Marcel Taeumel uploaded a new version of Kernel to project The Trunk:
http://source.squeak.org/trunk/Kernel-jar.1501.mcz
==================== Summary ====================
Name: Kernel-jar.1501
Author: jar
Time: 15 February 2023, 4:46:08.266577 pm
UUID: df3048fe-826b-cd40-a21b-de4b7d285390
Ancestors: Kernel-eem.1498
fix and improve:
#terminate
- fix multiple termination issue
- use a helper method to improve readability;
#suspendAndReleaseCriticalSection
- improve algorithm to fix failing Sema/Mutex tests
- replace conditionals with class based methods;
#unwindAndStop:
- fix a bug (missing fake return value before jump)
#unwindTo: safely:
- fix a bug (missing nil check)
Complemented by KernelTests-jar.443 (set of Sema/Mutex/Proc tests)
This changeset replaces Kernel-jar.1498 (#terminate etc) - please remove from Inbox
=============== Diff against Kernel-eem.1498 ===============
Item was added:
+ ----- Method: BlockClosure>>valueAndWaitWhileUnwinding: (in category 'private') -----
+ valueAndWaitWhileUnwinding: contextToUnwind
+ "A helper method for Process terminate. Evaluate the receiver and suspend
+ current process until argument's sender chain is unwound."
+
+ | semaphore newBottom |
+ contextToUnwind ifNil: [^self].
+ semaphore := Semaphore new.
+ newBottom := contextToUnwind class contextEnsure: [semaphore signal].
+ contextToUnwind bottomContext insertSender: newBottom.
+ self value: contextToUnwind.
+ semaphore wait!
Item was added:
+ ----- Method: Context>>unwindAndStop: (in category 'private') -----
+ unwindAndStop: aProcess
+ "A helper method to Process #terminate. Create and answer
+ a helper stack for a terminating process to unwind itself from.
+ Note: push a fake return value to create a proper top context."
+
+ ^(self class contextEnsure: [self unwindTo: nil])
+ privSender: [aProcess suspend] asContext;
+ push: nil
+ !
Item was changed:
----- Method: Context>>unwindTo:safely: (in category 'private-exceptions') -----
unwindTo: aContext safely: aBoolean
"Unwind self to aContext to execute pending #ensure:/#ifCurtailed: argument blocks between self
and aContext. If aBoolean is false, unwind only blocks that have not run yet, otherwise complete all
pending unwind blocks including those currently in the middle of their execution; these blocks will
just finish their execution. Run all unwinds on their original stack using #runUntilReturnFrom:."
| top ctx |
ctx := top := self.
aBoolean ifTrue: [
"If self is the top context of a stack already halfways through an unwind block, complete the outer-most
unfinished unwind block first; all nested pending unwind blocks will be completed in the process;
see testTerminationDuringUnwind and tests in ProcessTest/UnwindTest.
Note: Halfway-through blocks have already set the complete variable (ctxt tempAt: 2) in their
defining #ensure:/#ifCurtailed contexts from nil to true; we'll search for the bottom-most one."
| outerMost |
ctx isUnwindContext ifFalse: [ctx := ctx findNextUnwindContextUpTo: aContext].
[ctx isNil] whileFalse: [
(ctx tempAt: 2) ifNotNil: [
outerMost := ctx].
ctx := ctx findNextUnwindContextUpTo: aContext].
outerMost ifNotNil: [top := top runUntilReturnFrom: outerMost]].
"By now no halfway-through unwind blocks are on the stack.
Note: top points to the former outerMost sender now, i.e. to the next context to be explored."
ctx := top ifNil: [^self].
"#findNextUnwindContextUpTo: starts searching from the receiver's sender so we must check
the receiver explicitly whether it is an unwind context; see testTerminateEnsureAsStackTop.
Create a new top context (i.e. a new branch off the original stack) for each pending unwind block
(ctxt tempAt: 1) and execute it on the unwind block's stack to evaluate non-local returns correctly."
ctx isUnwindContext ifFalse: [ctx := ctx findNextUnwindContextUpTo: aContext].
[ctx isNil] whileFalse: [
(ctx tempAt: 2) ifNil: [
ctx tempAt: 2 put: true.
+ (ctx tempAt: 1) ifNotNil: [:unwindBlock |
+ top := unwindBlock asContextWithSender: ctx.
+ top runUntilReturnFrom: top]].
- top := (ctx tempAt: 1) asContextWithSender: ctx.
- top runUntilReturnFrom: top].
ctx := ctx findNextUnwindContextUpTo: aContext]
"Note: Cf. the unwind pattern in the previous versions of unwindTo: (1999-2021). Using #value
instead of #runUntilReturnFrom: lead to a failure to evaluate some non-local returns correctly;
a non-local return must be evaluated in the evaluation context (sender chain) in which it was defined."!
Item was added:
+ ----- Method: Mutex>>releaseCriticalSection: (in category 'private') -----
+ releaseCriticalSection: aContext
+ "A helper method for Process suspendAndReleaseCriticalSection.
+ If the terminating process is still blocked at the condition variable
+ of a critical section, skip the rest of the current context."
+
+ ^aContext pc: aContext endPC!
Item was added:
+ ----- Method: Mutex>>stepIntoCriticalSection: (in category 'private') -----
+ stepIntoCriticalSection: aContext
+ "A helper method for Process suspendAndReleaseCriticalSection.
+ If the terminating process still haven't made progress beyond the lock primitive
+ and the lock primitive just acquired ownership (indicated by it answering false)
+ then the ensure block has not been activated, so step into it."
+
+ ^(aContext stackPtr > 0 and: [aContext top == false])
+ ifTrue: [aContext stepToCallee]
+ ifFalse: [aContext]!
Item was changed:
----- Method: Process>>suspendAndReleaseCriticalSection (in category 'private') -----
suspendAndReleaseCriticalSection
"Figure out if we are terminating a process that is in the ensure: block of a critical section.
If it hasn't made progress but is beyond the wait (which we can tell by the oldList being
+ one of the runnable lists, i.e. a LinkedList, not a Semaphore or Mutex), then the ensure:
+ block needs to be run. Answer a context chain that needs to be unwound."
- one of the runnable lists, i.e. a LinkedList, not a Semaphore or Mutex, et al), then the ensure:
- block needs to be run."
+ "Note 1: suspend and unblock the receiver from a condition variable using the old suspend
+ primitive #88; it answers the list the receiver was on before the suspension.
+ Note 2: condition variables' classes implement the actual releasing depending on their
+ implementation of #critical:; see Semaphore or Mutex (or any future extension's)
+ #releaseCriticalSection: and #stepIntoCriticalSection: and the discussion here:
+ http://forum.world.st/Solving-termination-of-critical-sections-in-the-conte…"
- | oldList selectorJustSent |
- "Suspend and unblock the receiver from a condition variable using suspend primitive #88.
- It answers the list the receiver was on before the suspension."
- oldList := self suspendAndUnblock.
- (oldList isNil or: [oldList class == LinkedList]) ifFalse: [^self].
+ | oldList |
+ oldList := self suspendAndUnblock ifNil: [LinkedList new].
+ ^suspendedContext ifNotNil: [:context |
+ suspendedContext := nil.
+ (context method pragmaAt: #criticalSection)
+ ifNil: [context]
+ ifNotNil: [oldList releaseCriticalSection: context]]!
- ((suspendedContext ifNil: [^self]) method pragmaAt: #criticalSection) ifNil: [^self].
- selectorJustSent := suspendedContext selectorJustSentOrSelf.
-
- "If still at the wait the ensure: block has not been activated, so signal to restore."
- selectorJustSent == #wait ifTrue:
- [suspendedContext receiver signal].
-
- "If still at the lock primitive and the lock primitive just acquired ownership (indicated by it answering false)
- then the ensure block has not been activated, so explicitly primitiveExitCriticalSection to unlock."
- (selectorJustSent == #primitiveEnterCriticalSection
- or: [selectorJustSent == #primitiveTestAndSetOwnershipOfCriticalSection]) ifTrue:
- [(suspendedContext stackPtr > 0
- and: [suspendedContext top == false]) ifTrue:
- [suspendedContext receiver primitiveExitCriticalSection]]!
Item was changed:
----- Method: Process>>terminate (in category 'changing process state') -----
+ terminate
+ "Stop the process that the receiver represents forever. Allow all pending unwind
+ blocks to run before terminating; if they are currently in progress, let them finish."
- terminate
- "Stop the process that the receiver represents forever.
- Unwind to execute pending #ensure:/#ifCurtailed: blocks before terminating;
- allow all unwind blocks to run; if they are currently in progress, let them finish."
+ "Note: This is the kind of behavior we expect when terminating a healthy process.
- "This is the kind of behavior we expect when terminating a healthy process.
See further comments in #terminateAggressively and #destroy methods dealing
with process termination when closing the debugger or after a catastrophic failure.
If terminating the active process, create a new stack and run unwinds from there.
If terminating a suspended process (including runnable and blocked), always
+ suspend the terminating process first so it doesn't accidentally get woken up,
+ and nil the suspended context to prevent accidental resumption or termination
+ while manipulating the suspended context.
+
- suspend the terminating process first so it doesn't accidentally get woken up.
Equally important is the side effect of the suspension: In 2022 a new suspend
semantics has been introduced: the revised #suspend backs up a process waiting
on a conditional variable to the send that invoked the wait state, while the previous
#suspend simply removed the process from the conditional variable's list it was
previously waiting on; see #suspend and #suspendAndUnblock comments.
+
+ If the process is blocked, waiting to access the #critical: section, release it properly.
-
- If the process is in the middle of a #critical: critical section, release it properly.
To allow a suspended process to unwind itself, create a new stack for the process
being terminated and resume the suspended process to complete its termination
+ from the new, parallel stack. Use a semaphore to make the process that invoked
- from the new parallel stack. Use a semaphore to make the process that invoked
the termination wait for self's completion. Execute the termination in the ensure
argument block to ensure it completes even if the terminator process itself gets
terminated before it's finished; see testTerminateInTerminate and others."
- | context |
self isActiveProcess ifTrue: [
+ ^(thisContext unwindAndStop: self) jump].
- context := thisContext.
- ^[[] ensure: [context unwindTo: nil]. self suspend] asContext jump].
+ [] ensure: [
+ [:contextToUnwind |
+ self
- [] ensure: [ | terminator |
- self suspendAndReleaseCriticalSection.
- context := suspendedContext ifNil: [^self].
- terminator := Semaphore new.
- context bottomContext insertSender: (Context contextEnsure: [terminator signal]).
- self suspendedContext: [[] ensure: [context unwindTo: nil]. self suspend] asContext;
priority: Processor activePriority;
+ suspendedContext: (contextToUnwind unwindAndStop: self);
+ resume
+ ] valueAndWaitWhileUnwinding: self suspendAndReleaseCriticalSection
+ ]!
- resume.
- terminator wait]!
Item was added:
+ ----- Method: Semaphore>>releaseCriticalSection: (in category 'private') -----
+ releaseCriticalSection: aContext
+ "A helper method for Process suspendAndReleaseCriticalSection.
+ If the terminating process is still blocked at the condition variable
+ of a critical section, skip the rest of the current context."
+
+ ^aContext pc: aContext endPC!
Item was added:
+ ----- Method: Semaphore>>stepIntoCriticalSection: (in category 'private') -----
+ stepIntoCriticalSection: aContext
+ "A helper method for Process suspendAndReleaseCriticalSection.
+ If the terminating process still haven't made progress beyond the wait
+ then the ensure block has not been activated, so step into it."
+
+ ^aContext stepToCallee!
1
0
Marcel Taeumel uploaded a new version of Kernel to project The Trunk:
http://source.squeak.org/trunk/Kernel-jar.1500.mcz
==================== Summary ====================
Name: Kernel-jar.1500
Author: jar
Time: 2 February 2023, 10:04:57.541211 pm
UUID: 8add6e35-4849-624a-94f8-0722d7ef8c07
Ancestors: Kernel-tpr.1497
Fix #terminateAggressively and #runUntilErrorOrReturnFrom: bugs. Both bugs combined cause the Debugger MNU in this situation:
Run this in the Workspace:
p := [ [Semaphore new wait] ensure: [1/0] ] fork
Then terminate it like this:
[p terminate] fork
And then just press Abandon and get the MNU error.
=============== Diff against Kernel-tpr.1497 ===============
Item was changed:
----- Method: Context>>runUntilErrorOrReturnFrom: (in category 'controlling') -----
runUntilErrorOrReturnFrom: aSender
"ASSUMES aSender is a sender of self. Execute self's stack until aSender returns or an unhandled exception is raised. Return a pair containing the new top context and a possibly nil exception. The exception is not nil if it was raised before aSender returned and it was not handled. The exception is returned rather than openning the debugger, giving the caller the choice of how to handle it."
"Self is run by jumping directly to it (the active process abandons thisContext and executes self). However, before jumping to self we insert an ensure block under aSender that jumps back to thisContext when evaluated. We also insert an exception handler under aSender that jumps back to thisContext when an unhandled exception is raised. In either case, the inserted ensure and exception handler are removed once control jumps back to thisContext."
| error ctxt here topContext |
here := thisContext.
"Insert ensure and exception handler contexts under aSender"
error := nil.
ctxt := aSender insertSender: (Context
contextOn: UnhandledError do: [:ex |
error ifNil: [
error := ex exception.
topContext := thisContext.
ex resumeUnchecked: here jump]
ifNotNil: [ex pass]
]).
ctxt := ctxt insertSender: (Context
contextEnsure: [error ifNil: [
topContext := thisContext.
here jump]
]).
self jump. "Control jumps to self"
"Control resumes here once above ensure block or exception handler is executed"
^ error ifNil: [
"No error was raised, remove ensure context by stepping until popped"
+ [ctxt isDead or: [topContext isNil]] whileFalse: [topContext := topContext stepToCallee].
- [ctxt isDead] whileFalse: [topContext := topContext stepToCallee].
{topContext. nil}
] ifNotNil: [
"Error was raised, remove inserted above contexts then return signaler context"
aSender terminateTo: ctxt sender. "remove above ensure and handler contexts"
{topContext. error}
]!
Item was changed:
----- Method: Process>>terminateAggressively (in category 'changing process state') -----
terminateAggressively
"Stop the receiver forever.
Run all unwind contexts (#ensure:/#ifCurtailed: blocks) on the stack that have not yet been started. If the process is in the middle of an unwind block, then that unwind block will not be completed, but subsequent unwind blocks will be run. If even those unwind contexts should be continued, send #terminate instead.
Note that ill unwind contexts are theoretically able to stall the termination (for instance, by placing a non-local return in an unwind block); however, this is a disrecommended practice.
If the process is in the middle of a critical: critical section, release it properly."
| oldList bottom tombstone |
self isActiveProcess ifTrue: [
"If terminating the active process, suspend it first and terminate it as a suspended process."
[self terminate] fork.
^self suspend].
"Always suspend the process first so it doesn't accidentally get woken up.
N.B.: If oldList is a LinkedList then the process is runnable. If it is a Semaphore/Mutex et al., then the process is blocked."
oldList := self suspend.
suspendedContext ifNil: [^ self "Process is already terminated"].
"Release any method marked with the <criticalSection> pragma. The argument is whether the process is runnable."
self releaseCriticalSection: (oldList isNil or: [oldList class == LinkedList]).
bottom := suspendedContext bottomContext.
tombstone := bottom insertSender: [self suspend "terminated"] asContext.
suspendedContext := self
activateReturn: bottom
value: nil.
self complete: tombstone ifError: [:ex |
+ (suspendedContext ifNil: [^self]) privRefresh. "Restart the handler context of UnhandledError so that when the receiver is resumed, its #defaultAction will be reached. See implementation details in #runUntilErrorOrReturnFrom:."
- suspendedContext privRefresh. "Restart the handler context of UnhandledError so that when the receiver is resumed, its #defaultAction will be reached. See implementation details in #runUntilErrorOrReturnFrom:."
"We're not yet done, resume the receiver to spawn a new debugger on the error."
self resume].!
1
0
Marcel Taeumel uploaded a new version of Collections to project The Trunk:
http://source.squeak.org/trunk/Collections-jar.1028.mcz
==================== Summary ====================
Name: Collections-jar.1028
Author: jar
Time: 16 February 2023, 8:00:13.16881 am
UUID: 60a0cd75-df99-1942-8d6a-3fbe0615b1aa
Ancestors: Collections-mt.1027
complement Kernel-jar.1501 (#terminate etc)
=============== Diff against Collections-mt.1027 ===============
Item was added:
+ ----- Method: LinkedList>>releaseCriticalSection: (in category 'private') -----
+ releaseCriticalSection: aContext
+ "A helper method for Process suspendAndReleaseCriticalSection;
+ aContext receiver represents a condition variable, i.e. a Semaphore
+ or a Mutex (or any other in case of future new condition variables),
+ which will take care of releasing the critical section properly."
+
+ ^aContext receiver stepIntoCriticalSection: aContext!
1
0
Marcel Taeumel uploaded a new version of Tools to project The Trunk:
http://source.squeak.org/trunk/Tools-mt.1190.mcz
==================== Summary ====================
Name: Tools-mt.1190
Author: mt
Time: 16 February 2023, 9:38:41.897287 am
UUID: 91daa1d9-9457-f646-a5d2-32fbd45dd79b
Ancestors: Tools-mt.1189, Tools-jar.1189
Complement Kernel-mt.1504
=============== Diff against Tools-mt.1189 ===============
Item was changed:
----- Method: Debugger>>send (in category 'context stack menu') -----
send
"Send the selected message in the accessed method, and take control in
the method invoked to allow further step or send."
+ | newContext currentContext |
self okToChange ifFalse: [^ self].
self interruptedProcessIsReady ifFalse: [^ self shouldNotStep].
self checkContextSelection.
+ currentContext := self selectedContext.
+ self handleLabelUpdatesIn:
+ [interruptedProcess step: currentContext]
+ whenExecuting: currentContext.
- interruptedProcess step: self selectedContext.
interruptedProcess ifNil: [^ self shouldNotStep].
+ newContext := interruptedProcess stepToSendOrReturn.
+ self updateProcess.
+ self contextStackIndex > 1
+ ifTrue: [self resetContext: newContext]
+ ifFalse:
+ [newContext == currentContext
+ ifTrue: [self changed: #contentsSelection.
+ self updateInspectors]
+ ifFalse: [self resetContext: newContext]]!
- self resetContext: interruptedProcess stepToSendOrReturn.!
1
0
Marcel Taeumel uploaded a new version of KernelTests to project The Trunk:
http://source.squeak.org/trunk/KernelTests-mt.444.mcz
==================== Summary ====================
Name: KernelTests-mt.444
Author: mt
Time: 16 February 2023, 9:38:13.146287 am
UUID: e53ab079-320a-0443-978a-24f1e5d386d6
Ancestors: KernelTests-jar.443, KernelTests-jar.442
Complement Kernel-mt.1504
=============== Diff against KernelTests-tpr.441 ===============
Item was changed:
TestCase subclass: #MonitorTest
+ instanceVariableNames: 'semaphore'
- instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'KernelTests-Processes'!
Item was added:
+ ----- Method: MonitorTest>>setUp (in category 'as yet unclassified') -----
+ setUp
+
+ super setUp.
+ semaphore := Semaphore new.!
Item was added:
+ ----- Method: MonitorTest>>tearDown (in category 'as yet unclassified') -----
+ tearDown
+ "Release all processes still waiting at the semaphore or in the active priority queue."
+
+ Processor yield.
+ [semaphore isEmpty] whileFalse: [semaphore signal].
+
+ super tearDown.!
Item was changed:
----- Method: MonitorTest>>testCheckOwnerProcess (in category 'tests') -----
testCheckOwnerProcess
self should: [Monitor new checkOwnerProcess]
raise: Error.
self shouldnt: [| m | m := Monitor new. m critical: [m checkOwnerProcess]]
raise: Error.
self should: [| s m |
m := Monitor new.
+ [m critical: [s := #in. semaphore wait]] fork.
- [m critical: [s := #in. Semaphore new wait]] fork.
Processor yield.
self assert: #in equals: s.
m checkOwnerProcess]
raise: Error!
Item was changed:
----- Method: MonitorTest>>testCriticalIfLocked (in category 'tests') -----
testCriticalIfLocked
| m s |
m := Monitor new.
self assert: #unlocked == (m critical: [#unlocked] ifLocked: [#locked]).
+ [m critical: [s := #in. semaphore wait]] fork.
- [m critical: [s := #in. Semaphore new wait]] fork.
Processor yield.
self assert: #in equals: s.
self assert: #locked equals: (m critical: [#unlocked] ifLocked: [#locked])!
Item was removed:
- ----- Method: MutexTest>>expectedFailures (in category 'failures') -----
- expectedFailures
-
- ^ #(testUnwindMutexBlockedInCritical)!
Item was added:
+ ----- Method: MutexTest>>testMutexAfterCriticalWait2 (in category 'tests') -----
+ testMutexAfterCriticalWait2
+ "This tests whether a process that has just left the primitiveEnterCriticalSection in Mutex>>critical:
+ leaves it with the mutex correctly released."
+ | lock p beenHere |
+ lock := Mutex new. beenHere := false.
+ p := [lock critical: [beenHere := true]] newProcess.
+ p priority: Processor activePriority - 1.
+ lock critical: "We now own it; p can't enter properly"
+ [p resume.
+ "wait until p enters the critical section; it doesn't own the Mutex so is blocked..."
+ [p suspendingList == lock] whileFalse: [(Delay forMilliseconds: 10) wait].
+ self deny: lock isEmpty].
+ "p is waiting on lock; on our exiting critical: p is now the notional owner. Terminate before it has a chance to run".
+ p terminate.
+ self deny: lock isOwned.
+ self assert: lock isEmpty.
+ self deny: beenHere!
Item was added:
+ ----- Method: MutexTest>>testMutexAfterCriticalWaitCf (in category 'tests') -----
+ testMutexAfterCriticalWaitCf
+ "This tests whether a process that has just left the primitiveEnterCriticalSection in Mutex>>critical:
+ leaves it with the mutex correctly released."
+ | lock p beenHere |
+ lock := Mutex new. beenHere := false.
+ p := [lock critical: [beenHere := true]] newProcess.
+ p priority: Processor activePriority - 1.
+ lock critical: "We now own it; p can't enter properly"
+ [p resume.
+ "wait until p enters the critical section; it doesn't own the Mutex so is blocked..."
+ [p suspendingList == lock] whileFalse: [(Delay forMilliseconds: 10) wait].
+ self deny: lock isEmpty.
+ "p is waiting on lock; on our exiting critical: p is now the notional owner. Terminate before it has a chance to run".
+ p terminate].
+ self deny: lock isOwned.
+ self assert: lock isEmpty.
+ self deny: beenHere!
Item was added:
+ ----- Method: MutexTest>>testMutexAfterCriticalWaitInEnsure (in category 'tests') -----
+ testMutexAfterCriticalWaitInEnsure
+ "This tests whether a process that has just left the primitiveEnterCriticalSection in Mutex>>critical:
+ leaves it with the mutex correctly released."
+ | lock p |
+ lock := Mutex new.
+ p := [[] ensure: [lock critical: []]] newProcess.
+ p priority: Processor activePriority - 1.
+ lock critical: "We now own it; p can't enter properly"
+ [p resume.
+ "wait until p enters the critical section; it doesn't own the Mutex so is blocked..."
+ [p suspendingList == lock] whileFalse: [(Delay forMilliseconds: 10) wait].
+ self deny: lock isEmpty].
+ "p is waiting on lock; on our exiting critical: p is now the notional owner. Terminate before it has a chance to run".
+ p terminate.
+ self deny: lock isOwned.
+ self assert: lock isEmpty!
Item was added:
+ ----- Method: MutexTest>>testMutexAfterCriticalWaitInEnsure2 (in category 'tests') -----
+ testMutexAfterCriticalWaitInEnsure2
+ "This tests whether a process that has just left the primitiveEnterCriticalSection in Mutex>>critical:
+ leaves it with the mutex correctly released."
+ | lock p beenHere |
+ lock := Mutex new. beenHere := false.
+ p := [[] ensure: [lock critical: [beenHere := true]]] newProcess.
+ p priority: Processor activePriority - 1.
+ lock critical: "We now own it; p can't enter properly"
+ [p resume.
+ "wait until p enters the critical section; it doesn't own the Mutex so is blocked..."
+ [p suspendingList == lock] whileFalse: [(Delay forMilliseconds: 10) wait].
+ self deny: lock isEmpty].
+ "p is waiting on lock; on our exiting critical: p is now the notional owner. Terminate before it has a chance to run".
+ p terminate.
+ self deny: lock isOwned.
+ self assert: lock isEmpty.
+ self assert: beenHere!
Item was added:
+ ----- Method: MutexTest>>testMutexAfterCriticalWaitInEnsureCf (in category 'tests') -----
+ testMutexAfterCriticalWaitInEnsureCf
+ "This tests whether a process that has just left the primitiveEnterCriticalSection in Mutex>>critical:
+ leaves it with the mutex correctly released."
+ | lock p beenHere |
+ lock := Mutex new. beenHere := false.
+ p := [[] ensure: [lock critical: [beenHere := true]]] newProcess.
+ p priority: Processor activePriority - 1.
+ lock critical: "We now own it; p can't enter properly"
+ [p resume.
+ "wait until p enters the critical section; it doesn't own the Mutex so is blocked..."
+ [p suspendingList == lock] whileFalse: [(Delay forMilliseconds: 10) wait].
+ self deny: lock isEmpty.
+ "p is waiting on lock; on our exiting critical: p is now the notional owner. Terminate before it has a chance to run".
+ p terminate].
+ self deny: lock isOwned.
+ self assert: lock isEmpty.
+ self deny: beenHere!
Item was added:
+ ----- Method: MutexTest>>testMutexBlockedInCritical (in category 'tests') -----
+ testMutexBlockedInCritical
+ "This tests whether a process that is inside the primitiveEnterCriticalSection in Mutex>>critical:
+ leaves it unchanged."
+ | lock sock proc wait |
+ lock := Mutex new.
+ sock := Semaphore new.
+ proc := [lock critical: [sock wait]] fork.
+ wait := [lock critical: []] fork.
+ Processor yield.
+ self assert: proc suspendingList == sock.
+ self assert: wait suspendingList == lock.
+ self deny: lock isEmpty.
+ self assert: lock isOwned.
+ wait terminate.
+ Processor yield.
+ self assert: wait isTerminated.
+ self assert: proc suspendingList == sock.
+ self assert: wait suspendingList == nil.
+ self assert: lock isEmpty.
+ self assert: lock isOwned.
+ proc terminate!
Item was added:
+ ----- Method: MutexTest>>testMutexBlockedInCritical2 (in category 'tests') -----
+ testMutexBlockedInCritical2
+ "This tests whether a process that is inside the primitiveEnterCriticalSection in Mutex>>critical:
+ leaves it unchanged."
+ | lock sock proc wait beenHere beenHereToo |
+ lock := Mutex new.
+ sock := Semaphore new.
+ beenHere := beenHereToo := false.
+ proc := [lock critical: [sock wait]] fork.
+ wait := [lock critical: [beenHere := true]. beenHereToo := true] fork.
+ Processor yield.
+ self assert: proc suspendingList == sock.
+ self assert: wait suspendingList == lock.
+ self deny: lock isEmpty.
+ self assert: lock isOwned.
+ wait terminate.
+ Processor yield.
+ self assert: wait isTerminated.
+ self assert: proc suspendingList == sock.
+ self assert: wait suspendingList == nil.
+ self assert: lock isEmpty.
+ self assert: lock isOwned.
+ self deny: beenHere.
+ self deny: beenHereToo.
+ proc terminate!
Item was added:
+ ----- Method: MutexTest>>testMutexBlockedInCriticalInEnsure (in category 'tests') -----
+ testMutexBlockedInCriticalInEnsure
+ "This tests whether a process that is inside the primitiveEnterCriticalSection in Mutex>>critical:
+ leaves it unchanged."
+ | lock sock proc wait |
+ lock := Mutex new.
+ sock := Semaphore new.
+ proc := [lock critical: [sock wait]] fork.
+ wait := [[] ensure: [lock critical: []]] fork.
+ Processor yield.
+ self assert: proc suspendingList == sock.
+ self assert: wait suspendingList == lock.
+ self deny: lock isEmpty.
+ self assert: lock isOwned.
+ wait terminate.
+ Processor yield.
+ self assert: wait isTerminated.
+ self assert: proc suspendingList == sock.
+ self assert: wait suspendingList == nil.
+ self assert: lock isEmpty.
+ self assert: lock isOwned.
+ proc terminate!
Item was added:
+ ----- Method: MutexTest>>testMutexBlockedInCriticalInEnsure2 (in category 'tests') -----
+ testMutexBlockedInCriticalInEnsure2
+ "This tests whether a process that is inside the primitiveEnterCriticalSection in Mutex>>critical:
+ leaves it unchanged."
+ | lock sock proc wait beenHere beenHereToo |
+ lock := Mutex new.
+ sock := Semaphore new.
+ beenHere := beenHereToo := false.
+ proc := [lock critical: [sock wait]] fork.
+ wait := [[] ensure: [lock critical: [beenHere := true]. beenHereToo := true]] fork.
+ Processor yield.
+ self assert: proc suspendingList == sock.
+ self assert: wait suspendingList == lock.
+ self deny: lock isEmpty.
+ self assert: lock isOwned.
+ wait terminate.
+ Processor yield.
+ self assert: wait isTerminated.
+ self assert: proc suspendingList == sock.
+ self assert: wait suspendingList == nil.
+ self assert: lock isEmpty.
+ self assert: lock isOwned.
+ self deny: beenHere.
+ self assert: beenHereToo.
+ proc terminate!
Item was added:
+ ----- Method: MutexTest>>testMutexInCriticalWait2 (in category 'tests') -----
+ testMutexInCriticalWait2
+ "This tests whether a process that has got past the primitiveEnterCriticalSection in Mutex>>critical:
+ leaves it unowned."
+ | lock sock proc beenHere beenHereToo |
+ lock := Mutex new.
+ sock := Semaphore new.
+ beenHere := beenHereToo := false.
+ proc := [lock critical: [sock wait. beenHere := true]. beenHereToo := true] fork.
+ Processor yield.
+ self assert: proc suspendingList == sock.
+ proc terminate.
+ self deny: lock isOwned.
+ self assert: lock isEmpty.
+ self deny: beenHere.
+ self deny: beenHereToo!
Item was added:
+ ----- Method: MutexTest>>testMutexInCriticalWaitInEnsure (in category 'tests') -----
+ testMutexInCriticalWaitInEnsure
+ "This tests whether a process that has got past the primitiveEnterCriticalSection in Mutex>>critical:
+ leaves it unowned."
+ | lock sock proc |
+ lock := Mutex new.
+ sock := Semaphore new.
+ proc := [[] ensure: [lock critical: [sock wait]]] fork.
+ Processor yield.
+ self assert: proc suspendingList == sock.
+ proc terminate.
+ self deny: lock isOwned.
+ self assert: lock isEmpty!
Item was added:
+ ----- Method: MutexTest>>testMutexInCriticalWaitInEnsure2 (in category 'tests') -----
+ testMutexInCriticalWaitInEnsure2
+ "This tests whether a process that has got past the primitiveEnterCriticalSection in Mutex>>critical:
+ leaves it unowned."
+ | lock sock proc beenHere beenHereToo |
+ lock := Mutex new.
+ sock := Semaphore new.
+ beenHere := beenHereToo := false.
+ proc := [[] ensure: [lock critical: [sock wait. beenHere := true]. beenHereToo := true]] fork.
+ Processor yield.
+ self assert: proc suspendingList == sock.
+ proc terminate.
+ self deny: lock isOwned.
+ self assert: lock isEmpty.
+ self assert: beenHere.
+ self assert: beenHereToo!
Item was removed:
- ----- Method: MutexTest>>testUnwindMutexBlockedInCritical (in category 'tests') -----
- testUnwindMutexBlockedInCritical "self run: #testMutexBlockedInCritical"
- "This tests whether a mutex that is inside the primitiveEnterCriticalSection in Mutex>>critical:
- leaves it unchanged."
- | lock sock proc wait |
- lock := Mutex new.
- sock := Semaphore new.
- proc := [lock critical: [sock wait]] fork.
- wait := [[] ensure: [lock critical: []]] fork.
- Processor yield.
- self assert: proc suspendingList == sock.
- self assert: wait suspendingList == lock.
- self deny: lock isEmpty.
- self assert: lock isOwned.
- wait terminate.
- Processor yield.
- self assert: wait isTerminated.
- self assert: proc suspendingList == sock.
- self assert: wait suspendingList == nil.
- self assert: lock isEmpty.
- self assert: lock isOwned
- !
Item was removed:
- ----- Method: ProcessTest>>expectedFailures (in category 'failures') -----
- expectedFailures
-
- ^ #(testTerminateTerminatingProcess testResumeTerminatingProcess)!
Item was changed:
----- Method: ProcessTest>>testResumeTerminatingProcess (in category 'tests') -----
testResumeTerminatingProcess
+ "An attempt to resume a terminating process in the middle of preparing its suspended context should raise an error;
+ one possible solution is to nil the suspended context of the terminating process while executing the vulnerable code"
+
+ "Note: another solution could be to run the vulnerable part of the code in #terminate using #valueUnpreemptively;
+ currently, however, #valueUnpreemptively is affected by the #priority: bug described here:
+ http://lists.squeakfoundation.org/pipermail/squeak-dev/2021-December/217473…"
- "An attempt to resume a terminating process should probably raise an error;
- leave this test as an expected failure for the moment."
+ | terminatee terminator unwound |
+ unwound := false.
+ terminatee := [[Processor activeProcess suspend] ensure: [unwound := unwound not]] newProcess.
+ terminatee priority: Processor activePriority + 1.
+ terminatee resume.
- | terminatee terminator resumed |
- terminatee := [semaphore critical:[]. resumed := true] fork.
- Processor yield.
terminator := [terminatee terminate] newProcess.
+ terminator priority: Processor activePriority + 1.
+ self assert: terminatee isSuspended.
- self assert: terminatee suspendingList == semaphore.
self assert: terminator isSuspended.
"run terminator and stop inside #terminate"
+ [terminator suspendedContext selectorToSendOrSelf == #bottomContext] whileFalse: [terminator step].
+ self assert: terminatee suspendedContext isNil.
+ self deny: unwound.
- terminator runUntil: [:ctx | ctx selectorToSendOrSelf = #priority:].
self assert: terminator isSuspended.
+ "resuming the terminatee process should causes the VM to raise an error while its suspended context is nil"
- "resume the terminatee process and and check if the VM raises an error;
- an error is expected because terminatee's suspendedContext equals nil"
self should: [terminatee resume] raise: Error.
+ self assert: terminatee suspendedContext isNil.
+ self deny: unwound.
+ self assert: terminator isSuspended.
+ "now let the terminator finish its interrupted termination of the terminatee process"
- "now let the terminator finish terminating the terminatee process"
terminator resume.
- Processor yield.
- self assert: resumed isNil.
self assert: terminatee isTerminated.
+ self assert: unwound.
self assert: terminator isTerminated!
Item was changed:
----- Method: ProcessTest>>testTerminateTerminatingProcess (in category 'tests') -----
testTerminateTerminatingProcess
+ "An attempt to terminate a terminating process in the middle of preparing its suspended context should do nothing;
+ one possible solution is to nil the suspended context of the terminating process while executing the vulnerable code."
+
+ "Note: another solution could be to run the vulnerable part of the code in #terminate using #valueUnpreemptively;
+ currently, however, #valueUnpreemptively is affected by the #priority: bug described here:
+ http://lists.squeakfoundation.org/pipermail/squeak-dev/2021-December/217473…"
- "An attempt to terminate a terminating process should probably raise an error;
- leave this test as an expected failure for the moment."
+ | terminatee terminator unwound |
+ unwound := false.
+ terminatee := [[Processor activeProcess suspend] ensure: [unwound := unwound not]] newProcess.
+ terminatee priority: Processor activePriority + 1.
+ terminatee resume.
- | terminatee terminator resumed |
- terminatee := [semaphore critical:[]. resumed := true] fork.
- Processor yield.
terminator := [terminatee terminate] newProcess.
+ terminator priority: Processor activePriority + 1.
+ self assert: terminatee isSuspended.
- self assert: terminatee suspendingList == semaphore.
self assert: terminator isSuspended.
"run terminator and stop inside #terminate"
+ [terminator suspendedContext selectorToSendOrSelf == #bottomContext] whileFalse: [terminator step].
+ self assert: terminatee suspendedContext isNil.
+ self deny: unwound.
- terminator runUntil: [:ctx | ctx selectorToSendOrSelf = #priority:].
self assert: terminator isSuspended.
+ "terminating the terminatee process again should make no difference while its suspended context is nil"
+ terminatee terminate.
+ self assert: terminatee suspendedContext isNil.
+ self deny: unwound.
+ self assert: terminator isSuspended.
+ "now let the terminator finish its interrupted termination of the terminatee process"
- "terminate the terminatee process again and let the termination finish;
- an error is expected because #terminate detected multiple termination"
- self should: [terminatee terminate] raise: Error.
- "now let the terminator finish terminating the terminatee process"
terminator resume.
- Processor yield.
- self assert: resumed isNil.
self assert: terminatee isTerminated.
+ self assert: unwound.
self assert: terminator isTerminated!
Item was added:
+ ----- Method: ProcessTest>>testTerminateTerminatingProcessBeforeUnwindTo (in category 'tests') -----
+ testTerminateTerminatingProcessBeforeUnwindTo
+ "Terminating a terminatee process after the terminator process restarted the terminatee
+ process should unwind the terminatee process and let the terminator process terminate."
+
+ | terminator terminatee unwound |
+ unwound := false.
+ terminatee := [[Semaphore new wait] ensure: [unwound := true]] fork.
+ Processor yield.
+ terminator := [terminatee terminate] newProcess.
+ self assert: terminatee isBlocked.
+ self assert: terminator isSuspended.
+ terminator runUntil: [:ctx | ctx selectorToSendOrSelf = #resume].
+ "terminator steps until terminatee's unwind context is set"
+ terminator suspendedContext nextInstruction. "skip terminatee resume instruction"
+ terminator resume. "and run until parked at wait"
+ "terminatee is inside its helper stack, about to call #unwindTo:"
+ self assert: terminatee isSuspended.
+ terminatee terminate.
+ self assert: terminatee isTerminated.
+ self assert: unwound.
+ Processor yield.
+ self assert: terminator isTerminated!
Item was removed:
- ----- Method: SemaphoreTest>>expectedFailures (in category 'failures') -----
- expectedFailures
-
- ^ #(testUnwindSemaInCriticalWait)!
Item was added:
+ ----- Method: SemaphoreTest>>testSemaAfterCriticalWait2 (in category 'tests') -----
+ testSemaAfterCriticalWait2
+ "This tests whether a process that has just left the wait in Semaphore>>critical:
+ leaves it with signaling the associated semaphore."
+ | s p beenHere |
+ s := Semaphore new. beenHere := false.
+ p := [s critical: [beenHere := true]] forkAt: Processor activePriority-1.
+ "wait until p entered the critical section"
+ [p suspendingList == s] whileFalse: [(Delay forMilliseconds: 10) wait].
+ "Now that p entered it, signal the semaphore. p now 'owns' the semaphore
+ but since we are running at higher priority than p it will not get to do
+ anything."
+ s signal.
+ p terminate.
+ self assert: 1 equals: s excessSignals.
+ self deny: beenHere!
Item was added:
+ ----- Method: SemaphoreTest>>testSemaAfterCriticalWaitInEnsure (in category 'tests') -----
+ testSemaAfterCriticalWaitInEnsure
+ "This tests whether a process that has just left the wait in Semaphore>>critical:
+ leaves it with signaling the associated semaphore."
+ | s p |
+ s := Semaphore new.
+ p := [[] ensure: [s critical:[]]] forkAt: Processor activePriority-1.
+ "wait until p entered the critical section"
+ [p suspendingList == s] whileFalse: [(Delay forMilliseconds: 10) wait].
+ "Now that p entered it, signal the semaphore. p now 'owns' the semaphore
+ but since we are running at higher priority than p it will not get to do
+ anything."
+ s signal.
+ p terminate.
+ self assert: 1 equals: s excessSignals!
Item was added:
+ ----- Method: SemaphoreTest>>testSemaAfterCriticalWaitInEnsure2 (in category 'tests') -----
+ testSemaAfterCriticalWaitInEnsure2
+ "This tests whether a process that has just left the wait in Semaphore>>critical:
+ leaves it with signaling the associated semaphore."
+ | s p beenHere |
+ s := Semaphore new. beenHere := false.
+ p := [[] ensure: [s critical: [beenHere := true]]] forkAt: Processor activePriority-1.
+ "wait until p entered the critical section"
+ [p suspendingList == s] whileFalse: [(Delay forMilliseconds: 10) wait].
+ "Now that p entered it, signal the semaphore. p now 'owns' the semaphore
+ but since we are running at higher priority than p it will not get to do
+ anything."
+ s signal.
+ p terminate.
+ self assert: 1 equals: s excessSignals.
+ self assert: beenHere!
Item was added:
+ ----- Method: SemaphoreTest>>testSemaInCriticalWait2 (in category 'tests') -----
+ testSemaInCriticalWait2
+ "This tests whether a process that has entered the wait in Semaphore>>critical:
+ leaves it without signaling the associated semaphore."
+ | s p beenHere |
+ s := Semaphore new. beenHere := false.
+ p := [s critical: [beenHere := true]] fork.
+ Processor yield.
+ self assert: s equals: p suspendingList.
+ p terminate.
+ self assert: 0 equals: s excessSignals.
+ self deny: beenHere!
Item was added:
+ ----- Method: SemaphoreTest>>testSemaInCriticalWaitInEnsure (in category 'tests') -----
+ testSemaInCriticalWaitInEnsure
+ "This tests whether a process that has entered the wait in Semaphore>>critical:
+ leaves it without signaling the associated semaphore."
+ | s p |
+ s := Semaphore new.
+ p := [[] ensure: [s critical: []]] fork.
+ Processor yield.
+ self assert: s equals: p suspendingList.
+ p terminate.
+ self assert: 0 equals: s excessSignals!
Item was added:
+ ----- Method: SemaphoreTest>>testSemaInCriticalWaitInEnsure2 (in category 'tests') -----
+ testSemaInCriticalWaitInEnsure2
+ "This tests whether a process that has entered the wait in Semaphore>>critical:
+ leaves it without signaling the associated semaphore."
+ | s p beenHere |
+ s := Semaphore new. beenHere := false.
+ p := [[] ensure: [s critical: [beenHere := true]]] fork.
+ Processor yield.
+ self assert: s equals: p suspendingList.
+ p terminate.
+ self assert: 0 equals: s excessSignals.
+ self deny: beenHere!
Item was removed:
- ----- Method: SemaphoreTest>>testUnwindSemaInCriticalWait (in category 'tests') -----
- testUnwindSemaInCriticalWait "self run: #testSemaInCriticalWait"
- "This tests whether a semaphore that has entered the wait in Semaphore>>critical:
- leaves it without signaling the associated semaphore."
- | s p |
- s := Semaphore new.
- p := [[] ensure: [s critical:[]]] fork.
- Processor yield.
- self assert:(p suspendingList == s).
- p terminate.
- self assert: 0 equals: s excessSignals!
1
0
Marcel Taeumel uploaded a new version of Kernel to project The Trunk:
http://source.squeak.org/trunk/Kernel-mt.1504.mcz
==================== Summary ====================
Name: Kernel-mt.1504
Author: mt
Time: 16 February 2023, 9:37:50.549287 am
UUID: 213eecba-61aa-fc4d-bae3-52aaf4eaa8c0
Ancestors: Kernel-jar.1500, Kernel-jar.1501, Kernel-jar.1502, Kernel-jar.1503
Merge, merge, merge. :-) Big thanks to Jaromir (jar)!!
Kernel-jar.1500:
Fix #terminateAggressively and #runUntilErrorOrReturnFrom: bugs. Both bugs combined cause the Debugger MNU in this situation: [...]
Kernel-jar.1501:
fix and improve: #terminate [...] #suspendAndReleaseCriticalSection [...] #unwindAndStop: [...] #unwindTo: safely: [...]
Kernel-jar.1502:
make Context #methodReturnContexts a synonym of #home;
make BlockClosure and FullBlockClosure #homeMethod synonyms of #method [...]
Kernel-jar.1503:
remove unwind code duplication and fix the "stepOver bug" (Cannot #stepOver '^2' in example '[^2] ensure: []') [...]
=============== Diff against Kernel-tpr.1497 ===============
Item was changed:
----- Method: BlockClosure>>hasMethodReturn (in category 'testing') -----
hasMethodReturn
"Answer whether the receiver has a method-return ('^') in its code."
| scanner endpc |
+ scanner := InstructionStream new method: self method pc: startpcOrMethod.
- scanner := InstructionStream new method: outerContext method pc: startpcOrMethod.
endpc := self endPC.
+ scanner scanFor:
+ [:byte |
+ scanner willReturn ifTrue:
+ [scanner willBlockReturn ifFalse:
+ [^true]].
+ scanner pc >= endpc].
+ ^false!
- scanner scanFor: [:byte | (byte between: 120 and: 124) or: [scanner pc > endpc]].
- ^scanner pc <= endpc!
Item was changed:
----- Method: BlockClosure>>homeMethod (in category 'accessing') -----
homeMethod
+ "Answer the home method associated with the receiver.
+ This is polymorphic with BlockClosure, CompiledCode, Context etc."
+
+ ^self method!
- ^outerContext method!
Item was added:
+ ----- Method: BlockClosure>>valueAndWaitWhileUnwinding: (in category 'private') -----
+ valueAndWaitWhileUnwinding: contextToUnwind
+ "A helper method for Process terminate. Evaluate the receiver and suspend
+ current process until argument's sender chain is unwound."
+
+ | semaphore newBottom |
+ contextToUnwind ifNil: [^self].
+ semaphore := Semaphore new.
+ newBottom := contextToUnwind class contextEnsure: [semaphore signal].
+ contextToUnwind bottomContext insertSender: newBottom.
+ self value: contextToUnwind.
+ semaphore wait!
Item was removed:
- ----- Method: CompiledBlock>>homeMethod (in category 'accessing') -----
- homeMethod
- "answer the compiled method that I am installed in, or nil if none."
- ^self outerCode homeMethod!
Item was changed:
----- Method: CompiledCode>>homeMethod (in category 'accessing') -----
homeMethod
+ "Answer the home method associated with the receiver.
+ This is polymorphic with BlockClosure, CompiledCode, Context etc."
- "Answer the home method associated with the receiver."
+ ^self method!
- ^self subclassResponsibility!
Item was removed:
- ----- Method: CompiledMethod>>homeMethod (in category 'accessing') -----
- homeMethod
- "Answer the home method associated with the receiver.
- This is polymorphic with closure, CompiledBlock, Context etc"
-
- ^self!
Item was changed:
----- Method: Context>>home (in category 'accessing') -----
home
+ "Answer the outermost context (along the static chain) for the receiver.
+ This is the outermost lexical scope in which the receiver's method is defined."
- "Answer the context in which the receiver was defined."
+ ^closureOrNil
+ ifNil: [self] "normal method activation"
+ ifNotNil: "block activation"
+ [:closure|
+ closure outerContext
+ ifNil: [self] "clean block"
+ ifNotNil: [:outerContext| outerContext home]] "normal block"!
- closureOrNil == nil ifTrue:
- [^self].
- ^closureOrNil outerContext home!
Item was changed:
----- Method: Context>>homeMethod (in category 'accessing') -----
homeMethod
"Answer the home method associated with the receiver.
+ This is polymorphic with BlockClosure, CompiledCode, Context etc."
+
+ ^self method!
- This is polymorphic with BlockClosure, CompiledCode, etc"
- ^method homeMethod!
Item was changed:
----- Method: Context>>methodReturnContext (in category 'accessing') -----
methodReturnContext
"Answer the context from which an ^-return should return from."
+ ^self home!
- closureOrNil == nil ifTrue:
- [^self].
- ^closureOrNil outerContext methodReturnContext!
Item was changed:
----- Method: Context>>restart (in category 'controlling') -----
restart
"Unwind thisContext to self and resume from beginning. Execute unwind blocks when unwinding. ASSUMES self is a sender of thisContext"
+ ^self resumeEvaluating: [self privRefresh]!
- | ctxt unwindBlock |
- self isDead ifTrue: [self cannotReturn: nil to: self].
- self privRefresh.
- ctxt := thisContext.
- [ ctxt := ctxt findNextUnwindContextUpTo: self.
- ctxt isNil
- ] whileFalse: [
- (ctxt tempAt: 2) ifNil:[
- ctxt tempAt: 2 put: true.
- unwindBlock := ctxt tempAt: 1.
- thisContext terminateTo: ctxt.
- unwindBlock value].
- ].
- thisContext terminateTo: self.
- self jump.
- !
Item was changed:
----- Method: Context>>resume:through: (in category 'controlling') -----
resume: value through: firstUnwindCtxt
"Unwind thisContext to self and resume with value as result of last send.
Execute any unwind blocks while unwinding.
ASSUMES self is a sender of thisContext."
+ ^self resumeEvaluating: [value] through: firstUnwindCtxt!
- | ctxt unwindBlock |
- self isDead ifTrue: [self cannotReturn: value to: self].
- ctxt := firstUnwindCtxt.
- [ctxt isNil] whileFalse:
- [(ctxt tempAt: 2) ifNil:
- [ctxt tempAt: 2 put: true.
- unwindBlock := ctxt tempAt: 1.
- thisContext terminateTo: ctxt.
- unwindBlock value].
- ctxt := ctxt findNextUnwindContextUpTo: self].
- thisContext terminateTo: self.
- ^value
- !
Item was changed:
----- Method: Context>>resumeEvaluating: (in category 'controlling') -----
resumeEvaluating: aBlock
"Unwind thisContext to self and resume with value as result of last send.
Execute unwind blocks when unwinding.
ASSUMES self is a sender of thisContext"
+ ^self resumeEvaluating: aBlock through: nil!
- | ctxt unwindBlock |
- self isDead ifTrue: [self cannotReturn: aBlock value to: self].
- ctxt := thisContext.
- [ ctxt := ctxt findNextUnwindContextUpTo: self.
- ctxt isNil
- ] whileFalse: [
- (ctxt tempAt: 2) ifNil:[
- "(tempAt: 2) refers to complete temporary in ensure: and ifCurtailed:
- or any other method marked with <primitive: 198>"
- ctxt tempAt: 2 put: true.
- unwindBlock := ctxt tempAt: 1.
- thisContext terminateTo: ctxt.
- unwindBlock value].
- ].
- thisContext terminateTo: self.
- ^ aBlock value
- !
Item was added:
+ ----- Method: Context>>resumeEvaluating:through: (in category 'controlling') -----
+ resumeEvaluating: aBlock through: firstUnwindCtxtOrNil
+ "Unwind thisContext to self and resume with value as result of last send.
+ Execute unwind blocks when unwinding.
+ ASSUMES self is a sender of thisContext."
+
+ self isDead ifTrue: [self cannotReturn: aBlock value to: self].
+ (firstUnwindCtxtOrNil ifNil: thisContext) unwindTo: self safely: false.
+ thisContext terminateTo: self.
+ ^aBlock value!
Item was changed:
----- Method: Context>>return:from: (in category 'instruction decoding') -----
return: value from: aSender
"For simulation. Roll back self to aSender and return value from it. Execute any unwind blocks on the way. ASSUMES aSender is a sender of self"
| newTop |
aSender isDead ifTrue:
[^self send: #cannotReturn: to: self with: {value}].
newTop := aSender sender.
(self findNextUnwindContextUpTo: newTop) ifNotNil:
+ "Send #aboutToReturn:through: with nil as the second argument to avoid this bug:
+ Cannot #stepOver '^2' in example '[^2] ensure: []'.
- [:unwindProtectCtxt|
- self flag: #knownBug. "Cannot #stepOver '^2' in example '[^2] ensure: []'.
See http://lists.squeakfoundation.org/pipermail/squeak-dev/2022-June/220975.html"
+ [^self send: #aboutToReturn:through: to: self with: {value. nil}].
- ^self send: #aboutToReturn:through: to: self with: {value. unwindProtectCtxt}].
self releaseTo: newTop.
newTop ifNotNil: [newTop push: value].
^newTop!
Item was changed:
----- Method: Context>>runUntilErrorOrReturnFrom: (in category 'controlling') -----
runUntilErrorOrReturnFrom: aSender
"ASSUMES aSender is a sender of self. Execute self's stack until aSender returns or an unhandled exception is raised. Return a pair containing the new top context and a possibly nil exception. The exception is not nil if it was raised before aSender returned and it was not handled. The exception is returned rather than openning the debugger, giving the caller the choice of how to handle it."
"Self is run by jumping directly to it (the active process abandons thisContext and executes self). However, before jumping to self we insert an ensure block under aSender that jumps back to thisContext when evaluated. We also insert an exception handler under aSender that jumps back to thisContext when an unhandled exception is raised. In either case, the inserted ensure and exception handler are removed once control jumps back to thisContext."
| error ctxt here topContext |
here := thisContext.
"Insert ensure and exception handler contexts under aSender"
error := nil.
ctxt := aSender insertSender: (Context
contextOn: UnhandledError do: [:ex |
error ifNil: [
error := ex exception.
topContext := thisContext.
ex resumeUnchecked: here jump]
ifNotNil: [ex pass]
]).
ctxt := ctxt insertSender: (Context
contextEnsure: [error ifNil: [
topContext := thisContext.
here jump]
]).
self jump. "Control jumps to self"
"Control resumes here once above ensure block or exception handler is executed"
^ error ifNil: [
"No error was raised, remove ensure context by stepping until popped"
+ [ctxt isDead or: [topContext isNil]] whileFalse: [topContext := topContext stepToCallee].
- [ctxt isDead] whileFalse: [topContext := topContext stepToCallee].
{topContext. nil}
] ifNotNil: [
"Error was raised, remove inserted above contexts then return signaler context"
aSender terminateTo: ctxt sender. "remove above ensure and handler contexts"
{topContext. error}
]!
Item was added:
+ ----- Method: Context>>unwindAndStop: (in category 'private') -----
+ unwindAndStop: aProcess
+ "A helper method to Process #terminate. Create and answer
+ a helper stack for a terminating process to unwind itself from.
+ Note: push a fake return value to create a proper top context."
+
+ ^(self class contextEnsure: [self unwindTo: nil])
+ privSender: [aProcess suspend] asContext;
+ push: nil
+ !
Item was changed:
----- Method: Context>>unwindTo:safely: (in category 'private-exceptions') -----
unwindTo: aContext safely: aBoolean
"Unwind self to aContext to execute pending #ensure:/#ifCurtailed: argument blocks between self
and aContext. If aBoolean is false, unwind only blocks that have not run yet, otherwise complete all
pending unwind blocks including those currently in the middle of their execution; these blocks will
just finish their execution. Run all unwinds on their original stack using #runUntilReturnFrom:."
| top ctx |
ctx := top := self.
aBoolean ifTrue: [
"If self is the top context of a stack already halfways through an unwind block, complete the outer-most
unfinished unwind block first; all nested pending unwind blocks will be completed in the process;
see testTerminationDuringUnwind and tests in ProcessTest/UnwindTest.
Note: Halfway-through blocks have already set the complete variable (ctxt tempAt: 2) in their
defining #ensure:/#ifCurtailed contexts from nil to true; we'll search for the bottom-most one."
| outerMost |
ctx isUnwindContext ifFalse: [ctx := ctx findNextUnwindContextUpTo: aContext].
[ctx isNil] whileFalse: [
(ctx tempAt: 2) ifNotNil: [
outerMost := ctx].
ctx := ctx findNextUnwindContextUpTo: aContext].
outerMost ifNotNil: [top := top runUntilReturnFrom: outerMost]].
"By now no halfway-through unwind blocks are on the stack.
Note: top points to the former outerMost sender now, i.e. to the next context to be explored."
ctx := top ifNil: [^self].
"#findNextUnwindContextUpTo: starts searching from the receiver's sender so we must check
the receiver explicitly whether it is an unwind context; see testTerminateEnsureAsStackTop.
Create a new top context (i.e. a new branch off the original stack) for each pending unwind block
(ctxt tempAt: 1) and execute it on the unwind block's stack to evaluate non-local returns correctly."
ctx isUnwindContext ifFalse: [ctx := ctx findNextUnwindContextUpTo: aContext].
[ctx isNil] whileFalse: [
(ctx tempAt: 2) ifNil: [
ctx tempAt: 2 put: true.
+ (ctx tempAt: 1) ifNotNil: [:unwindBlock |
+ top := unwindBlock asContextWithSender: ctx.
+ top runUntilReturnFrom: top]].
- top := (ctx tempAt: 1) asContextWithSender: ctx.
- top runUntilReturnFrom: top].
ctx := ctx findNextUnwindContextUpTo: aContext]
"Note: Cf. the unwind pattern in the previous versions of unwindTo: (1999-2021). Using #value
instead of #runUntilReturnFrom: lead to a failure to evaluate some non-local returns correctly;
a non-local return must be evaluated in the evaluation context (sender chain) in which it was defined."!
Item was removed:
- ----- Method: FullBlockClosure>>homeMethod (in category 'accessing') -----
- homeMethod
- ^startpcOrMethod homeMethod!
Item was added:
+ ----- Method: Mutex>>releaseCriticalSection: (in category 'private') -----
+ releaseCriticalSection: aContext
+ "A helper method for Process suspendAndReleaseCriticalSection.
+ If the terminating process is still blocked at the condition variable
+ of a critical section, skip the rest of the current context."
+
+ ^aContext pc: aContext endPC!
Item was added:
+ ----- Method: Mutex>>stepIntoCriticalSection: (in category 'private') -----
+ stepIntoCriticalSection: aContext
+ "A helper method for Process suspendAndReleaseCriticalSection.
+ If the terminating process still haven't made progress beyond the lock primitive
+ and the lock primitive just acquired ownership (indicated by it answering false)
+ then the ensure block has not been activated, so step into it."
+
+ ^(aContext stackPtr > 0 and: [aContext top == false])
+ ifTrue: [aContext stepToCallee]
+ ifFalse: [aContext]!
Item was changed:
----- Method: Process>>suspendAndReleaseCriticalSection (in category 'private') -----
suspendAndReleaseCriticalSection
"Figure out if we are terminating a process that is in the ensure: block of a critical section.
If it hasn't made progress but is beyond the wait (which we can tell by the oldList being
+ one of the runnable lists, i.e. a LinkedList, not a Semaphore or Mutex), then the ensure:
+ block needs to be run. Answer a context chain that needs to be unwound."
- one of the runnable lists, i.e. a LinkedList, not a Semaphore or Mutex, et al), then the ensure:
- block needs to be run."
+ "Note 1: suspend and unblock the receiver from a condition variable using the old suspend
+ primitive #88; it answers the list the receiver was on before the suspension.
+ Note 2: condition variables' classes implement the actual releasing depending on their
+ implementation of #critical:; see Semaphore or Mutex (or any future extension's)
+ #releaseCriticalSection: and #stepIntoCriticalSection: and the discussion here:
+ http://forum.world.st/Solving-termination-of-critical-sections-in-the-conte…"
- | oldList selectorJustSent |
- "Suspend and unblock the receiver from a condition variable using suspend primitive #88.
- It answers the list the receiver was on before the suspension."
- oldList := self suspendAndUnblock.
- (oldList isNil or: [oldList class == LinkedList]) ifFalse: [^self].
+ | oldList |
+ oldList := self suspendAndUnblock ifNil: [LinkedList new].
+ ^suspendedContext ifNotNil: [:context |
+ suspendedContext := nil.
+ (context method pragmaAt: #criticalSection)
+ ifNil: [context]
+ ifNotNil: [oldList releaseCriticalSection: context]]!
- ((suspendedContext ifNil: [^self]) method pragmaAt: #criticalSection) ifNil: [^self].
- selectorJustSent := suspendedContext selectorJustSentOrSelf.
-
- "If still at the wait the ensure: block has not been activated, so signal to restore."
- selectorJustSent == #wait ifTrue:
- [suspendedContext receiver signal].
-
- "If still at the lock primitive and the lock primitive just acquired ownership (indicated by it answering false)
- then the ensure block has not been activated, so explicitly primitiveExitCriticalSection to unlock."
- (selectorJustSent == #primitiveEnterCriticalSection
- or: [selectorJustSent == #primitiveTestAndSetOwnershipOfCriticalSection]) ifTrue:
- [(suspendedContext stackPtr > 0
- and: [suspendedContext top == false]) ifTrue:
- [suspendedContext receiver primitiveExitCriticalSection]]!
Item was changed:
----- Method: Process>>terminate (in category 'changing process state') -----
+ terminate
+ "Stop the process that the receiver represents forever. Allow all pending unwind
+ blocks to run before terminating; if they are currently in progress, let them finish."
- terminate
- "Stop the process that the receiver represents forever.
- Unwind to execute pending #ensure:/#ifCurtailed: blocks before terminating;
- allow all unwind blocks to run; if they are currently in progress, let them finish."
+ "Note: This is the kind of behavior we expect when terminating a healthy process.
- "This is the kind of behavior we expect when terminating a healthy process.
See further comments in #terminateAggressively and #destroy methods dealing
with process termination when closing the debugger or after a catastrophic failure.
If terminating the active process, create a new stack and run unwinds from there.
If terminating a suspended process (including runnable and blocked), always
+ suspend the terminating process first so it doesn't accidentally get woken up,
+ and nil the suspended context to prevent accidental resumption or termination
+ while manipulating the suspended context.
+
- suspend the terminating process first so it doesn't accidentally get woken up.
Equally important is the side effect of the suspension: In 2022 a new suspend
semantics has been introduced: the revised #suspend backs up a process waiting
on a conditional variable to the send that invoked the wait state, while the previous
#suspend simply removed the process from the conditional variable's list it was
previously waiting on; see #suspend and #suspendAndUnblock comments.
+
+ If the process is blocked, waiting to access the #critical: section, release it properly.
-
- If the process is in the middle of a #critical: critical section, release it properly.
To allow a suspended process to unwind itself, create a new stack for the process
being terminated and resume the suspended process to complete its termination
+ from the new, parallel stack. Use a semaphore to make the process that invoked
- from the new parallel stack. Use a semaphore to make the process that invoked
the termination wait for self's completion. Execute the termination in the ensure
argument block to ensure it completes even if the terminator process itself gets
terminated before it's finished; see testTerminateInTerminate and others."
- | context |
self isActiveProcess ifTrue: [
+ ^(thisContext unwindAndStop: self) jump].
- context := thisContext.
- ^[[] ensure: [context unwindTo: nil]. self suspend] asContext jump].
+ [] ensure: [
+ [:contextToUnwind |
+ self
- [] ensure: [ | terminator |
- self suspendAndReleaseCriticalSection.
- context := suspendedContext ifNil: [^self].
- terminator := Semaphore new.
- context bottomContext insertSender: (Context contextEnsure: [terminator signal]).
- self suspendedContext: [[] ensure: [context unwindTo: nil]. self suspend] asContext;
priority: Processor activePriority;
+ suspendedContext: (contextToUnwind unwindAndStop: self);
+ resume
+ ] valueAndWaitWhileUnwinding: self suspendAndReleaseCriticalSection
+ ]!
- resume.
- terminator wait]!
Item was changed:
----- Method: Process>>terminateAggressively (in category 'changing process state') -----
terminateAggressively
"Stop the receiver forever.
Run all unwind contexts (#ensure:/#ifCurtailed: blocks) on the stack that have not yet been started. If the process is in the middle of an unwind block, then that unwind block will not be completed, but subsequent unwind blocks will be run. If even those unwind contexts should be continued, send #terminate instead.
Note that ill unwind contexts are theoretically able to stall the termination (for instance, by placing a non-local return in an unwind block); however, this is a disrecommended practice.
If the process is in the middle of a critical: critical section, release it properly."
| oldList bottom tombstone |
self isActiveProcess ifTrue: [
"If terminating the active process, suspend it first and terminate it as a suspended process."
[self terminate] fork.
^self suspend].
"Always suspend the process first so it doesn't accidentally get woken up.
N.B.: If oldList is a LinkedList then the process is runnable. If it is a Semaphore/Mutex et al., then the process is blocked."
oldList := self suspend.
suspendedContext ifNil: [^ self "Process is already terminated"].
"Release any method marked with the <criticalSection> pragma. The argument is whether the process is runnable."
self releaseCriticalSection: (oldList isNil or: [oldList class == LinkedList]).
bottom := suspendedContext bottomContext.
tombstone := bottom insertSender: [self suspend "terminated"] asContext.
suspendedContext := self
activateReturn: bottom
value: nil.
self complete: tombstone ifError: [:ex |
+ (suspendedContext ifNil: [^self]) privRefresh. "Restart the handler context of UnhandledError so that when the receiver is resumed, its #defaultAction will be reached. See implementation details in #runUntilErrorOrReturnFrom:."
- suspendedContext privRefresh. "Restart the handler context of UnhandledError so that when the receiver is resumed, its #defaultAction will be reached. See implementation details in #runUntilErrorOrReturnFrom:."
"We're not yet done, resume the receiver to spawn a new debugger on the error."
self resume].!
Item was added:
+ ----- Method: Semaphore>>releaseCriticalSection: (in category 'private') -----
+ releaseCriticalSection: aContext
+ "A helper method for Process suspendAndReleaseCriticalSection.
+ If the terminating process is still blocked at the condition variable
+ of a critical section, skip the rest of the current context."
+
+ ^aContext pc: aContext endPC!
Item was added:
+ ----- Method: Semaphore>>stepIntoCriticalSection: (in category 'private') -----
+ stepIntoCriticalSection: aContext
+ "A helper method for Process suspendAndReleaseCriticalSection.
+ If the terminating process still haven't made progress beyond the wait
+ then the ensure block has not been activated, so step into it."
+
+ ^aContext stepToCallee!
1
0
Marcel Taeumel uploaded a new version of 60Deprecated to project The Treated Inbox:
http://source.squeak.org/treated/60Deprecated-ct.115.mcz
==================== Summary ====================
Name: 60Deprecated-ct.115
Author: ct
Time: 20 May 2022, 6:36:07.506152 pm
UUID: ff6f5fdc-4104-894f-8e96-765f93b72165
Ancestors: 60Deprecated-ct.114
Complements System-ct.1353. This is a follow-up of 60Deprecated-mt.107 and not a new deprecation.
=============== Diff against 60Deprecated-ct.114 ===============
Item was added:
+ ----- Method: TTFileDescription>>profileAll (in category '*60Deprecated-*System-Tools-profiling') -----
+ profileAll
+ "Profile reading all the glyphs"
+ MessageTally spyOn:[
+ 1 to: numGlyphs do:[:glyphIndex| self readGlyphAt: glyphIndex-1].
+ ].!
1
0
Marcel Taeumel uploaded a new version of 60Deprecated to project The Treated Inbox:
http://source.squeak.org/treated/60Deprecated-ct.112.mcz
==================== Summary ====================
Name: 60Deprecated-ct.112
Author: ct
Time: 4 May 2022, 9:16:34.90725 pm
UUID: ac301b93-5b73-3e42-84ad-029d6f08c441
Ancestors: 60Deprecated-mt.111
Test for Squeaksource. Please apologize the noise.
<img src="data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIBAMAAAA2IaO4AAAAMFBMVEUAAACAAAAAgACAgAAAAICAAIAAgICAgIC/v7//AAAA/wD//wAAAP//AP8A//////94imqWAAAAEHRSTlP/////////////////////zSGylAAAAChJREFUeF5j+P///3+G/7t3/2f4zb1hP8Pv3bv3Q1kbuPdDJIAq/gMA/8wZcBN9r58AAAAASUVORK5CYII=" />
<script>alert("XSS attack!");</script>
=============== Diff against 60Deprecated-mt.111 ===============
1
0
Marcel Taeumel uploaded a new version of KernelTests to project The Treated Inbox:
http://source.squeak.org/treated/KernelTests-jar.423.mcz
==================== Summary ====================
Name: KernelTests-jar.423
Author: jar
Time: 29 May 2022, 4:27:14.426063 pm
UUID: 20a7b2ce-4161-674d-abd4-e80376bf00f3
Ancestors: KernelTests-nice.422
Update a battery of tests to complement Kernel-jar.1468 and Kernel-jar.1469 (revised suspend and terminate semantics and termination fixes). The update adjusts some tests for the revised suspend, plus adds some more. A few tests will be parked as expected failures as a reminder :)
Supersede KernelTests-jar.421; please remove it from the Inbox.
=============== Diff against KernelTests-nice.422 ===============
Item was added:
+ ----- Method: MutexTest>>expectedFailures (in category 'failures') -----
+ expectedFailures
+
+ ^ #(testUnwindMutexBlockedInCritical)!
Item was added:
+ ----- Method: MutexTest>>testMutexInCriticalEnsureArgument (in category 'tests') -----
+ testMutexInCriticalEnsureArgument "self run: #testMutexInCriticalEnsureArgument"
+ "This tests whether a process that is in the ensure argument block in critical: but has yet to evaluate the primitiveExitCriticalSection
+ leaves it with the mutex unlocked."
+
+ | terminatee mutex |
+ mutex := Mutex new.
+ terminatee := [mutex critical: []] newProcess.
+ self assert: terminatee isSuspended.
+ terminatee runUntil: [:ctx | ctx selectorToSendOrSelf = #primitiveExitCriticalSection].
+ self assert: terminatee isSuspended.
+ terminatee terminate.
+ self deny: mutex isOwned.
+ self assert: mutex isEmpty!
Item was added:
+ ----- Method: MutexTest>>testUnwindMutexBlockedInCritical (in category 'tests') -----
+ testUnwindMutexBlockedInCritical "self run: #testMutexBlockedInCritical"
+ "This tests whether a mutex that is inside the primitiveEnterCriticalSection in Mutex>>critical:
+ leaves it unchanged."
+ | lock sock proc wait |
+ lock := Mutex new.
+ sock := Semaphore new.
+ proc := [lock critical: [sock wait]] fork.
+ wait := [[] ensure: [lock critical: []]] fork.
+ Processor yield.
+ self assert: proc suspendingList == sock.
+ self assert: wait suspendingList == lock.
+ self deny: lock isEmpty.
+ self assert: lock isOwned.
+ wait terminate.
+ Processor yield.
+ self assert: wait isTerminated.
+ self assert: proc suspendingList == sock.
+ self assert: wait suspendingList == nil.
+ self assert: lock isEmpty.
+ self assert: lock isOwned
+ !
Item was changed:
----- Method: Process>>suspendPrimitivelyOrFail (in category '*KernelTests-Processes') -----
suspendPrimitivelyOrFail
+ "Test support. Execute primitive 578, or fail."
- "Test support. Execute primitive 88, or fail."
+ <primitive: 578>
- <primitive: 88>
^self primitiveFailed!
Item was added:
+ ----- Method: ProcessTest>>expectedFailures (in category 'failures') -----
+ expectedFailures
+
+ ^ #(testTerminateTerminatingProcess testResumeTerminatingProcess)!
Item was changed:
----- Method: ProcessTest>>testAtomicSuspend (in category 'tests') -----
testAtomicSuspend
+ "Test atomic suspend of foreign processes.
+ Note: this test will fail when run with older VMs without primitive suspend 578."
- "Test atomic suspend of foreign processes"
| list p |
p := [semaphore wait] fork.
Processor yield.
list := p suspendPrimitivelyOrFail.
+ self assert: list == nil.
- self assert: list == semaphore.
!
Item was added:
+ ----- Method: ProcessTest>>testResumeTerminatingProcess (in category 'tests') -----
+ testResumeTerminatingProcess
+ "An attempt to resume a terminating process should probably raise an error;
+ leave this test as an expected failure for the moment."
+
+ | terminatee terminator resumed semaphore |
+ semaphore := Semaphore new.
+ terminatee := [semaphore critical:[]. resumed := true] fork.
+ Processor yield.
+ terminator := [terminatee terminate] newProcess.
+ self assert: terminatee suspendingList == semaphore.
+ self assert: terminator isSuspended.
+ "run terminator and stop inside #terminate"
+ terminator runUntil: [:ctx | ctx selectorToSendOrSelf = #priority:].
+ self assert: terminator isSuspended.
+ "resume the terminatee process and and check if the VM raises an error;
+ an error is expected because terminatee's suspendedContext equals nil"
+ self should: [terminatee resume] raise: Error.
+ "now let the terminator finish terminating the terminatee process"
+ terminator resume.
+ Processor yield.
+ self assert: resumed isNil.
+ self assert: terminatee isTerminated.
+ self assert: terminator isTerminated!
Item was added:
+ ----- Method: ProcessTest>>testRevisedSuspendExpectations (in category 'tests') -----
+ testRevisedSuspendExpectations
+ "Test revised suspend expectations vs. pre-2022 VM's suspend"
+
+ | s p list |
+ s := Semaphore new.
+ p := [s critical:[]] forkAt: Processor activePriority + 1.
+ list := p suspend.
+
+ Smalltalk processSuspensionUnblocks
+ ifFalse: [
+ self assert: p suspendingList equals: nil.
+ self assert: list equals: nil.
+ self deny: p suspendedContext selectorJustSentOrSelf equals: #wait
+ ]
+ ifTrue: [
+ self assert: p suspendingList equals: nil.
+ self assert: list equals: s.
+ self assert: p suspendedContext selectorJustSentOrSelf equals: #wait
+ ]!
Item was added:
+ ----- Method: ProcessTest>>testTerminateEnsureAsStackTop (in category 'tests') -----
+ testTerminateEnsureAsStackTop
+ "Test #ensure unwind block is executed even when #ensure context is on stack's top."
+
+ | p1 p2 p3 x1 x2 x3 |
+ x1 := x2 := x3 := false.
+
+ "p1 is at the beginning of the ensure block and the unwind block hasn't run yet"
+ p1 := Process
+ forBlock: [[] ensure: [x1 := x1 not]]
+ runUntil: [:ctx | ctx isUnwindContext and: [(ctx tempAt: 2) isNil]].
+ p1 step. p1 step. "move the pc behind the send: valueNoContextSwitch instruction"
+
+ "p2 has already set complete to true (tempAt: 2) but the unwind block hasn't run yet"
+ p2 := Process
+ forBlock: [[] ensure: [x2 := x2 not]]
+ runUntil: [:ctx | ctx isUnwindContext and: [(ctx tempAt: 2) notNil]].
+
+ "p3 has already set complete to true AND the unwind block has already run;
+ we have to verify the unwind block is not executed again during termination"
+ p3 := Process
+ forBlock: [[] ensure: [x3 := x3 not]]
+ runUntil: [:ctx | ctx isUnwindContext and: [ctx willReturn]].
+
+ "make sure all processes are running and only the p3's unwind block has finished"
+ self deny: p1 isTerminated | p2 isTerminated | p3 isTerminated.
+ self deny: x1 | x2.
+ self assert: x3. "p3 has already run its unwind block; we test it won't run it again"
+ "terminate all processes and verify all unwind blocks have finished correctly"
+ p1 terminate. p2 terminate. p3 terminate.
+ self assert: p1 isTerminated & p2 isTerminated & p3 isTerminated.
+ self assert: x1 & x2 & x3!
Item was added:
+ ----- Method: ProcessTest>>testTerminateInTerminate (in category 'tests') -----
+ testTerminateInTerminate
+ "Terminating a terminator process should unwind both the terminator and its terminatee process"
+
+ | terminator terminatee unwound |
+ unwound := false.
+ terminatee := [[Processor activeProcess suspend] ensure: [unwound := true]] fork.
+ Processor yield.
+ terminator := [terminatee terminate] newProcess.
+ self assert: terminatee isSuspended.
+ self assert: terminator isSuspended.
+ "run terminator and stop inside #terminate"
+ terminator runUntil: [:ctx | ctx selectorToSendOrSelf = #priority:].
+ self assert: terminator isSuspended.
+ terminator terminate.
+ self assert: terminator isTerminated.
+ self assert: unwound!
Item was added:
+ ----- Method: ProcessTest>>testTerminateTerminatingProcess (in category 'tests') -----
+ testTerminateTerminatingProcess
+ "An attempt to terminate a terminating process should probably raise an error;
+ leave this test as an expected failure for the moment."
+
+ | terminatee terminator resumed semaphore |
+ semaphore := Semaphore new.
+ terminatee := [semaphore critical:[]. resumed := true] fork.
+ Processor yield.
+ terminator := [terminatee terminate] newProcess.
+ self assert: terminatee suspendingList == semaphore.
+ self assert: terminator isSuspended.
+ "run terminator and stop inside #terminate"
+ terminator runUntil: [:ctx | ctx selectorToSendOrSelf = #priority:].
+ self assert: terminator isSuspended.
+ "terminate the terminatee process again and let the termination finish;
+ an error is expected because #terminate detected multiple termination"
+ self should: [terminatee terminate] raise: Error.
+ "now let the terminator finish terminating the terminatee process"
+ terminator resume.
+ Processor yield.
+ self assert: resumed isNil.
+ self assert: terminatee isTerminated.
+ self assert: terminator isTerminated!
Item was added:
+ ----- Method: SemaphoreTest>>expectedFailures (in category 'failures') -----
+ expectedFailures
+
+ ^ #(testUnwindSemaInCriticalWait)!
Item was added:
+ ----- Method: SemaphoreTest>>testSemaInCriticalEnsureArgument (in category 'tests') -----
+ testSemaInCriticalEnsureArgument "self run: #testSemaInCriticalEnsureArgument"
+ "This tests whether a process that is in ensure argument block but has yet to evaluate the signal
+ leaves it with signaling the associated semaphore."
+
+ | terminatee sema |
+ sema := Semaphore forMutualExclusion.
+ terminatee := [sema critical: []] newProcess.
+ self assert: terminatee isSuspended.
+ terminatee runUntil: [:ctx | ctx selectorToSendOrSelf = #signal].
+ self assert: terminatee isSuspended.
+ terminatee terminate.
+ self assert: terminatee isTerminated.
+ self assert: sema excessSignals = 1 !
Item was added:
+ ----- Method: SemaphoreTest>>testUnwindSemaInCriticalWait (in category 'tests') -----
+ testUnwindSemaInCriticalWait "self run: #testSemaInCriticalWait"
+ "This tests whether a semaphore that has entered the wait in Semaphore>>critical:
+ leaves it without signaling the associated semaphore."
+ | s p |
+ s := Semaphore new.
+ p := [[] ensure: [s critical:[]]] fork.
+ Processor yield.
+ self assert:(p suspendingList == s).
+ p terminate.
+ self assert: 0 equals: s excessSignals!
Item was added:
+ ProcessTest subclass: #UnwindTest
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'KernelTests-Processes'!
Item was added:
+ ----- Method: UnwindTest>>testTerminateActiveInNestedEnsure1 (in category 'tests') -----
+ testTerminateActiveInNestedEnsure1
+ "Terminate active process.
+ Test all nested unwind blocks are correctly executed;
+ all unwind blocks halfway through their execution should be completed."
+
+ | p x1 x2 x3 x4 |
+ x1 := x2 := x3 := x4 := false.
+ p :=
+ [
+ [
+ [ ] ensure: [
+ [Processor activeProcess terminate] ensure: [
+ x1 := true].
+ x2 := true]
+ ] ensure: [
+ x3 := true].
+ x4 := true.
+ ] newProcess.
+ p resume.
+ Processor yield.
+ self assert: p isTerminated.
+ self assert: x1 & x2 & x3.
+ self deny: x4.!
Item was added:
+ ----- Method: UnwindTest>>testTerminateActiveInNestedEnsure2 (in category 'tests') -----
+ testTerminateActiveInNestedEnsure2
+ "Terminate active process.
+ Test all nested unwind blocks are correctly executed;
+ all unwind blocks halfway through their execution should be completed."
+
+ | p x1 x2 x3 x4 |
+ x1 := x2 := x3 := x4 := false.
+ p :=
+ [
+ [
+ [ ] ensure: [
+ [ ] ensure: [
+ Processor activeProcess terminate.
+ x1 := true].
+ x2 := true]
+ ] ensure: [
+ x3 := true].
+ x4 := true.
+ ] newProcess.
+ p resume.
+ Processor yield.
+ self assert: p isTerminated.
+ self assert: x1 & x2 & x3.
+ self deny: x4.!
Item was added:
+ ----- Method: UnwindTest>>testTerminateBlockedInNestedEnsure1 (in category 'tests') -----
+ testTerminateBlockedInNestedEnsure1
+ "Terminate blocked process.
+ Test all nested unwind blocks are correctly executed;
+ all unwind blocks halfway through their execution should be completed."
+
+ | p x1 x2 x3 x4 |
+ x1 := x2 := x3 := x4 := false.
+ p :=
+ [
+ [
+ [ ] ensure: [
+ [semaphore wait] ensure: [
+ x1 := true].
+ x2 := true]
+ ] ensure: [
+ x3 := true].
+ x4 := true.
+ ] newProcess.
+ p resume.
+ Processor yield.
+ "make sure p is blocked and none of the unwind blocks has finished yet"
+ self assert: p isBlocked.
+ self deny: x1 | x2 | x3 | x4.
+ "now terminate the process and make sure all unwind blocks have finished"
+ p terminate.
+ self assert: p isTerminated.
+ self assert: x1 & x2 & x3.
+ self deny: x4.!
Item was added:
+ ----- Method: UnwindTest>>testTerminateBlockedInNestedEnsure2 (in category 'tests') -----
+ testTerminateBlockedInNestedEnsure2
+ "Terminate blocked process.
+ Test all nested unwind blocks are correctly executed;
+ all unwind blocks halfway through their execution should be completed."
+
+ | p x1 x2 x3 x4 |
+ x1 := x2 := x3 := x4 := false.
+ p :=
+ [
+ [
+ [ ] ensure: [
+ [ ] ensure: [
+ semaphore wait.
+ x1 := true].
+ x2 := true]
+ ] ensure: [
+ x3 := true].
+ x4 := true.
+ ] newProcess.
+ p resume.
+ Processor yield.
+ "make sure p is blocked and none of the unwind blocks has finished yet"
+ self assert: p isBlocked.
+ self deny: x1 | x2 | x3 | x4.
+ "now terminate the process and make sure all unwind blocks have finished"
+ p terminate.
+ self assert: p isTerminated.
+ self assert: x1 & x2 & x3.
+ self deny: x4.!
Item was added:
+ ----- Method: UnwindTest>>testTerminateInNestedEnsureWithReturn1 (in category 'tests') -----
+ testTerminateInNestedEnsureWithReturn1
+ "Terminate suspended process.
+ Test all nested unwind blocks are correctly executed;
+ all unwind blocks halfway through their execution should be completed."
+
+ | p x1 x2 x3 x4 |
+ x1 := x2 := x3 := x4 := false.
+ p :=
+ [
+ [:return |
+ [
+ [ ] ensure: [
+ [Processor activeProcess suspend] ensure: [
+ x1 := true. return value].
+ x2 := true]
+ ] ensure: [
+ x3 := true].
+ x4 := true.
+ ] valueWithExit
+ ] newProcess.
+ p resume.
+ Processor yield.
+ "make sure p is suspended and none of the unwind blocks has finished yet"
+ self assert: p isSuspended.
+ self deny: x1 | x2 | x3 | x4.
+ "now terminate the process and make sure all unwind blocks have finished"
+ p terminate.
+ self assert: p isTerminated.
+ self assert: x1 & x3.
+ self deny: x2 & x4.!
Item was added:
+ ----- Method: UnwindTest>>testTerminateInNestedEnsureWithReturn2 (in category 'tests') -----
+ testTerminateInNestedEnsureWithReturn2
+ "Terminate suspended process.
+ Test all nested unwind blocks are correctly executed;
+ all unwind blocks halfway through their execution should be completed."
+
+ | p x1 x2 x3 x4 |
+ x1 := x2 := x3 := x4 := false.
+ p :=
+ [
+ [:return |
+ [
+ [ ] ensure: [
+ [] ensure: [
+ Processor activeProcess suspend.
+ x1 := true. return value].
+ x2 := true]
+ ] ensure: [
+ x3 := true].
+ x4 := true.
+ ] valueWithExit
+ ] newProcess.
+ p resume.
+ Processor yield.
+ "make sure p is suspended and none of the unwind blocks has finished yet"
+ self assert: p isSuspended.
+ self deny: x1 | x2 | x3 | x4.
+ "now terminate the process and make sure all unwind blocks have finished"
+ p terminate.
+ self assert: p isTerminated.
+ self assert: x1 & x3.
+ self deny: x2 & x4.!
Item was added:
+ ----- Method: UnwindTest>>testTerminateInNestedEnsureWithReturn3 (in category 'tests') -----
+ testTerminateInNestedEnsureWithReturn3
+ "Terminate suspended process.
+ Test all nested unwind blocks are correctly executed;
+ all unwind blocks halfway through their execution should be completed."
+
+ | p x1 x2 x3 x4 |
+ x1 := x2 := x3 := x4 := false.
+ p :=
+ [
+ [:return |
+ [
+ [ ] ensure: [
+ [Processor activeProcess suspend] ensure: [
+ x1 := true].
+ x2 := true. return value]
+ ] ensure: [
+ x3 := true].
+ x4 := true.
+ ] valueWithExit
+ ] newProcess.
+ p resume.
+ Processor yield.
+ "make sure p is suspended and none of the unwind blocks has finished yet"
+ self assert: p isSuspended.
+ self deny: x1 | x2 | x3 | x4.
+ "now terminate the process and make sure all unwind blocks have finished"
+ p terminate.
+ self assert: p isTerminated.
+ self assert: x1 & x2 & x3.
+ self deny: x4.!
Item was added:
+ ----- Method: UnwindTest>>testTerminateInNestedEnsureWithReturn4 (in category 'tests') -----
+ testTerminateInNestedEnsureWithReturn4
+ "Terminate suspended process.
+ Test all nested unwind blocks are correctly executed;
+ all unwind blocks halfway through their execution should be completed."
+
+ | p x1 x2 x3 x4 |
+ x1 := x2 := x3 := x4 := false.
+ p :=
+ [
+ [:return |
+ [
+ [ ] ensure: [
+ [] ensure: [
+ Processor activeProcess suspend.
+ x1 := true].
+ x2 := true. return value]
+ ] ensure: [
+ x3 := true].
+ x4 := true.
+ ] valueWithExit
+ ] newProcess.
+ p resume.
+ Processor yield.
+ "make sure p is suspended and none of the unwind blocks has finished yet"
+ self assert: p isSuspended.
+ self deny: x1 | x2 | x3 | x4.
+ "now terminate the process and make sure all unwind blocks have finished"
+ p terminate.
+ self assert: p isTerminated.
+ self assert: x1 & x2 & x3.
+ self deny: x4.!
Item was added:
+ ----- Method: UnwindTest>>testTerminateInNestedEnsureWithReturn5 (in category 'tests') -----
+ testTerminateInNestedEnsureWithReturn5
+ "Terminate suspended process.
+ Test all nested unwind blocks are correctly executed;
+ all unwind blocks halfway through their execution should be completed."
+
+ | p x1 x2 x3 x4 |
+ x1 := x2 := x3 := x4 := false.
+ p :=
+ [
+ [:return |
+ [
+ [ ] ensure: [
+ [Processor activeProcess suspend] ensure: [
+ x1 := true].
+ x2 := true]
+ ] ensure: [
+ x3 := true. return value].
+ x4 := true.
+ ] valueWithExit
+ ] newProcess.
+ p resume.
+ Processor yield.
+ "make sure p is suspended and none of the unwind blocks has finished yet"
+ self assert: p isSuspended.
+ self deny: x1 | x2 | x3 | x4.
+ "now terminate the process and make sure all unwind blocks have finished"
+ p terminate.
+ self assert: p isTerminated.
+ self assert: x1 & x2 & x3.
+ self deny: x4.!
Item was added:
+ ----- Method: UnwindTest>>testTerminateInNestedEnsureWithReturn6 (in category 'tests') -----
+ testTerminateInNestedEnsureWithReturn6
+ "Terminate suspended process.
+ Test all nested unwind blocks are correctly executed;
+ all unwind blocks halfway through their execution should be completed."
+
+ | p x1 x2 x3 x4 |
+ x1 := x2 := x3 := x4 := false.
+ p :=
+ [
+ [:return |
+ [
+ [ ] ensure: [
+ [] ensure: [
+ Processor activeProcess suspend.
+ x1 := true].
+ x2 := true]
+ ] ensure: [
+ x3 := true. return value].
+ x4 := true.
+ ] valueWithExit
+ ] newProcess.
+ p resume.
+ Processor yield.
+ "make sure p is suspended and none of the unwind blocks has finished yet"
+ self assert: p isSuspended.
+ self deny: x1 | x2 | x3 | x4.
+ "now terminate the process and make sure all unwind blocks have finished"
+ p terminate.
+ self assert: p isTerminated.
+ self assert: x1 & x2 & x3.
+ self deny: x4.!
Item was added:
+ ----- Method: UnwindTest>>testTerminateInNestedEnsureWithReturn7 (in category 'tests') -----
+ testTerminateInNestedEnsureWithReturn7
+ "Terminate suspended process.
+ Test all nested unwind blocks are correctly executed;
+ all unwind blocks halfway through their execution should be completed."
+
+ | p x1 x2 x3 x4 |
+ x1 := x2 := x3 := x4 := false.
+ p :=
+ [
+ [:return |
+ [
+ [ ] ensure: [
+ [Processor activeProcess suspend] ensure: [
+ x1 := true].
+ x2 := true]
+ ] ensure: [
+ x3 := true].
+ x4 := true. return value.
+ ] valueWithExit
+ ] newProcess.
+ p resume.
+ Processor yield.
+ "make sure p is suspended and none of the unwind blocks has finished yet"
+ self assert: p isSuspended.
+ self deny: x1 | x2 | x3 | x4.
+ "now terminate the process and make sure all unwind blocks have finished"
+ p terminate.
+ self assert: p isTerminated.
+ self assert: x1 & x2 & x3.
+ self deny: x4.!
Item was added:
+ ----- Method: UnwindTest>>testTerminateInNestedEnsureWithReturn8 (in category 'tests') -----
+ testTerminateInNestedEnsureWithReturn8
+ "Terminate suspended process.
+ Test all nested unwind blocks are correctly executed;
+ all unwind blocks halfway through their execution should be completed."
+
+ | p x1 x2 x3 x4 |
+ x1 := x2 := x3 := x4 := false.
+ p :=
+ [
+ [:return |
+ [
+ [ ] ensure: [
+ [] ensure: [
+ Processor activeProcess suspend.
+ x1 := true].
+ x2 := true]
+ ] ensure: [
+ x3 := true].
+ x4 := true. return value.
+ ] valueWithExit
+ ] newProcess.
+ p resume.
+ Processor yield.
+ "make sure p is suspended and none of the unwind blocks has finished yet"
+ self assert: p isSuspended.
+ self deny: x1 | x2 | x3 | x4.
+ "now terminate the process and make sure all unwind blocks have finished"
+ p terminate.
+ self assert: p isTerminated.
+ self assert: x1 & x2 & x3.
+ self deny: x4.!
Item was added:
+ ----- Method: UnwindTest>>testTerminateRunnableInNestedEnsure1 (in category 'tests') -----
+ testTerminateRunnableInNestedEnsure1
+ "Terminate runnable process.
+ Test all nested unwind blocks are correctly executed;
+ all unwind blocks halfway through their execution should be completed."
+
+ | p x1 x2 x3 x4 |
+ x1 := x2 := x3 := x4 := false.
+ p :=
+ [
+ [
+ [ ] ensure: [
+ [Processor yield] ensure: [
+ x1 := true].
+ x2 := true]
+ ] ensure: [
+ x3 := true].
+ x4 := true.
+ ] newProcess.
+ p resume.
+ Processor yield.
+ "make sure p is runnable and none of the unwind blocks has finished yet"
+ self assert: p isRunnable.
+ self deny: x1 | x2 | x3 | x4.
+ "now terminate the process and make sure all unwind blocks have finished"
+ p terminate.
+ self assert: p isTerminated.
+ self assert: x1 & x2 & x3.
+ self deny: x4.!
Item was added:
+ ----- Method: UnwindTest>>testTerminateRunnableInNestedEnsure2 (in category 'tests') -----
+ testTerminateRunnableInNestedEnsure2
+ "Terminate runnable process.
+ Test all nested unwind blocks are correctly executed;
+ all unwind blocks halfway through their execution should be completed."
+
+ | p x1 x2 x3 x4 |
+ x1 := x2 := x3 := x4 := false.
+ p :=
+ [
+ [
+ [ ] ensure: [
+ [ ] ensure: [
+ Processor yield.
+ x1 := true].
+ x2 := true]
+ ] ensure: [
+ x3 := true].
+ x4 := true.
+ ] newProcess.
+ p resume.
+ Processor yield.
+ "make sure p is runnable and none of the unwind blocks has finished yet"
+ self assert: p isRunnable.
+ self deny: x1 | x2 | x3 | x4.
+ "now terminate the process and make sure all unwind blocks have finished"
+ p terminate.
+ self assert: p isTerminated.
+ self assert: x1 & x2 & x3.
+ self deny: x4.!
Item was added:
+ ----- Method: UnwindTest>>testTerminateSuspendedInNestedEnsure1 (in category 'tests') -----
+ testTerminateSuspendedInNestedEnsure1
+ "Terminate suspended process.
+ Test all nested unwind blocks are correctly executed;
+ all unwind blocks halfway through their execution should be completed."
+
+ | p x1 x2 x3 x4 |
+ x1 := x2 := x3 := x4 := false.
+ p :=
+ [
+ [
+ [ ] ensure: [
+ [Processor activeProcess suspend] ensure: [
+ x1 := true].
+ x2 := true]
+ ] ensure: [
+ x3 := true].
+ x4 := true.
+ ] newProcess.
+ p resume.
+ Processor yield.
+ "make sure p is suspended and none of the unwind blocks has finished yet"
+ self assert: p isSuspended.
+ self deny: x1 | x2 | x3 | x4.
+ "now terminate the process and make sure all unwind blocks have finished"
+ p terminate.
+ self assert: p isTerminated.
+ self assert: x1 & x2 & x3.
+ self deny: x4.!
Item was added:
+ ----- Method: UnwindTest>>testTerminateSuspendedInNestedEnsure2 (in category 'tests') -----
+ testTerminateSuspendedInNestedEnsure2
+ "Terminate suspended process.
+ Test all nested unwind blocks are correctly executed;
+ all unwind blocks halfway through their execution should be completed."
+
+ | p x1 x2 x3 x4 |
+ x1 := x2 := x3 := x4 := false.
+ p :=
+ [
+ [
+ [ ] ensure: [
+ [ ] ensure: [
+ Processor activeProcess suspend.
+ x1 := true].
+ x2 := true]
+ ] ensure: [
+ x3 := true].
+ x4 := true.
+ ] newProcess.
+ p resume.
+ Processor yield.
+ "make sure p is suspended and none of the unwind blocks has finished yet"
+ self assert: p isSuspended.
+ self deny: x1 | x2 | x3 | x4.
+ "now terminate the process and make sure all unwind blocks have finished"
+ p terminate.
+ self assert: p isTerminated.
+ self assert: x1 & x2 & x3.
+ self deny: x4.!
1
0
Marcel Taeumel uploaded a new version of KernelTests to project The Treated Inbox:
http://source.squeak.org/treated/KernelTests-jar.437.mcz
==================== Summary ====================
Name: KernelTests-jar.437
Author: jar
Time: 11 July 2022, 3:00:42.307972 pm
UUID: 8e550373-a0e1-9d4a-9d23-22020c403639
Ancestors: KernelTests-jar.436
Modify the test to cover a situation previously missed - see Kernel-jar.1487
Complements Kernel-jar.1487
=============== Diff against KernelTests-jar.436 ===============
Item was added:
+ SystemOrganization addCategory: #'KernelTests-Classes'!
+ SystemOrganization addCategory: #'KernelTests-Methods'!
+ SystemOrganization addCategory: #'KernelTests-Numbers'!
+ SystemOrganization addCategory: #'KernelTests-Objects'!
+ SystemOrganization addCategory: #'KernelTests-Processes'!
+ SystemOrganization addCategory: #'KernelTests-WriteBarrier'!
+ SystemOrganization addCategory: #'KernelTests-Models'!
Item was added:
+ ClassTestCase subclass: #AbstractProcessTest
+ instanceVariableNames: 'semaphore'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'KernelTests-Processes'!
Item was added:
+ ----- Method: AbstractProcessTest class>>isAbstract (in category 'testing') -----
+ isAbstract
+
+ ^ self name = #AbstractProcessTest!
Item was added:
+ ----- Method: AbstractProcessTest>>classToBeTested (in category 'support') -----
+ classToBeTested
+
+ ^ self environment classNamed: #Process!
Item was added:
+ ----- Method: AbstractProcessTest>>genuineProcess (in category 'support') -----
+ genuineProcess
+ "Usually, we don't want to expose this from the class under test but we need it in the test context."
+
+ ^ Processor instVarNamed: 'genuineProcess'!
Item was added:
+ ----- Method: AbstractProcessTest>>setUp (in category 'running') -----
+ setUp
+
+ super setUp.
+ semaphore := Semaphore new.!
Item was added:
+ ----- Method: AbstractProcessTest>>tearDown (in category 'running') -----
+ tearDown
+ "Release all processes still waiting at the semaphore or in the active priority queue."
+
+ Processor yield.
+ [semaphore isEmpty] whileFalse: [semaphore signal].
+
+ super tearDown.!
Item was added:
+ TestCase subclass: #AllocationTest
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'KernelTests-Objects'!
Item was added:
+ ----- Method: AllocationTest>>setMaximumOldSpaceTo:around: (in category 'support') -----
+ setMaximumOldSpaceTo: bytes around: aBlock
+ "Attempt to evaluate aBlock with a limit of the requested maximum
+ size of old space, restoring the extant limit after the evaluation."
+
+ | extantLimit |
+ extantLimit := Smalltalk vmParameterAt: 67.
+ Smalltalk vmParameterAt: 67 put: (Smalltalk vmParameterAt: 1) + bytes asInteger.
+ ^aBlock ensure: [Smalltalk vmParameterAt: 67 put: extantLimit]!
Item was added:
+ ----- Method: AllocationTest>>setMaximumOldSpaceToAtLeast:around: (in category 'support') -----
+ setMaximumOldSpaceToAtLeast: bytes around: aBlock
+ "Attempt to evaluate aBlock with a limit of at least the requested maximum
+ size (in bytes) of old space, restoring the extant limit after the evaluation."
+
+ | extantLimit |
+ extantLimit := Smalltalk vmParameterAt: 67.
+ extantLimit >= bytes ifTrue:
+ [^aBlock value].
+ Smalltalk vmParameterAt: 67 put: (Smalltalk vmParameterAt: 1) + bytes asInteger.
+ ^aBlock ensure: [Smalltalk vmParameterAt: 67 put: extantLimit]!
Item was added:
+ ----- Method: AllocationTest>>testOneGigAllocation (in category 'tests') -----
+ testOneGigAllocation
+ self setMaximumOldSpaceToAtLeast: 1024 * 1024 * 1024 * (Smalltalk wordSize = 8
+ ifTrue: [4]
+ ifFalse: [1.5])
+ around:
+ [| sz array failed |
+ failed := false.
+ sz := 1024*1024*1024 / Smalltalk wordSize.
+ array := [Array new: sz]
+ on: OutOfMemory
+ do: [:ex| failed := true].
+ self assert: (failed or: [array isArray and: [array size = sz]])]!
Item was added:
+ ----- Method: AllocationTest>>testOneMegAllocation (in category 'tests') -----
+ testOneMegAllocation
+ "Documentating a weird bug in the allocator"
+ | sz array failed |
+ failed := false.
+ sz := 1024*1024.
+ array := [Array new: sz] on: OutOfMemory do:[:ex| failed := true].
+ self assert: (failed or:[array size = sz]).
+ !
Item was added:
+ ----- Method: AllocationTest>>testOutOfMemorySignal (in category 'tests') -----
+ testOutOfMemorySignal
+ "Ensure that OutOfMemory is signaled eventually. Restrain the available memory first to not stress the machine too much."
+
+ self setMaximumOldSpaceToAtLeast: 1024 * 1024 * 1024 * (Smalltalk wordSize = 8
+ ifTrue: [4]
+ ifFalse: [1.5])
+ around:
+ [| sz |
+ sz := 512*1024*1024. "work around the 1GB alloc bug" "what 1Gb allocation bug? eem"
+ self should: [(1 to: 2000) collect: [:i| Array new: sz]] raise: OutOfMemory].!
Item was added:
+ ----- Method: AllocationTest>>testOutOfMemorySignalExtreme (in category 'tests') -----
+ testOutOfMemorySignalExtreme
+ "Try to allocate more memory than permitted by the -memory vm argument, and check whether the expected error is signaled. Note that current (2017) Spur VMs fail in #new: and #basicNew: with #'bad argument' if given other than a non-negative SmallInteger."
+ Smalltalk heapMemoryLimit ifNotNil:
+ [ : bytes |
+ self
+ should: [ Array new: (bytes // Smalltalk wordSize) + 100 ]
+ raise: OutOfMemory, Error
+ withExceptionDo:
+ [:ex|
+ ex class == Error ifTrue:
+ [self assert: [ex messageText includesSubstring: 'basicNew: with invalid argument' ]]]]!
Item was added:
+ TestCase subclass: #BasicBehaviorClassMetaclassTest
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'KernelTests-Classes'!
+
+ !BasicBehaviorClassMetaclassTest commentStamp: '<historical>' prior: 0!
+ This class contains some tests regarding the classes
+ Behavior
+ ClassDescription
+ Class
+ Metaclass
+ ---
+ !
Item was added:
+ ----- Method: BasicBehaviorClassMetaclassTest>>testBehaviorClassClassDescriptionMetaclassHierarchy (in category 'tests') -----
+ testBehaviorClassClassDescriptionMetaclassHierarchy
+ "self run: #testBehaviorClassClassDescriptionMetaclassHierarchy"
+
+ self assert: Class superclass == ClassDescription.
+ self assert: Metaclass superclass == ClassDescription.
+
+ self assert: ClassDescription superclass == Behavior.
+ self assert: Behavior superclass = Object.
+
+ self assert: Class class class == Metaclass.
+ self assert: Metaclass class class == Metaclass.
+ self assert: ClassDescription class class == Metaclass.
+ self assert: Behavior class class == Metaclass.
+
+
+
+
+
+
+
+
+
+
+
+
+
+ !
Item was added:
+ ----- Method: BasicBehaviorClassMetaclassTest>>testClassDescriptionAllSubInstances (in category 'tests') -----
+ testClassDescriptionAllSubInstances
+ "self run: #testClassDescriptionAllSubInstances"
+
+ | cdNo clsNo metaclsNo |
+ cdNo := ClassDescription allSubInstances size.
+ clsNo := Class allSubInstances size .
+ metaclsNo := Metaclass allSubInstances size.
+
+ "When traits are present, discount all traits if necessary"
+ Smalltalk at: #Trait ifPresent:[:aClass|
+ (aClass inheritsFrom: ClassDescription)
+ ifTrue:[cdNo := cdNo - aClass instanceCount]].
+ Smalltalk at: #ClassTrait ifPresent:[:aClass|
+ (aClass inheritsFrom: ClassDescription)
+ ifTrue:[cdNo := cdNo - aClass instanceCount]].
+
+ self assert: cdNo = (clsNo + metaclsNo).!
Item was added:
+ ----- Method: BasicBehaviorClassMetaclassTest>>testMetaclass (in category 'tests') -----
+ testMetaclass
+ "self run: #testMetaclass"
+
+ self assert: OrderedCollection class class == Metaclass.
+ self assert: Dictionary class class == Metaclass.
+ self assert: Object class class == Metaclass.
+
+
+
+
+
+
+
+
+
+
+
+
+
+ !
Item was added:
+ ----- Method: BasicBehaviorClassMetaclassTest>>testMetaclassName (in category 'tests') -----
+ testMetaclassName
+ "self run: #testMetaclassName"
+
+ self assert: Dictionary class name = 'Dictionary class'.
+ self assert: OrderedCollection class name = 'OrderedCollection class'.
+ !
Item was added:
+ ----- Method: BasicBehaviorClassMetaclassTest>>testMetaclassNumberOfInstances (in category 'tests') -----
+ testMetaclassNumberOfInstances
+ "self run: #testMetaclassNumberOfInstances"
+
+ self assert: Dictionary class allInstances size = 1.
+ self assert: OrderedCollection class allInstances size = 1.!
Item was added:
+ ----- Method: BasicBehaviorClassMetaclassTest>>testMetaclassPointOfCircularity (in category 'tests') -----
+ testMetaclassPointOfCircularity
+ "self run: #testMetaclassPointOfCircularity"
+
+ self assert: Metaclass class instanceCount = 1.
+ self assert: Metaclass class someInstance == Metaclass.
+
+
+
+
+
+
+
+
+
+
+
+ !
Item was added:
+ ----- Method: BasicBehaviorClassMetaclassTest>>testMetaclassSuperclass (in category 'tests') -----
+ testMetaclassSuperclass
+ "self run: #testMetaclassSuperclass"
+
+ self assert: Dictionary class superclass == HashedCollection class.
+ self assert: OrderedCollection class superclass == SequenceableCollection class.
+
+ !
Item was added:
+ ----- Method: BasicBehaviorClassMetaclassTest>>testMetaclassSuperclassHierarchy (in category 'tests') -----
+ testMetaclassSuperclassHierarchy
+ "self run: #testMetaclassSuperclassHierarchy"
+
+ | s |
+ self assert: SequenceableCollection class instanceCount = 1.
+ self assert: Collection class instanceCount = 1.
+ self assert: Object class instanceCount = 1.
+ self assert: ProtoObject class instanceCount = 1.
+
+ s := OrderedCollection new.
+ s add: SequenceableCollection class.
+ s add: Collection class.
+ s add: Object class.
+ s add: ProtoObject class.
+
+ s add: Class.
+ s add: ClassDescription.
+ s add: Behavior.
+ s add: Object.
+ s add: ProtoObject.
+
+ self assert: OrderedCollection class allSuperclasses = s.
+
+
+
+
+
+
+ !
Item was added:
+ ----- Method: BasicBehaviorClassMetaclassTest>>testObjectAllSubclasses (in category 'tests') -----
+ testObjectAllSubclasses
+ "self run: #testObjectAllSubclasses"
+
+ | n2 |
+ n2 := Object allSubclasses size.
+ self assert: n2 = (Object allSubclasses
+ select: [:cls | cls class class == Metaclass
+ or: [cls class == Metaclass]]) size!
Item was added:
+ ----- Method: BasicBehaviorClassMetaclassTest>>testSuperclass (in category 'tests') -----
+ testSuperclass
+ "self run: #testSuperclass"
+
+ | s |
+ self assert: Dictionary superclass == HashedCollection.
+ self assert: OrderedCollection superclass == SequenceableCollection.
+
+ s := OrderedCollection new.
+ s add: SequenceableCollection.
+ s add: Collection.
+ s add: Object.
+ s add: ProtoObject.
+
+ self assert: OrderedCollection allSuperclasses = s.
+
+
+ !
Item was added:
+ TestCase subclass: #BehaviorTest
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'KernelTests-Classes'!
Item was added:
+ ----- Method: BehaviorTest>>sampleMessageWithFirstArgument:andInterleavedCommentBeforeSecondArgument: (in category 'tests') -----
+ sampleMessageWithFirstArgument: firstArgument "This is a comment intended to explain arg1"
+ andInterleavedCommentBeforeSecondArgument: secondArgument
+
+ "This method is here to test a few utilities like formalParametersAt:"
+
+ | thisIsAnUnusedTemp |
+ thisIsAnUnusedTemp := self.
+ ^thisIsAnUnusedTemp!
Item was added:
+ ----- Method: BehaviorTest>>testAllSelectors (in category 'tests') -----
+ testAllSelectors
+
+ self assert: ProtoObject allSelectors = ProtoObject selectors asIdentitySet.
+ self assert: Object allSelectors = (Object selectors union: ProtoObject selectors) asIdentitySet.!
Item was added:
+ ----- Method: BehaviorTest>>testAllSelectorsBelow (in category 'tests') -----
+ testAllSelectorsBelow
+
+ self assert: (Object allSelectorsBelow: ProtoObject) = Object selectors asIdentitySet.
+ self assert: (Object allSelectorsBelow: nil) = (Object selectors union: ProtoObject selectors) asIdentitySet!
Item was added:
+ ----- Method: BehaviorTest>>testBehaviorSubclasses (in category 'tests') -----
+ testBehaviorSubclasses
+ "self run: #testBehaviorSubclasses"
+
+ | b b2 |
+ b := Behavior new.
+ b superclass: OrderedCollection.
+ b methodDictionary: MethodDictionary new.
+
+ b2 := Behavior new.
+ b2 superclass: b.
+ b2 methodDictionary: MethodDictionary new.
+
+ self assert: (b subclasses includes: b2).
+ self deny: (b subclasses includes: b).
+
+ self assert: (b withAllSubclasses includes: b).
+
+ self assert: (b allSubclasses includes: b2).!
Item was added:
+ ----- Method: BehaviorTest>>testBehaviornewnewShouldNotCrash (in category 'tests') -----
+ testBehaviornewnewShouldNotCrash
+
+ Behavior new new.
+ "still not working correctly but at least does not crash the image"
+ !
Item was added:
+ ----- Method: BehaviorTest>>testBinding (in category 'tests') -----
+ testBinding
+ self assert: Object binding value = Object.
+ self assert: Object binding key = #Object.
+
+ self assert: Object class binding value = Object class.
+
+ "returns nil for Metaclasses... like Encoder>>#associationFor:"
+
+ self assert: Object class binding key = nil.!
Item was added:
+ ----- Method: BehaviorTest>>testChange (in category 'tests') -----
+ testChange
+ "self debug: #testChange"
+
+ | behavior model |
+ behavior := Behavior new.
+ behavior superclass: Model.
+ behavior setFormat: Model format.
+ model := Model new.
+ model primitiveChangeClassTo: behavior new.
+ Utilities
+ useAuthorInitials: self className
+ during: [ behavior compile: 'thisIsATest ^ 2' ].
+ self assert: model thisIsATest = 2.
+ self should: [Model new thisIsATest] raise: MessageNotUnderstood.
+
+
+ !
Item was added:
+ ----- Method: BehaviorTest>>testFormalParameterNames (in category 'tests') -----
+ testFormalParameterNames
+ | method |
+ method := #sampleMessageWithFirstArgument:andInterleavedCommentBeforeSecondArgument:.
+ self assert: (self class formalParametersAt: method) size = 2.
+ self assert: (self class formalParametersAt: method) asArray = #('firstArgument' 'secondArgument').
+ CurrentReadOnlySourceFiles cacheDuring: [
+ Object selectorsDo: [:e |
+ self assert: (Object formalParametersAt: e) size = e numArgs]].!
Item was added:
+ ----- Method: BehaviorTest>>testWhichMethodsStoreInto (in category 'tests') -----
+ testWhichMethodsStoreInto
+ ClassForBehaviorTest withAllSubclassesDo: [:eachTestClass |
+ {eachTestClass. eachTestClass class} do: [:eachTestClassOrMetaclass |
+
+ eachTestClassOrMetaclass allInstVarNames do: [:iv |
+ self assert: ((eachTestClassOrMetaclass whichMethodsStoreInto: iv)
+ collect: [:eachMethod | eachMethod selector]) sorted
+ = (eachTestClassOrMetaclass whichSelectorsStoreInto: iv) sorted.
+ self assert: ((eachTestClassOrMetaclass whichMethodsStoreInto: iv)
+ allSatisfy: [:eachMethod | eachMethod methodClass = eachTestClassOrMetaclass]) ].
+
+ eachTestClassOrMetaclass allClassVarNames do: [:cv |
+ self assert: ((eachTestClassOrMetaclass whichMethodsStoreInto: cv)
+ collect: [:eachMethod | eachMethod selector]) sorted
+ = (eachTestClassOrMetaclass whichSelectorsStoreInto: cv) sorted.
+ self assert: ((eachTestClassOrMetaclass whichMethodsStoreInto: cv)
+ allSatisfy: [:eachMethod | eachMethod methodClass = eachTestClassOrMetaclass]) ]]]!
Item was added:
+ ----- Method: BehaviorTest>>testWhichSelectorStoreInto (in category 'tests') -----
+ testWhichSelectorStoreInto
+ self assert: (ClassForBehaviorTest whichSelectorsStoreInto: 'iv1') sorted = #(#initialize #iv1: #reset ).
+ self assert: (ClassForBehaviorTest whichSelectorsStoreInto: 'iv2') sorted = #(#iv2: #reset ).
+ self assert: (ClassForBehaviorTest whichSelectorsStoreInto: 'CV1') sorted = #(#initialize).
+ self assert: (ClassForBehaviorTest whichSelectorsStoreInto: 'CV2') sorted = #().
+
+ self assert: (SubClassForBehaviorTest whichSelectorsStoreInto: 'iv1') sorted = #(#resetIV1 ).
+ self assert: (SubClassForBehaviorTest whichSelectorsStoreInto: 'iv2') sorted = #(#iv2: ).
+ self assert: (SubClassForBehaviorTest whichSelectorsStoreInto: 'CV1') sorted = #().
+ self assert: (SubClassForBehaviorTest whichSelectorsStoreInto: 'CV2') sorted = #().
+
+ self assert: (ClassForBehaviorTest class whichSelectorsStoreInto: 'CV1') sorted = #(#initialize).
+ self assert: (ClassForBehaviorTest class whichSelectorsStoreInto: 'CV2') sorted = #(#initialize).
+ self assert: (ClassForBehaviorTest class whichSelectorsStoreInto: 'civ1') sorted = #(#civ1).
+
+ self assert: (SubClassForBehaviorTest class whichSelectorsStoreInto: 'CV1') sorted = #().
+ self assert: (SubClassForBehaviorTest class whichSelectorsStoreInto: 'CV2') sorted = #().
+ self assert: (SubClassForBehaviorTest class whichSelectorsStoreInto: 'civ1') sorted = #(#install).!
Item was added:
+ TestCase subclass: #BlockClosureTest
+ instanceVariableNames: 'aBlockClosure homeOfABlockClosure'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'KernelTests-Methods'!
+
+ !BlockClosureTest commentStamp: 'eem 3/30/2017 17:45' prior: 0!
+ I am an SUnit Test of BlockClosure and some of Context's simulation machinery'. See also MethodContextTest.
+
+ My fixtures are:
+ aBlockClosure - just some trivial block, i.e., [100@100 corner: 200@200].
+ homeOfABlockClosure - the home context of the block
+
+ NOTES ABOUT AUTOMATING USER INPUTS
+
+ When executing non-interactive programs you will inevitably run into programs (like SqueakMap or Monticello installation packages -- and other programs, to be fair) that require user input during their execution and these sort of problems shoot the whole non-interactiveness of your enclosing program.
+
+ BlockClosure helper methods have been made available and tests of these helpers are provided in this class to demonstrate that it can intercept PopUpMenu and FillInTheBlankMorph requests for user interaction. Of course, PopUpMenu and FillInTheBlankMorph were modified to first signal a ProvideAnswerNotification and if someone handles that (e.g. the enclosing block) then the user interaction will be circumvented and the provided answer of the enclosing block will be used. The basic syntax looks like:
+
+ [self confirm: 'Install spyware?'] valueSupplyingAnswer: #('Install spyware?' false)
+
+ There a few variants on this theme making it easy to provide a literal list of answers for the block so that you can handle a bunch of questions in a block with appropriate answers.
+
+ Additionally, it is possible to suppress Object>>inform: modal dialog boxes as these get in the way of automating anything. After applying this changeset you should be able to tryout the following code snippets to see the variants on this theme that are available.
+
+ Examples:
+
+ So you don't need any introduction here -- this one works like usual.
+ [self inform: 'hello'. #done] value.
+
+ Now let's suppress all inform: messages.
+ [self inform: 'hello'; inform: 'there'. #done] valueSuppressingAllMessages.
+
+ Here we can just suppress a single inform: message.
+ [self inform: 'hi'; inform: 'there'. #done] valueSuppressingMessages: #('there')
+
+ Here you see how you can suppress a list of messages.
+ [self inform: 'hi'; inform: 'there'; inform: 'bill'. #done] valueSuppressingMessages: #('hi' 'there')
+
+ Enough about inform:, let's look at confirm:. As you see this one works as expected.
+ [self confirm: 'You like Squeak?'] value
+
+ Let's supply answers to one of the questions -- check out the return value.
+ [{self confirm: 'You like Smalltalk?'. self confirm: 'You like Squeak?'}]
+ valueSupplyingAnswer: #('You like Smalltalk?' true)
+
+ Here we supply answers using only substrings of the questions (for simplicity).
+ [{self confirm: 'You like Squeak?'. self confirm: 'You like MVC?'}]
+ valueSupplyingAnswers: #( ('Squeak' true) ('MVC' false) )
+
+ This time let's answer all questions exactly the same way.
+ [{self confirm: 'You like Squeak?'. self confirm: 'You like Morphic?'}]
+ valueSupplyingAnswer: true
+
+ And, of course, we can answer FillInTheBlank questions in the same manner.
+ [FillInTheBlank request: 'What day is it?']
+ valueSupplyingAnswer: 'the first day of the rest of your life'
+
+ We can also return whatever the initialAnswer of the FillInTheBlank was by using the #default answer.
+ [FillInTheBlank request: 'What day is it?' initialAnswer: DateAndTime now dayOfWeekName]
+ valueSupplyingAnswer: #default
+
+ Finally, you can also do regex matches on any of the question text (or inform text) (should you have VB-Regex enhancements in your image).
+ [FillInTheBlank request: 'What day is it?']
+ valueSupplyingAnswers: { {'What day.*\?'. DateAndTime now dayOfWeekName} }
+
+ [Comment taken from BlockClosureTest last written by jrp 10/17/2004 12:22]!
Item was added:
+ ----- Method: BlockClosureTest class>>onceMethod (in category 'support methods') -----
+ onceMethod
+ ^[Object new] once!
Item was added:
+ ----- Method: BlockClosureTest>>return: (in category 'private') -----
+ return: something
+
+ ^ something!
Item was added:
+ ----- Method: BlockClosureTest>>setUp (in category 'running') -----
+ setUp
+ super setUp.
+ aBlockClosure := [100@100 corner: 200@200].
+ homeOfABlockClosure := thisContext!
Item was added:
+ ----- Method: BlockClosureTest>>testCull (in category 'tests - evaluating') -----
+ testCull
+ self assert: nil equals: ([ ] cull: 1).
+ self assert: nil equals: ([ :x | ] cull: 1).
+ self assert: 1 equals: ([ :x | x ] cull: 1).
+ self should: [ [ :x :y | ] cull: 1 ] raise: Error.
+ self should: [ [ :x :y :z | ] cull: 1 ] raise: Error.
+ self should: [ [ :x :y :z :a | ] cull: 1 ] raise: Error.
+ self should: [ [ :x :y :z :a :b | ] cull: 1 ] raise: Error.
+ self assert: ([ 0 ] cull: 1) = 0.
+ self assert: ([ :x | x ] cull: 1) = 1 !
Item was added:
+ ----- Method: BlockClosureTest>>testCullCull (in category 'tests - evaluating') -----
+ testCullCull
+ self assert: nil equals: ([ ] cull: 1 cull: 2).
+
+ self assert: nil equals: ([ :x | ] cull: 1 cull: 2).
+ self assert: 1 equals: ([ :x | x ] cull: 1 cull: 2).
+
+ self assert: nil equals: ([ :x :y | ] cull: 1 cull: 2).
+ self assert: 1 equals: ([ :x :y | x ] cull: 1 cull: 2).
+ self assert: 2 equals: ([ :x :y | y ] cull: 1 cull: 2).
+
+ self should: [ [ :x :y :z | ] cull: 1 cull: 2 ] raise: Error.
+ self should: [ [ :x :y :z :a | ] cull: 1 cull: 2 ] raise: Error.
+ self should: [ [ :x :y :z :a :b | ] cull: 1 cull: 2 ] raise: Error.
+ self assert: ([ 0 ] cull: 1 cull: 2) = 0.
+ self assert: ([ :x | x ] cull: 1 cull: 2) = 1.
+ self assert: ([ :x :y | y ] cull: 1 cull: 2) = 2. !
Item was added:
+ ----- Method: BlockClosureTest>>testCullCullCull (in category 'tests - evaluating') -----
+ testCullCullCull
+ self assert: nil equals: ([ ] cull: 1 cull: 2 cull: 3).
+
+ self assert: nil equals: ([ :x | ] cull: 1 cull: 2 cull: 3).
+ self assert: 1 equals: ([ :x | x ] cull: 1 cull: 2 cull: 3).
+
+ self assert: nil equals: ([ :x :y | ] cull: 1 cull: 2 cull: 3).
+ self assert: 1 equals: ([ :x :y | x ] cull: 1 cull: 2 cull: 3).
+ self assert: 2 equals: ([ :x :y | y ] cull: 1 cull: 2 cull: 3).
+
+ self assert: nil equals: ([ :x :y :z | ] cull: 1 cull: 2 cull: 3).
+ self assert: 1 equals: ([ :x :y :z | x ] cull: 1 cull: 2 cull: 3).
+ self assert: 2 equals: ([ :x :y :z | y ] cull: 1 cull: 2 cull: 3).
+ self assert: 3 equals: ([ :x :y :z | z ] cull: 1 cull: 2 cull: 3).
+
+ self should: [ [ :x :y :z :a | ] cull: 1 cull: 2 cull: 3 ] raise: Error.
+ self should: [ [ :x :y :z :a :b | ] cull: 1 cull: 2 cull: 3 ] raise: Error.
+ self assert: ([ 0 ] cull: 1 cull: 2 cull: 3) = 0.
+ self assert: ([ :x | x ] cull: 1 cull: 2 cull: 3) = 1.
+ self assert: ([ :x :y | y ] cull: 1 cull: 2 cull: 3) = 2.
+ self assert: ([ :x :y :z | z ] cull: 1 cull: 2 cull: 3) = 3. !
Item was added:
+ ----- Method: BlockClosureTest>>testCullCullCullCull (in category 'tests - evaluating') -----
+ testCullCullCullCull
+ self assert: nil equals: ([ ] cull: 1 cull: 2 cull: 3 cull: 4).
+
+ self assert: nil equals: ([ :x | ] cull: 1 cull: 2 cull: 3 cull: 4).
+ self assert: 1 equals: ([ :x | x ] cull: 1 cull: 2 cull: 3 cull: 4).
+
+ self assert: nil equals: ([ :x :y | ] cull: 1 cull: 2 cull: 3 cull: 4).
+ self assert: 1 equals: ([ :x :y | x ] cull: 1 cull: 2 cull: 3 cull: 4).
+ self assert: 2 equals: ([ :x :y | y ] cull: 1 cull: 2 cull: 3 cull: 4).
+
+ self assert: nil equals: ([ :x :y :z | ] cull: 1 cull: 2 cull: 3 cull: 4).
+ self assert: 1 equals: ([ :x :y :z | x ] cull: 1 cull: 2 cull: 3 cull: 4).
+ self assert: 2 equals: ([ :x :y :z | y ] cull: 1 cull: 2 cull: 3 cull: 4).
+ self assert: 3 equals: ([ :x :y :z | z ] cull: 1 cull: 2 cull: 3 cull: 4).
+
+ self assert: nil equals: ([ :x :y :z :a | ] cull: 1 cull: 2 cull: 3 cull: 4).
+ self assert: 1 equals: ([ :x :y :z :a | x ] cull: 1 cull: 2 cull: 3 cull: 4).
+ self assert: 2 equals: ([ :x :y :z :a | y ] cull: 1 cull: 2 cull: 3 cull: 4).
+ self assert: 3 equals: ([ :x :y :z :a | z ] cull: 1 cull: 2 cull: 3 cull: 4).
+ self assert: 4 equals: ([ :x :y :z :a | a ] cull: 1 cull: 2 cull: 3 cull: 4).
+
+ self should: [ [ :x :y :z :a :b | ] cull: 1 cull: 2 cull: 3 cull: 4 ] raise: Error.
+ self assert: ([ 0 ] cull: 1 cull: 2 cull: 3 cull: 4) = 0.
+ self assert: ([ :x | x ] cull: 1 cull: 2 cull: 3 cull: 4) = 1.
+ self assert: ([ :x :y | y ] cull: 1 cull: 2 cull: 3 cull: 4) = 2.
+ self assert: ([ :x :y :z | z ] cull: 1 cull: 2 cull: 3 cull: 4) = 3.
+ self assert: ([ :x :y :z :a | a ] cull: 1 cull: 2 cull: 3 cull: 4) = 4.!
Item was added:
+ ----- Method: BlockClosureTest>>testDecompile (in category 'tests - printing') -----
+ testDecompile
+ self assert: ([3 + 4] decompile printString = '{[3 + 4]}')!
Item was added:
+ ----- Method: BlockClosureTest>>testEmptyBlocksAnswerNil (in category 'tests - evaluating') -----
+ testEmptyBlocksAnswerNil
+ "In the olden days ([:a :b|] value: #first value: #last) == #last..."
+ {[]. [:a|]. [:a :b|]. [:a :b :c|]} do:
+ [:block|
+ self assert: (block cull: 1 cull: 2 cull: 3) equals: nil]!
Item was added:
+ ----- Method: BlockClosureTest>>testMoreThanOnce (in category 'tests - evaluating') -----
+ testMoreThanOnce
+ "Make sure that we can use once more than once"
+ | moreThanOnce |
+ moreThanOnce := (1 to: 3) collect: [:e | [String new] once -> [Array new] once].
+ self assert: (moreThanOnce allSatisfy: [:each | each key isString]).
+ self assert: (moreThanOnce allSatisfy: [:each | each value isArray]).
+ self assert: (moreThanOnce allSatisfy: [:each | each key == moreThanOnce first key]).
+ self assert: (moreThanOnce allSatisfy: [:each | each value == moreThanOnce first value]).!
Item was added:
+ ----- Method: BlockClosureTest>>testMoreThanOnceForEqualBlocks (in category 'tests - evaluating') -----
+ testMoreThanOnceForEqualBlocks
+ "Make sure that we can use once more than once"
+ | moreThanOnce |
+ moreThanOnce := (1 to: 3) collect: [:e | [Object new] once -> [Object new] once].
+ self assert: (moreThanOnce allSatisfy: [:each | each key == moreThanOnce first key]).
+ self assert: (moreThanOnce allSatisfy: [:each | each value == moreThanOnce first value]).
+ self assert: (moreThanOnce noneSatisfy: [:each | each key == each value]).!
Item was added:
+ ----- Method: BlockClosureTest>>testNew (in category 'tests') -----
+ testNew
+ self should: [Context new: 5] raise: Error.
+ [Context new: 5]
+ on: Error do: [:e|
+ self assert: (e messageText includesSubstring: 'newForMethod:') description: 'Error doesn''t tell you what you did wrong by calling #new:'].
+
+ self should: [Context new] raise: Error.
+ [Context new]
+ on: Error do: [:e|
+ self assert: (e messageText includesSubstring: 'newForMethod:') description: 'Error doesn''t tell you what you did wrong by calling #new']!
Item was added:
+ ----- Method: BlockClosureTest>>testNoArguments (in category 'tests') -----
+ testNoArguments
+ [10
+ timesRepeat: [:arg | 1 + 2]]
+ ifError: [:err :rcvr | self deny: err = 'This block requires 1 arguments.'].
+ [10
+ timesRepeat: [:arg1 :arg2 | 1 + 2]]
+ ifError: [:err :rcvr | self deny: err = 'This block requires 2 arguments.']!
Item was added:
+ ----- Method: BlockClosureTest>>testOnce (in category 'tests - evaluating') -----
+ testOnce
+ | objs result |
+ objs := (1 to: 10) collect: [:ign| [Object new] once].
+ self assert: (objs allSatisfy: [:obj| obj == objs first]).
+ result := self class onceMethod.
+ 1 to: 10 do:
+ [:ign|
+ self assert: result == self class onceMethod]!
Item was added:
+ ----- Method: BlockClosureTest>>testOneArgument (in category 'tests') -----
+ testOneArgument
+ | c |
+ c := OrderedCollection new.
+ c add: 'hello'.
+ [c
+ do: [1 + 2]]
+ ifError: [:err :rcvr | self deny: err = 'This block requires 0 arguments.'].
+ [c
+ do: [:arg1 :arg2 | 1 + 2]]
+ ifError: [:err :rcvr | self deny: err = 'This block requires 2 arguments.']!
Item was added:
+ ----- Method: BlockClosureTest>>testRunSimulated (in category 'tests') -----
+ testRunSimulated
+ self assert: Rectangle equals:
+ (Context runSimulated: aBlockClosure asContext) class.
+ self assert: 42 equals:
+ (Context runSimulated: [self return: 42]).
+ self
+ should: [Context runSimulated: [self halt]]
+ raise: Halt.!
Item was added:
+ ----- Method: BlockClosureTest>>testRunSimulatedContextAtEachStep (in category 'tests') -----
+ testRunSimulatedContextAtEachStep
+
+ | context |
+ context := aBlockClosure asContext.
+ self assert: Rectangle equals: (thisContext
+ runSimulated: context
+ contextAtEachStep: [:ctxt | self assert:
+ [ctxt == context or: [ctxt hasSender: context]]]) class.!
Item was added:
+ ----- Method: BlockClosureTest>>testSetUp (in category 'tests') -----
+ testSetUp
+ "Note: In addition to verifying that the setUp worked the way it was expected to, testSetUp is used to illustrate the meaning of the simple access methods, methods that are not normally otherwise 'tested'"
+ self deny: aBlockClosure isContext.
+ self assert: aBlockClosure isClosure.
+ self assert: aBlockClosure home = homeOfABlockClosure.
+ self assert: aBlockClosure receiver = self.
+ self assert: ((aBlockClosure isMemberOf: FullBlockClosure)
+ ifTrue: [aBlockClosure method isCompiledBlock]
+ ifFalse: [aBlockClosure method isCompiledMethod])!
Item was added:
+ ----- Method: BlockClosureTest>>testSourceString (in category 'tests - printing') -----
+ testSourceString
+ self assert: [] sourceString equals: '[]'.
+ self assert: (#((#'[' #':arg' #| nil #']') (#'[' #':arg' #| #']')) includes: (Scanner new scanTokens: [:arg|] sourceString)).
+ self assert: (Scanner new scanTokens: [ : stream | self printSourceOn: stream ] sourceString)
+ equals: #(#'[' #':stream' #| #self #printSourceOn: #stream #']')!
Item was added:
+ ----- Method: BlockClosureTest>>testSupplyAnswerOfFillInTheBlank (in category 'tests - supply answer') -----
+ testSupplyAnswerOfFillInTheBlank
+
+ UIManager subclassesDo: [:managerClass |
+ self should: ['blue' = ([managerClass new request: 'Your favorite color?']
+ valueSupplyingAnswer: #('Your favorite color?' 'blue'))]]!
Item was added:
+ ----- Method: BlockClosureTest>>testSupplyAnswerOfFillInTheBlankUsingDefaultAnswer (in category 'tests - supply answer') -----
+ testSupplyAnswerOfFillInTheBlankUsingDefaultAnswer
+
+ UIManager subclassesDo: [:managerClass |
+ self should: ['red' = ([managerClass new request: 'Your favorite color?' initialAnswer: 'red']
+ valueSupplyingAnswer: #('Your favorite color?' #default))]]!
Item was added:
+ ----- Method: BlockClosureTest>>testSupplyAnswerUsingOnlySubstringOfQuestion (in category 'tests - supply answer') -----
+ testSupplyAnswerUsingOnlySubstringOfQuestion
+
+ UIManager subclassesDo: [:managerClass |
+ self should: [false = ([managerClass new confirm: 'You like Smalltalk?']
+ valueSupplyingAnswer: #('like' false))]]!
Item was added:
+ ----- Method: BlockClosureTest>>testSupplyAnswerUsingRegexMatchOfQuestion (in category 'tests - supply answer') -----
+ testSupplyAnswerUsingRegexMatchOfQuestion
+
+ (String includesSelector: #matchesRegex:) ifFalse: [^ self].
+
+ UIManager subclassesDo: [:managerClass |
+ self should: [true = ([managerClass new confirm: 'You like Smalltalk?']
+ valueSupplyingAnswer: #('.*Smalltalk\?' true))]]!
Item was added:
+ ----- Method: BlockClosureTest>>testSupplySpecificAnswerToQuestion (in category 'tests - supply answer') -----
+ testSupplySpecificAnswerToQuestion
+
+ UIManager subclassesDo: [:managerClass |
+ self should: [false = ([managerClass new confirm: 'You like Smalltalk?']
+ valueSupplyingAnswer: #('You like Smalltalk?' false))]]!
Item was added:
+ ----- Method: BlockClosureTest>>testSupplySpecificAnswerToSelection (in category 'tests - supply answer') -----
+ testSupplySpecificAnswerToSelection
+
+ | windowTitle |
+ windowTitle := 'What is your favorite letter?'.
+ UIManager subclassesDo: [:managerClass |
+ self should: [#b = ([managerClass new chooseFrom: #(a b c) values: #(a b c) title: windowTitle]
+ valueSupplyingAnswer: {windowTitle . #b})]].
+
+ UIManager subclassesDo: [:managerClass |
+ self should: [#b = ([managerClass new chooseFrom: #(a b c) values: #(a b c) title: windowTitle]
+ valueSupplyingAnswer: {windowTitle . 2})]]!
Item was added:
+ ----- Method: BlockClosureTest>>testSuppressInform (in category 'tests - supply answer') -----
+ testSuppressInform
+
+ UIManager subclassesDo: [:managerClass | | manager |
+ manager := managerClass new.
+ self should: [[manager inform: 'Should not see this message or this test failed!!']
+ valueSuppressingAllMessages]]!
Item was added:
+ ----- Method: BlockClosureTest>>testSuppressInformUsingStringMatchOptions (in category 'tests - supply answer') -----
+ testSuppressInformUsingStringMatchOptions
+
+ UIManager subclassesDo: [:managerClass | | manager |
+ manager := managerClass new.
+ #("message" "pattern"
+ 'Should not see this message or this test failed!!' 'Should not see this message or this test failed!!'
+ 'Should not see this message or this test failed!!' 'not see this message'
+ 'Should not see this message or this test failed!!' '*message*failed#')
+ pairsDo: [:message :pattern |
+ self assert: ([manager inform: message] valueSuppressingMessages: {pattern})]]!
Item was added:
+ ----- Method: BlockClosureTest>>testTallyInstructions (in category 'tests') -----
+ testTallyInstructions
+ self assert: ((aBlockClosure isMemberOf: FullBlockClosure)
+ ifTrue: [14]
+ ifFalse: [15])
+ equals: (Context tallyInstructions: aBlockClosure asContext) size!
Item was added:
+ ----- Method: BlockClosureTest>>testValue (in category 'tests - evaluating') -----
+ testValue
+
+ "#value"
+ self
+ assert: nil equals: [ ] value;
+ assert: 1 equals: [ 1 ] value;
+ should: [ [ :a | ] value ] raise: Error.
+
+ "#value:"
+ self
+ assert: nil equals: ([ :a | ] value: 1);
+ assert: 1 equals: ([ :a | a ] value: 1);
+ should: [ [ ] value: 1 ] raise: Error;
+ should: [ [ :a :b | ] value: 1 ] raise: Error!
Item was added:
+ ----- Method: BlockClosureTest>>testValueValue (in category 'tests - evaluating') -----
+ testValueValue
+
+ self
+ assert: nil equals: ([ :a :b | ] value: 1 value: 2);
+ assert: 1 equals: ([ :a :b | a ] value: 1 value: 2);
+ assert: 2 equals: ([ :a :b | b ] value: 1 value: 2);
+ should: [ [ ] value: 1 value: 2 ] raise: Error;
+ should: [ [ :a | ] value: 1 value: 2 ] raise: Error;
+ should: [ [ :a :b :c | ] value: 1 value: 2 ] raise: Error!
Item was added:
+ ----- Method: BlockClosureTest>>testValueValueValue (in category 'tests - evaluating') -----
+ testValueValueValue
+
+ self
+ assert: nil equals: ([ :a :b :c | ] value: 1 value: 2 value: 3);
+ assert: 1 equals: ([ :a :b :c | a ] value: 1 value: 2 value: 3);
+ assert: 2 equals: ([ :a :b :c | b ] value: 1 value: 2 value: 3);
+ assert: 3 equals: ([ :a :b :c | c ] value: 1 value: 2 value: 3);
+ should: [ [ ] value: 1 value: 2 value: 3 ] raise: Error;
+ should: [ [ :a | ] value: 1 value: 2 value: 3 ] raise: Error;
+ should: [ [ :a :b | ] value: 1 value: 2 value: 3 ] raise: Error;
+ should: [ [ :a :b :c :d | ] value: 1 value: 2 value: 3 ] raise: Error!
Item was added:
+ ----- Method: BlockClosureTest>>testValueValueValueValue (in category 'tests - evaluating') -----
+ testValueValueValueValue
+
+ self
+ assert: nil equals: ([ :a :b :c :d | ] value: 1 value: 2 value: 3 value: 4);
+ assert: 1 equals: ([ :a :b :c :d | a ] value: 1 value: 2 value: 3 value: 4);
+ assert: 2 equals: ([ :a :b :c :d | b ] value: 1 value: 2 value: 3 value: 4);
+ assert: 3 equals: ([ :a :b :c :d | c ] value: 1 value: 2 value: 3 value: 4);
+ assert: 4 equals: ([ :a :b :c :d | d ] value: 1 value: 2 value: 3 value: 4);
+ should: [ [ ] value: 1 value: 2 value: 3 value: 4 ] raise: Error;
+ should: [ [ :a | ] value: 1 value: 2 value: 3 value: 4 ] raise: Error;
+ should: [ [ :a :b | ] value: 1 value: 2 value: 3 value: 4 ] raise: Error;
+ should: [ [ :a :b :c | ] value: 1 value: 2 value: 3 value: 4 ] raise: Error;
+ should: [ [ :a :b :c :d :e | ] value: 1 value: 2 value: 3 value: 4 ] raise: Error!
Item was added:
+ ----- Method: BlockClosureTest>>testValueValueValueValueValue (in category 'tests - evaluating') -----
+ testValueValueValueValueValue
+
+ self
+ assert: nil equals: ([ :a :b :c :d :e | ] value: 1 value: 2 value: 3 value: 4 value: 5);
+ assert: 1 equals: ([ :a :b :c :d :e | a ] value: 1 value: 2 value: 3 value: 4 value: 5);
+ assert: 2 equals: ([ :a :b :c :d :e | b ] value: 1 value: 2 value: 3 value: 4 value: 5);
+ assert: 3 equals: ([ :a :b :c :d :e | c ] value: 1 value: 2 value: 3 value: 4 value: 5);
+ assert: 4 equals: ([ :a :b :c :d :e | d ] value: 1 value: 2 value: 3 value: 4 value: 5);
+ assert: 5 equals: ([ :a :b :c :d :e | e ] value: 1 value: 2 value: 3 value: 4 value: 5);
+ should: [ [ ] value: 1 value: 2 value: 3 value: 4 value: 5 ] raise: Error;
+ should: [ [ :a | ] value: 1 value: 2 value: 3 value: 4 value: 5 ] raise: Error;
+ should: [ [ :a :b | ] value: 1 value: 2 value: 3 value: 4 value: 5 ] raise: Error;
+ should: [ [ :a :b :c | ] value: 1 value: 2 value: 3 value: 4 value: 5 ] raise: Error;
+ should: [ [ :a :b :c :d | ] value: 1 value: 2 value: 3 value: 4 value: 5 ] raise: Error;
+ should: [ [ :a :b :c :d :e :f | ] value: 1 value: 2 value: 3 value: 4 value: 5 ] raise: Error!
Item was added:
+ ----- Method: BlockClosureTest>>testValueWithPossibleArgs (in category 'tests - evaluating') -----
+ testValueWithPossibleArgs
+ | block blockWithArg blockWith2Arg |
+
+ block := [1].
+ blockWithArg := [:arg | arg].
+ blockWith2Arg := [:arg1 :arg2 | {arg1. arg2}].
+
+ self assert: (block valueWithPossibleArgs: #()) = 1.
+ self assert: (block valueWithPossibleArgs: #(1)) = 1.
+
+ self assert: (blockWithArg valueWithPossibleArgs: #()) = nil.
+ self assert: (blockWithArg valueWithPossibleArgs: #(1)) = 1.
+ self assert: (blockWithArg valueWithPossibleArgs: #(1 2)) = 1.
+
+ self assert: (blockWith2Arg valueWithPossibleArgs: #()) = {nil .nil}.
+ self assert: (blockWith2Arg valueWithPossibleArgs: #(1)) = {1 . nil}.
+ self assert: (blockWith2Arg valueWithPossibleArgs: #(1 2)) = #(1 2).
+ self assert: (blockWith2Arg valueWithPossibleArgs: #(1 2 3)) = #(1 2)!
Item was added:
+ ----- Method: BlockClosureTest>>testValueWithPossibleArgument (in category 'tests - evaluating') -----
+ testValueWithPossibleArgument
+ | block blockWithArg blockWith2Arg |
+
+ block := [1].
+ blockWithArg := [:arg | arg].
+ blockWith2Arg := [:arg1 :arg2 | {arg1. arg2}].
+
+ self assert: (block valueWithPossibleArgument: 1) = 1.
+
+ self assert: (blockWithArg valueWithPossibleArgument: 1) = 1.
+
+ self assert: (blockWith2Arg valueWithPossibleArgument: 1) = {1 . nil}!
Item was added:
+ ClassTestCase subclass: #BooleanTest
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'KernelTests-Objects'!
+
+ !BooleanTest commentStamp: '<historical>' prior: 0!
+ This is the unit test for the class Boolean. Unit tests are a good way to exercise the functionality of your system in a repeatable and automatic manner. They are therefore recommended if you plan to release anything. For more information, see:
+ - http://www.c2.com/cgi/wiki?UnitTest
+ - http://minnow.cc.gatech.edu/squeak/1547
+ - the sunit class category
+ !
Item was added:
+ ----- Method: BooleanTest>>testBooleanInitializedInstance (in category 'tests') -----
+ testBooleanInitializedInstance
+
+ self assert: (Boolean initializedInstance = nil).!
Item was added:
+ ----- Method: BooleanTest>>testBooleanNew (in category 'tests') -----
+ testBooleanNew
+
+ self shouldRaiseError: [Boolean new].
+ self shouldRaiseError: [True new].
+ self shouldRaiseError: [False new].!
Item was added:
+ ----- Method: BooleanTest>>testNew (in category 'tests') -----
+ testNew
+
+ self shouldRaiseError: [Boolean new].!
Item was added:
+ TestCase subclass: #CategorizerTest
+ instanceVariableNames: 'categorizer'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'KernelTests-Classes'!
Item was added:
+ ----- Method: CategorizerTest>>setUp (in category 'running') -----
+ setUp
+ categorizer := Categorizer defaultList: #(a b c d e).
+ categorizer classifyAll: #(a b c) under: 'abc'.
+ categorizer addCategory: 'unreal'.!
Item was added:
+ ----- Method: CategorizerTest>>testClassifyNewElementNewCategory (in category 'tests') -----
+ testClassifyNewElementNewCategory
+ categorizer classify: #f under: #nice.
+ self assert: categorizer printString =
+ '(''as yet unclassified'' d e)
+ (''abc'' a b c)
+ (''unreal'')
+ (''nice'' f)
+ '!
Item was added:
+ ----- Method: CategorizerTest>>testClassifyNewElementOldCategory (in category 'tests') -----
+ testClassifyNewElementOldCategory
+ categorizer classify: #f under: #unreal.
+ self assert: categorizer printString =
+ '(''as yet unclassified'' d e)
+ (''abc'' a b c)
+ (''unreal'' f)
+ '!
Item was added:
+ ----- Method: CategorizerTest>>testClassifyOldElementNewCategory (in category 'tests') -----
+ testClassifyOldElementNewCategory
+ categorizer classify: #e under: #nice.
+ self assert: categorizer printString =
+ '(''as yet unclassified'' d)
+ (''abc'' a b c)
+ (''unreal'')
+ (''nice'' e)
+ '!
Item was added:
+ ----- Method: CategorizerTest>>testClassifyOldElementOldCategory (in category 'tests') -----
+ testClassifyOldElementOldCategory
+ categorizer classify: #e under: #unreal.
+ self assert: categorizer printString =
+ '(''as yet unclassified'' d)
+ (''abc'' a b c)
+ (''unreal'' e)
+ '!
Item was added:
+ ----- Method: CategorizerTest>>testDefaultCategoryIsTransient (in category 'tests') -----
+ testDefaultCategoryIsTransient
+ "Test that category 'as yet unclassified' disapears when all it's elements are removed'"
+ categorizer classifyAll: #(d e) under: #abc.
+ self assert: categorizer printString =
+ '(''abc'' a b c d e)
+ (''unreal'')
+ '!
Item was added:
+ ----- Method: CategorizerTest>>testNoSpecialCategories (in category 'tests') -----
+ testNoSpecialCategories
+
+ SystemNavigation allClasses do: [:class |
+ {class. class class} do: [:classOrMetaClass |
+ self
+ assert: (classOrMetaClass organization categories includes: Categorizer allCategory) not
+ description: ('{1} must not have the all-category in its organization.' format: {class name}).
+ self
+ assert: (classOrMetaClass organization isEmpty or: [
+ (classOrMetaClass organization categories includes: Categorizer nullCategory) not])
+ description: ('{1} must not have the null-category in its organization.' format: {class name}).]].!
Item was added:
+ ----- Method: CategorizerTest>>testNullCategory (in category 'tests') -----
+ testNullCategory
+ "Test that category 'as yet unclassified' disapears when all it's elements are removed'"
+ | aCategorizer |
+ aCategorizer := Categorizer defaultList: #().
+ self assert: aCategorizer printString =
+ '(''as yet unclassified'')
+ '.
+ self assert: aCategorizer categories = #('no messages').
+ aCategorizer classify: #a under: #b.
+ self assert: aCategorizer printString =
+ '(''b'' a)
+ '.
+ self assert: aCategorizer categories = #(b).!
Item was added:
+ ----- Method: CategorizerTest>>testRemoveEmptyCategory (in category 'tests') -----
+ testRemoveEmptyCategory
+ categorizer removeCategory: #unreal.
+ self assert: categorizer printString =
+ '(''as yet unclassified'' d e)
+ (''abc'' a b c)
+ '!
Item was added:
+ ----- Method: CategorizerTest>>testRemoveExistingElement (in category 'tests') -----
+ testRemoveExistingElement
+ categorizer removeElement: #a.
+ self assert: categorizer printString =
+ '(''as yet unclassified'' d e)
+ (''abc'' b c)
+ (''unreal'')
+ '!
Item was added:
+ ----- Method: CategorizerTest>>testRemoveNonEmptyCategory (in category 'tests') -----
+ testRemoveNonEmptyCategory
+ self should: [categorizer removeCategory: #abc] raise: Error.
+ self assert: categorizer printString =
+ '(''as yet unclassified'' d e)
+ (''abc'' a b c)
+ (''unreal'')
+ '!
Item was added:
+ ----- Method: CategorizerTest>>testRemoveNonExistingCategory (in category 'tests') -----
+ testRemoveNonExistingCategory
+ categorizer removeCategory: #nice.
+ self assert: categorizer printString =
+ '(''as yet unclassified'' d e)
+ (''abc'' a b c)
+ (''unreal'')
+ '!
Item was added:
+ ----- Method: CategorizerTest>>testRemoveNonExistingElement (in category 'tests') -----
+ testRemoveNonExistingElement
+ categorizer removeElement: #f.
+ self assert: categorizer printString =
+ '(''as yet unclassified'' d e)
+ (''abc'' a b c)
+ (''unreal'')
+ '!
Item was added:
+ ----- Method: CategorizerTest>>testRemoveThenRename (in category 'tests') -----
+ testRemoveThenRename
+ categorizer removeCategory: #unreal.
+ categorizer renameCategory: #abc toBe: #unreal.
+ self assert: categorizer printString =
+ '(''as yet unclassified'' d e)
+ (''unreal'' a b c)
+ '!
Item was added:
+ ----- Method: CategorizerTest>>testUnchanged (in category 'tests') -----
+ testUnchanged
+ self assert: categorizer printString =
+ '(''as yet unclassified'' d e)
+ (''abc'' a b c)
+ (''unreal'')
+ '!
Item was added:
+ ClassTestCase subclass: #ClassBuilderTest
+ instanceVariableNames: 'baseClass subClass baseClass2 subSubClass'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'KernelTests-Classes'!
Item was added:
+ ----- Method: ClassBuilderTest>>baseClassName (in category 'utilities') -----
+ baseClassName
+ ^#DummyClassBuilderFormatTestSuperClass!
Item was added:
+ ----- Method: ClassBuilderTest>>categoryNameForTemporaryClasses (in category 'utilities') -----
+ categoryNameForTemporaryClasses
+ "Answer the category where to classify temporarily created classes"
+
+ ^'Dummy-Tests-ClassBuilder'!
Item was added:
+ ----- Method: ClassBuilderTest>>cleanup (in category 'utilities') -----
+ cleanup
+ subSubClass ifNotNil:[subSubClass removeFromSystem].
+ subClass ifNotNil:[subClass removeFromSystem].
+ baseClass ifNotNil:[baseClass removeFromSystem].
+ baseClass2 ifNotNil: [baseClass2 removeFromSystem].
+ (Smalltalk organization listAtCategoryNamed: self categoryNameForTemporaryClasses) isEmpty
+ ifTrue: [Smalltalk organization removeCategory: self categoryNameForTemporaryClasses]!
Item was added:
+ ----- Method: ClassBuilderTest>>makeByteVariableSubclassOf: (in category 'utilities') -----
+ makeByteVariableSubclassOf: aClass
+ ^ aClass variableByteSubclass: self subClassName
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: self categoryNameForTemporaryClasses!
Item was added:
+ ----- Method: ClassBuilderTest>>makeDoubleByteVariableSubclassOf: (in category 'utilities') -----
+ makeDoubleByteVariableSubclassOf: aClass
+ ^ aClass variableDoubleByteSubclass: self subClassName
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: self categoryNameForTemporaryClasses!
Item was added:
+ ----- Method: ClassBuilderTest>>makeDoubleWordVariableSubclassOf: (in category 'utilities') -----
+ makeDoubleWordVariableSubclassOf: aClass
+ ^ aClass variableDoubleWordSubclass: self subClassName
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: self categoryNameForTemporaryClasses!
Item was added:
+ ----- Method: ClassBuilderTest>>makeIVarsSubclassOf: (in category 'utilities') -----
+ makeIVarsSubclassOf: aClass
+ ^ aClass subclass: self subClassName
+ instanceVariableNames: 'var3 var4'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: self categoryNameForTemporaryClasses!
Item was added:
+ ----- Method: ClassBuilderTest>>makeNormalSubclassOf: (in category 'utilities') -----
+ makeNormalSubclassOf: aClass
+ ^ aClass subclass: self subClassName
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: self categoryNameForTemporaryClasses!
Item was added:
+ ----- Method: ClassBuilderTest>>makeVariableSubclassOf: (in category 'utilities') -----
+ makeVariableSubclassOf: aClass
+ ^ aClass variableSubclass: self subClassName
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: self categoryNameForTemporaryClasses!
Item was added:
+ ----- Method: ClassBuilderTest>>makeWeakSubclassOf: (in category 'utilities') -----
+ makeWeakSubclassOf: aClass
+ ^ aClass weakSubclass: self subClassName
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: self categoryNameForTemporaryClasses!
Item was added:
+ ----- Method: ClassBuilderTest>>makeWordVariableSubclassOf: (in category 'utilities') -----
+ makeWordVariableSubclassOf: aClass
+ ^ aClass variableWordSubclass: self subClassName
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: self categoryNameForTemporaryClasses!
Item was added:
+ ----- Method: ClassBuilderTest>>performTest (in category 'private') -----
+ performTest
+
+ Utilities
+ useAuthorInitials: self className
+ during: [ super performTest ]!
Item was added:
+ ----- Method: ClassBuilderTest>>subClassName (in category 'utilities') -----
+ subClassName
+ ^#DummyClassBuilderFormatTestSubClass!
Item was added:
+ ----- Method: ClassBuilderTest>>subSubClassName (in category 'utilities') -----
+ subSubClassName
+ ^#DummyClassBuilderFormatTestSubSubClass!
Item was added:
+ ----- Method: ClassBuilderTest>>tearDown (in category 'running') -----
+ tearDown
+
+ self cleanup.
+ baseClass := nil.
+ subClass := nil.
+ baseClass2 := nil.
+ subSubClass := nil!
Item was added:
+ ----- Method: ClassBuilderTest>>testByteVariableSubclass (in category 'tests - format') -----
+ testByteVariableSubclass
+ "Ensure that the invariants for superclass/subclass format are preserved"
+ baseClass := Object variableByteSubclass: self baseClassName
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: self categoryNameForTemporaryClasses.
+ [
+
+ subClass := self makeNormalSubclassOf: baseClass.
+ self deny: (subClass isPointers).
+ self assert: (subClass isVariable).
+ self deny: (subClass isWeak).
+ self assert: (subClass isBytes).
+ self deny: (subClass isWords).
+ self deny: (subClass isShorts).
+ self deny: (subClass isLongs).
+ subClass removeFromSystem.
+
+ "pointer classes"
+ self should:[self makeIVarsSubclassOf: baseClass] raise: Error.
+ self should:[self makeVariableSubclassOf: baseClass] raise: Error.
+ self should:[self makeWeakSubclassOf: baseClass] raise: Error.
+
+ "bit classes"
+ subClass := self makeByteVariableSubclassOf: baseClass.
+ self deny: (subClass isPointers).
+ self assert: (subClass isVariable).
+ self deny: (subClass isWeak).
+ self assert: (subClass isBytes).
+ self deny: (subClass isWords).
+ self deny: (subClass isShorts).
+ self deny: (subClass isLongs).
+ subClass removeFromSystem.
+
+ self should:[self makeWordVariableSubclassOf: baseClass] raise: Error.
+ self should:[self makeDoubleByteVariableSubclassOf: baseClass] raise: Error.
+ self should:[self makeDoubleWordVariableSubclassOf: baseClass] raise: Error.
+
+ ] ensure:[self cleanup].!
Item was added:
+ ----- Method: ClassBuilderTest>>testChangeToVariableSubclass (in category 'tests - format') -----
+ testChangeToVariableSubclass
+ "Ensure that the invariants for superclass/subclass format are preserved"
+ baseClass := Object subclass: self baseClassName
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: self categoryNameForTemporaryClasses.
+ [
+ baseClass := Object variableSubclass: self baseClassName
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: self categoryNameForTemporaryClasses.
+
+ ] ensure:[self cleanup].!
Item was added:
+ ----- Method: ClassBuilderTest>>testCompiledMethodSubclass (in category 'tests - format') -----
+ testCompiledMethodSubclass
+ "Ensure that the invariants for superclass/subclass format are preserved"
+ [self deny: (Smalltalk includesKey: self subClassName).
+ baseClass := CompiledMethod
+ variableByteSubclass: self subClassName
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: self categoryNameForTemporaryClasses.
+ self deny: baseClass isPointers.
+ self assert: baseClass isVariable.
+ self deny: baseClass isWeak.
+ self assert: baseClass isBytes.
+ self assert: baseClass isCompiledMethodClass.
+ self deny: baseClass isWords.
+ self deny: baseClass isShorts.
+ self deny: baseClass isLongs.
+ "Now move it to be a sibling; test it maintains its CompiledMethod-ness"
+ baseClass := ByteArray
+ variableByteSubclass: self subClassName
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: self categoryNameForTemporaryClasses.
+ self deny: baseClass isPointers.
+ self assert: baseClass isVariable.
+ self deny: baseClass isWeak.
+ self assert: baseClass isBytes.
+ self assert: baseClass isCompiledMethodClass.
+ self deny: baseClass isWords.
+ self deny: baseClass isShorts.
+ self deny: baseClass isLongs]
+ ensure: [self cleanup]!
Item was added:
+ ----- Method: ClassBuilderTest>>testDoubleByteVariableSubclass (in category 'tests - format') -----
+ testDoubleByteVariableSubclass
+ "Ensure that the invariants for superclass/subclass format are preserved"
+ baseClass := Object variableDoubleByteSubclass: self baseClassName
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: self categoryNameForTemporaryClasses.
+ [
+ subClass := self makeNormalSubclassOf: baseClass.
+ self deny: (subClass isPointers).
+ self assert: (subClass isVariable).
+ self assert: (subClass isShorts).
+ self deny: (subClass isWeak).
+ self deny: (subClass isBytes).
+ self deny: (subClass isWords).
+ self deny: (subClass isLongs).
+ subClass removeFromSystem.
+
+ "pointer classes"
+ self should:[self makeIVarsSubclassOf: baseClass] raise: Error.
+ self should:[self makeVariableSubclassOf: baseClass] raise: Error.
+ self should:[self makeWeakSubclassOf: baseClass] raise: Error.
+
+ "bit classes"
+ self should:[self makeByteVariableSubclassOf: baseClass] raise: Error.
+ self should:[self makeWordVariableSubclassOf: baseClass] raise: Error.
+ self should:[self makeDoubleWordVariableSubclassOf: baseClass] raise: Error.
+ subClass := self makeDoubleByteVariableSubclassOf: baseClass.
+ self deny: (subClass isPointers).
+ self assert: (subClass isVariable).
+ self assert: (subClass isShorts).
+ self deny: (subClass isWeak).
+ self deny: (subClass isBytes).
+ self deny: (subClass isWords).
+ self deny: (subClass isLongs).
+ subClass removeFromSystem.
+ ] ensure:[self cleanup].!
Item was added:
+ ----- Method: ClassBuilderTest>>testDoubleWordVariableSubclass (in category 'tests - format') -----
+ testDoubleWordVariableSubclass
+ "Ensure that the invariants for superclass/subclass format are preserved"
+ baseClass := Object variableDoubleWordSubclass: self baseClassName
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: self categoryNameForTemporaryClasses.
+ [
+ subClass := self makeNormalSubclassOf: baseClass.
+ self deny: (subClass isPointers).
+ self assert: (subClass isVariable).
+ self assert: (subClass isLongs).
+ self deny: (subClass isWeak).
+ self deny: (subClass isBytes).
+ self deny: (subClass isShorts).
+ self deny: (subClass isWords).
+ subClass removeFromSystem.
+
+ "pointer classes"
+ self should:[self makeIVarsSubclassOf: baseClass] raise: Error.
+ self should:[self makeVariableSubclassOf: baseClass] raise: Error.
+ self should:[self makeWeakSubclassOf: baseClass] raise: Error.
+
+ "bit classes"
+ self should:[self makeByteVariableSubclassOf: baseClass] raise: Error.
+ self should:[self makeDoubleByteVariableSubclassOf: baseClass] raise: Error.
+ self should:[self makeWordVariableSubclassOf: baseClass] raise: Error.
+ subClass := self makeDoubleWordVariableSubclassOf: baseClass.
+ self deny: (subClass isPointers).
+ self assert: (subClass isVariable).
+ self assert: (subClass isLongs).
+ self deny: (subClass isWeak).
+ self deny: (subClass isBytes).
+ self deny: (subClass isShorts).
+ self deny: (subClass isWords).
+ subClass removeFromSystem.
+ ] ensure:[self cleanup].!
Item was added:
+ ----- Method: ClassBuilderTest>>testDuplicateClassVariableError (in category 'tests - reshape') -----
+ testDuplicateClassVariableError
+ baseClass := Object subclass: self baseClassName
+ instanceVariableNames: ''
+ classVariableNames: 'TestVar'
+ poolDictionaries: ''
+ category: self categoryNameForTemporaryClasses.
+
+ self should:[
+ subClass := baseClass subclass: self subClassName
+ instanceVariableNames: ''
+ classVariableNames: 'TestVar'
+ poolDictionaries: ''
+ category: self categoryNameForTemporaryClasses
+ ] raise: DuplicateVariableError.
+
+ [subClass := baseClass subclass: self subClassName
+ instanceVariableNames: ''
+ classVariableNames: 'TestVar'
+ poolDictionaries: ''
+ category: self categoryNameForTemporaryClasses
+ ] on: DuplicateVariableError do:[:ex|
+ self assert: ex superclass == baseClass.
+ self assert: ex variable = 'TestVar'.
+ ex resume.
+ ].
+
+ baseClass := Object subclass: self baseClassName
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: self categoryNameForTemporaryClasses.
+
+ self should:[
+ baseClass := Object subclass: self baseClassName
+ instanceVariableNames: ''
+ classVariableNames: 'TestVar'
+ poolDictionaries: ''
+ category: self categoryNameForTemporaryClasses.
+ ] raise: DuplicateVariableError.
+
+ [baseClass := Object subclass: self baseClassName
+ instanceVariableNames: ''
+ classVariableNames: 'TestVar'
+ poolDictionaries: ''
+ category: self categoryNameForTemporaryClasses.
+ ] on: DuplicateVariableError do:[:ex|
+ self assert: ex superclass == baseClass.
+ self assert: ex variable = 'TestVar'.
+ ex resume.
+ ].!
Item was added:
+ ----- Method: ClassBuilderTest>>testDuplicateInstanceVariableError (in category 'tests - reshape') -----
+ testDuplicateInstanceVariableError
+ | didRaise |
+ "Define 'var' in a superclass."
+ baseClass := Object
+ subclass: self baseClassName
+ instanceVariableNames: 'var'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: self categoryNameForTemporaryClasses.
+ "Ensure trying to define a subclass with same var errors."
+ didRaise := false.
+ [baseClass subclass: self subClassName
+ instanceVariableNames: 'var'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: self categoryNameForTemporaryClasses ]
+ on: DuplicateVariableError do:
+ [ : err |
+ didRaise := true.
+ self assert: err superclass == baseClass.
+ self assert: err variable = 'var' ].
+ self assert: didRaise.
+ "Prepare for next test: Remove 'var' from superclass."
+ baseClass := Object
+ subclass: self baseClassName
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: self categoryNameForTemporaryClasses.
+ "Define a subclass without 'var'..."
+ subClass := baseClass
+ subclass: self subClassName
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: self categoryNameForTemporaryClasses.
+ "... but with a subclass of THAT, with 'var' defined."
+ subSubClass := subClass subclass: self subSubClassName
+ instanceVariableNames: 'var'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: self categoryNameForTemporaryClasses.
+ "... as well as a different base class with 'var' already defined..."
+ baseClass2 := Object
+ subclass: (self baseClassName,'2') asSymbol
+ instanceVariableNames: 'var'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: self categoryNameForTemporaryClasses.
+ "...and now try to move the middle subClass, whose subclass (a.k.a., subSubClass) defines 'var', to the new baseClass which also defines 'var'."
+ didRaise := false.
+ [baseClass2 subclass: self subClassName
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: self categoryNameForTemporaryClasses ]
+ on: DuplicateVariableError do:
+ [ : err |
+ didRaise := true.
+ self assert: err superclass == baseClass2.
+ self assert: err variable = 'var' ].
+ self assert: didRaise!
Item was added:
+ ----- Method: ClassBuilderTest>>testMoveVarFromSubToSuperclass (in category 'tests - reshape') -----
+ testMoveVarFromSubToSuperclass
+ | baseInst subInst |
+
+ baseClass := Object subclass: self baseClassName
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: self categoryNameForTemporaryClasses.
+
+ subClass := baseClass subclass: self subClassName
+ instanceVariableNames: 'var'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: self categoryNameForTemporaryClasses.
+ subClass compile: 'subGet ^var'.
+ subClass compile: 'subSet: v var := v'.
+
+ self assert:[baseClass instSize = 0].
+ self assert:[subClass instSize = 1].
+
+ baseInst := baseClass new.
+ subInst := subClass new.
+ subInst instVarAt: 1 put: 123.
+
+ self assert: (subInst instVarAt: 1) = 123.
+ self assert: (subInst subGet) = 123.
+
+ [baseClass := Object subclass: self baseClassName
+ instanceVariableNames: 'var'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: self categoryNameForTemporaryClasses.
+ ] on: DuplicateVariableError do:[:ex| ex resume].
+ baseClass compile: 'superGet ^var'.
+ baseClass compile: 'superSet: v var := v'.
+
+ self assert:[baseClass instSize = 1].
+ self assert:[subClass instSize = 2].
+
+ "the assumption here is that an existing value is propagated up"
+ self assert: (baseInst instVarAt: 1) = nil.
+ self assert: (subInst instVarAt: 1) = 123.
+ self assert: (subInst instVarAt: 2) = 123.
+
+ "the assumption below is that the subclass binds to the local scope not
+ the outer one, which is in line with common name space approaches."
+ subInst superSet: 666.
+ subInst subSet: 321.
+
+ self assert: (subInst instVarAt: 1) = 666.
+ self assert: (subInst instVarAt: 2) = 321.
+ self assert: (subInst superGet) = 666.
+ self assert: (subInst subGet) = 321.
+
+ subClass := baseClass subclass: self subClassName
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: self categoryNameForTemporaryClasses.
+
+ self assert:[baseClass instSize = 1].
+ self assert:[subClass instSize = 1].
+
+ "the assumption here is that the current (subclass) value is propagated up"
+ self assert: (subInst instVarAt: 1) = 321.
+ self assert: (subInst subGet) = 321.
+ !
Item was added:
+ ----- Method: ClassBuilderTest>>testMoveVarFromSuperToSubclass (in category 'tests - reshape') -----
+ testMoveVarFromSuperToSubclass
+ | baseInst subInst |
+ baseClass := Object subclass: self baseClassName
+ instanceVariableNames: 'var'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: self categoryNameForTemporaryClasses.
+ baseClass compile: 'superGet ^var'.
+ baseClass compile: 'superSet: v var := v'.
+
+ subClass := baseClass subclass: self subClassName
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: self categoryNameForTemporaryClasses.
+ subClass compile: 'subGet ^var'.
+ subClass compile: 'subSet: v var := v'.
+
+ self assert:[baseClass instSize = 1].
+ self assert:[subClass instSize = 1].
+
+ baseInst := baseClass new.
+ subInst := subClass new.
+ baseInst instVarAt: 1 put: 42.
+ subInst instVarAt: 1 put: 123.
+
+ self assert: (baseInst instVarAt: 1) = 42.
+ self assert: (subInst instVarAt: 1) = 123.
+ self assert: (subInst subGet) = 123.
+
+ [subClass := baseClass subclass: self subClassName
+ instanceVariableNames: 'var'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: self categoryNameForTemporaryClasses
+ ] on: DuplicateVariableError do:[:ex| ex resume].
+
+ self assert:[baseClass instSize = 1].
+ self assert:[subClass instSize = 2].
+
+ self assert: (baseInst instVarAt: 1) = 42.
+
+ "the assumption below is that for duplicate variables the values get duplicated too.
+ this isn't strictly necessary; what we really need is that the old var doesn't get
+ nuked but it has some advantages when moving vars up the hierarchy"
+ self assert: (subInst instVarAt: 1) = 123.
+ self assert: (subInst instVarAt: 2) = 123.
+ self assert: (subInst superGet) = 123.
+ self assert: (subInst subGet) = 123.
+
+ "the assumption below is that the subclass binds to the local scope not
+ the outer one, which is in line with common name space approaches."
+ subInst superSet: 666.
+ subInst subSet: 321.
+
+ self assert: (subInst instVarAt: 1) = 666.
+ self assert: (subInst instVarAt: 2) = 321.
+ self assert: (subInst superGet) = 666.
+ self assert: (subInst subGet) = 321.
+
+ baseClass removeSelector: #superGet.
+ baseClass removeSelector: #superSet:.
+ baseClass := Object subclass: self baseClassName
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: self categoryNameForTemporaryClasses.
+
+ self assert:[baseClass instSize = 0].
+ self assert:[subClass instSize = 1].
+
+ self assert: (subInst instVarAt: 1) = 321.
+ self assert: (subInst subGet) = 321.
+ !
Item was added:
+ ----- Method: ClassBuilderTest>>testNewUniclass (in category 'tests - uniclass') -----
+ testNewUniclass
+
+ baseClass := Object subclass: self baseClassName
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: self categoryNameForTemporaryClasses.
+ "Note that you have to denote a new base class to be capable of spawning uni classes. See Object class >> #isUniClass for more information."
+ baseClass class
+ compile: ('isUniClass\ ^ self ~~ {1}' withCRs format: {self baseClassName})
+ classified: 'instance creation'.
+
+ subClass := baseClass newSubclass.
+
+ self
+ assert: subClass isUniClass;
+ assert: subClass environment ~~ baseClass environment;
+ assert: subClass category = Object categoryForUniclasses;
+ assert: (baseClass organization categoryOfElement: subClass name) isNil.
+
+ self deny: subClass isObsolete.
+ subClass removeFromSystem.
+ self assert: subClass isObsolete.!
Item was added:
+ ----- Method: ClassBuilderTest>>testSubclass (in category 'tests - format') -----
+ testSubclass
+ "Ensure that the invariants for superclass/subclass format are preserved"
+ baseClass := Object subclass: self baseClassName
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: self categoryNameForTemporaryClasses.
+ [
+ subClass := self makeNormalSubclassOf: baseClass.
+ self assert: (subClass isPointers).
+ self deny: (subClass isVariable).
+ self deny: (subClass isWeak).
+ self deny: (subClass isBytes).
+ subClass removeFromSystem.
+
+ "pointer classes"
+ subClass := self makeIVarsSubclassOf: baseClass.
+ self assert: (subClass isPointers).
+ self deny: (subClass isVariable).
+ self deny: (subClass isWeak).
+ self deny: (subClass isBytes).
+ subClass removeFromSystem.
+
+ subClass := self makeVariableSubclassOf: baseClass.
+ self assert: (subClass isPointers).
+ self assert:(subClass isVariable).
+ self deny: (subClass isWeak).
+ self deny: (subClass isBytes).
+ subClass removeFromSystem.
+
+ subClass := self makeWeakSubclassOf: baseClass.
+ self assert: (subClass isPointers).
+ self assert:(subClass isVariable).
+ self assert:(subClass isWeak).
+ self deny: (subClass isBytes).
+ subClass removeFromSystem.
+
+ "bit classes"
+ subClass := self makeByteVariableSubclassOf: baseClass.
+ self deny: (subClass isPointers).
+ self assert: (subClass isVariable).
+ self deny: (subClass isWeak).
+ self assert: (subClass isBytes).
+ subClass removeFromSystem.
+
+ subClass := self makeWordVariableSubclassOf: baseClass.
+ self deny: (subClass isPointers).
+ self assert: (subClass isVariable).
+ self deny: (subClass isWeak).
+ self deny: (subClass isBytes).
+ subClass removeFromSystem.
+ ] ensure:[self cleanup].!
Item was added:
+ ----- Method: ClassBuilderTest>>testSubclassWithInstanceVariables (in category 'tests - format') -----
+ testSubclassWithInstanceVariables
+ "Ensure that the invariants for superclass/subclass format are preserved"
+ baseClass := Object subclass: self baseClassName
+ instanceVariableNames: 'var1 var2'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: self categoryNameForTemporaryClasses.
+ [
+ subClass := self makeNormalSubclassOf: baseClass.
+ self assert: (subClass isPointers).
+ self deny: (subClass isVariable).
+ self deny: (subClass isWeak).
+ self deny: (subClass isBytes).
+ subClass removeFromSystem.
+
+ "pointer classes"
+ subClass := self makeIVarsSubclassOf: baseClass.
+ self assert: (subClass isPointers).
+ self deny: (subClass isVariable).
+ self deny: (subClass isWeak).
+ self deny: (subClass isBytes).
+ subClass removeFromSystem.
+
+ subClass := self makeVariableSubclassOf: baseClass.
+ self assert: (subClass isPointers).
+ self assert: (subClass isVariable).
+ self deny: (subClass isWeak).
+ self deny: (subClass isBytes).
+ subClass removeFromSystem.
+
+ subClass := self makeWeakSubclassOf: baseClass.
+ self assert: (subClass isPointers).
+ self assert: (subClass isVariable).
+ self assert: (subClass isWeak).
+ self deny: (subClass isBytes).
+ subClass removeFromSystem.
+
+ "bit classes"
+ self should:[self makeByteVariableSubclassOf: baseClass] raise: Error.
+ self should:[self makeWordVariableSubclassOf: baseClass] raise: Error.
+ ] ensure:[self cleanup].!
Item was added:
+ ----- Method: ClassBuilderTest>>testVariableSubclass (in category 'tests - format') -----
+ testVariableSubclass
+ "Ensure that the invariants for superclass/subclass format are preserved"
+ baseClass := Object variableSubclass: self baseClassName
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: self categoryNameForTemporaryClasses.
+ [
+ "pointer classes"
+ subClass := self makeNormalSubclassOf: baseClass.
+ self assert: (subClass isPointers).
+ self assert: (subClass isVariable).
+ self deny: (subClass isWeak).
+ self deny: (subClass isBytes).
+ subClass removeFromSystem.
+
+ subClass := self makeIVarsSubclassOf: baseClass.
+ self assert: (subClass isPointers).
+ self assert: (subClass isVariable).
+ self deny: (subClass isWeak).
+ self deny: (subClass isBytes).
+ subClass removeFromSystem.
+
+ subClass := self makeVariableSubclassOf: baseClass.
+ self assert: (subClass isPointers).
+ self assert: (subClass isVariable).
+ self deny: (subClass isWeak).
+ self deny: (subClass isBytes).
+ subClass removeFromSystem.
+
+ subClass := self makeWeakSubclassOf: baseClass.
+ self assert: (subClass isPointers).
+ self assert: (subClass isVariable).
+ self assert: (subClass isWeak).
+ self deny: (subClass isBytes).
+ subClass removeFromSystem.
+
+ "bit classes"
+ self should:[self makeByteVariableSubclassOf: baseClass] raise: Error.
+ self should:[self makeWordVariableSubclassOf: baseClass] raise: Error.
+ ] ensure:[self cleanup].!
Item was added:
+ ----- Method: ClassBuilderTest>>testWeakSubclass (in category 'tests - format') -----
+ testWeakSubclass
+ "Ensure that the invariants for superclass/subclass format are preserved"
+ baseClass := Object weakSubclass: self baseClassName
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: self categoryNameForTemporaryClasses.
+ [
+ "pointer classes"
+ subClass := self makeNormalSubclassOf: baseClass.
+ self assert: (subClass isPointers).
+ self assert: (subClass isVariable).
+ self assert: (subClass isWeak).
+ self deny: (subClass isBytes).
+ subClass removeFromSystem.
+
+ subClass := self makeIVarsSubclassOf: baseClass.
+ self assert: (subClass isPointers).
+ self assert: (subClass isVariable).
+ self assert: (subClass isWeak).
+ self deny: (subClass isBytes).
+ subClass removeFromSystem.
+
+ subClass := self makeVariableSubclassOf: baseClass.
+ self assert: (subClass isPointers).
+ self assert: (subClass isVariable).
+ self deny: (subClass isWeak).
+ self deny: (subClass isBytes).
+ subClass removeFromSystem.
+
+ subClass := self makeWeakSubclassOf: baseClass.
+ self assert: (subClass isPointers).
+ self assert: (subClass isVariable).
+ self assert: (subClass isWeak).
+ self deny: (subClass isBytes).
+ subClass removeFromSystem.
+
+ "bit classes"
+ self should:[self makeByteVariableSubclassOf: baseClass] raise: Error.
+ self should:[self makeWordVariableSubclassOf: baseClass] raise: Error.
+ ] ensure:[self cleanup].!
Item was added:
+ ----- Method: ClassBuilderTest>>testWordVariableSubclass (in category 'tests - format') -----
+ testWordVariableSubclass
+ "Ensure that the invariants for superclass/subclass format are preserved"
+ baseClass := Object variableWordSubclass: self baseClassName
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: self categoryNameForTemporaryClasses.
+ [
+ subClass := self makeNormalSubclassOf: baseClass.
+ self deny: (subClass isPointers).
+ self assert: (subClass isVariable).
+ self assert: (subClass isWords).
+ self deny: (subClass isWeak).
+ self deny: (subClass isBytes).
+ self deny: (subClass isShorts).
+ self deny: (subClass isLongs).
+ subClass removeFromSystem.
+
+ "pointer classes"
+ self should:[self makeIVarsSubclassOf: baseClass] raise: Error.
+ self should:[self makeVariableSubclassOf: baseClass] raise: Error.
+ self should:[self makeWeakSubclassOf: baseClass] raise: Error.
+
+ "bit classes"
+ self should:[self makeByteVariableSubclassOf: baseClass] raise: Error.
+ self should:[self makeDoubleByteVariableSubclassOf: baseClass] raise: Error.
+ self should:[self makeDoubleWordVariableSubclassOf: baseClass] raise: Error.
+ subClass := self makeWordVariableSubclassOf: baseClass.
+ self deny: (subClass isPointers).
+ self assert: (subClass isVariable).
+ self assert: (subClass isWords).
+ self deny: (subClass isWeak).
+ self deny: (subClass isBytes).
+ self deny: (subClass isShorts).
+ self deny: (subClass isLongs).
+ subClass removeFromSystem.
+ ] ensure:[self cleanup].!
Item was added:
+ ClassTestCase subclass: #ClassDescriptionTest
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'KernelTests-Classes'!
+
+ !ClassDescriptionTest commentStamp: '<historical>' prior: 0!
+ This is the unit test for the class ClassDescription. Unit tests are a good way to exercise the functionality of your system in a repeatable and automatic manner. They are therefore recommended if you plan to release anything. For more information, see:
+ - http://www.c2.com/cgi/wiki?UnitTest
+ - http://minnow.cc.gatech.edu/squeak/1547
+ - the sunit class category!
Item was added:
+ ----- Method: ClassDescriptionTest>>testOrganization (in category 'tests') -----
+ testOrganization
+
+ | aClassOrganizer |
+ aClassOrganizer := ClassDescription organization.
+ self assert: (aClassOrganizer isKindOf: ClassOrganizer).!
Item was added:
+ Object subclass: #ClassForBehaviorTest
+ instanceVariableNames: 'iv1 iv2'
+ classVariableNames: 'CV1 CV2'
+ poolDictionaries: ''
+ category: 'KernelTests-Classes'!
+ ClassForBehaviorTest class
+ instanceVariableNames: 'civ1'!
+ ClassForBehaviorTest class
+ instanceVariableNames: 'civ1'!
Item was added:
+ ----- Method: ClassForBehaviorTest class>>civ1 (in category 'accessing') -----
+ civ1
+ ^civ1 ifNil: [civ1 := false]!
Item was added:
+ ----- Method: ClassForBehaviorTest class>>initialize (in category 'class initialization') -----
+ initialize
+ CV1 := 1.
+ CV2 := 2!
Item was added:
+ ----- Method: ClassForBehaviorTest>>initialize (in category 'accessing') -----
+ initialize
+ iv1 := CV1 ifNil: [CV1 := 1]!
Item was added:
+ ----- Method: ClassForBehaviorTest>>iv1 (in category 'accessing') -----
+ iv1
+ ^iv1!
Item was added:
+ ----- Method: ClassForBehaviorTest>>iv1: (in category 'accessing') -----
+ iv1: anyObject
+ iv1 := anyObject!
Item was added:
+ ----- Method: ClassForBehaviorTest>>iv2 (in category 'accessing') -----
+ iv2
+ ^iv2!
Item was added:
+ ----- Method: ClassForBehaviorTest>>iv2: (in category 'accessing') -----
+ iv2: anyObject
+ iv2 := anyObject!
Item was added:
+ ----- Method: ClassForBehaviorTest>>reset (in category 'accessing') -----
+ reset
+ iv1 := iv2 := nil!
Item was added:
+ TestCase subclass: #ClassTest
+ instanceVariableNames: 'className renamedName'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'KernelTests-Classes'!
Item was added:
+ ----- Method: ClassTest>>categoryNameForTemporaryClasses (in category 'setup') -----
+ categoryNameForTemporaryClasses
+ "Answer the category where to classify temporarily created classes"
+
+ ^'Dummy-Tests-Class'!
Item was added:
+ ----- Method: ClassTest>>deleteClass (in category 'setup') -----
+ deleteClass
+ | cl |
+ cl := Smalltalk at: className ifAbsent: [^self].
+ cl removeFromChanges; removeFromSystemUnlogged
+ !
Item was added:
+ ----- Method: ClassTest>>deleteRenamedClass (in category 'setup') -----
+ deleteRenamedClass
+ | cl |
+ cl := Smalltalk at: renamedName ifAbsent: [^self].
+ cl removeFromChanges; removeFromSystemUnlogged
+ !
Item was added:
+ ----- Method: ClassTest>>performTest (in category 'private') -----
+ performTest
+
+ Utilities
+ useAuthorInitials: self className
+ during: [ super performTest ]!
Item was added:
+ ----- Method: ClassTest>>setUp (in category 'setup') -----
+ setUp
+ className := #TUTU.
+ renamedName := #RenamedTUTU.
+ self deleteClass.
+ self deleteRenamedClass.
+ Object subclass: className
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: self categoryNameForTemporaryClasses.
+ #('foo' 'bar self foo' 'baz self bar') do:
+ [:s| (Smalltalk at: className) compileSilently: s]!
Item was added:
+ ----- Method: ClassTest>>tearDown (in category 'setup') -----
+ tearDown
+ self deleteClass.
+ self deleteRenamedClass.
+ (Smalltalk organization listAtCategoryNamed: self categoryNameForTemporaryClasses) isEmpty
+ ifTrue: [Smalltalk organization removeCategory: self categoryNameForTemporaryClasses]!
Item was added:
+ ----- Method: ClassTest>>testAddInstVarName (in category 'tests') -----
+ testAddInstVarName
+ "self run: #testAddInstVarName"
+
+
+ | tutu |
+ tutu := Smalltalk at: className.
+ tutu addInstVarName: 'x'.
+ self assert: (tutu instVarNames = #('x')).
+ tutu addInstVarName: 'y'.
+ self assert: (tutu instVarNames = #('x' 'y')).
+ tutu selectorsAndMethodsDo:
+ [:s :m|
+ self assert: m methodClassAssociation == (Smalltalk bindingOf: className)]
+
+ !
Item was added:
+ ----- Method: ClassTest>>testChangeClassOf (in category 'tests') -----
+ testChangeClassOf
+ "Exercise primitiveChangeClass (primitive 115) for a common use case. This should pass
+ for any Squeak image format (but failed for image format 68002 prior to VM fix)"
+
+ self shouldnt: [Exception new primitiveChangeClassTo: Error new] raise: Error!
Item was added:
+ ----- Method: ClassTest>>testCompileAll (in category 'tests - compiling') -----
+ testCompileAll
+ "We expect this to succeed."
+ ClassTest compileAll.!
Item was added:
+ ----- Method: ClassTest>>testRenaming (in category 'tests') -----
+ testRenaming
+ "self debug: #testRenaming"
+ "self run: #testRenaming"
+
+ | oldName newMetaclassName class |
+ oldName := className.
+ newMetaclassName := (renamedName, #' class') asSymbol.
+ class := Smalltalk at: oldName.
+ class class compile: 'dummyMeth'.
+ class rename: renamedName.
+ self assert: class name = renamedName.
+ self assert: (ChangeSet current changedClassNames includes: renamedName).
+ self assert: (ChangeSet current changedClassNames includes: newMetaclassName).
+ !
Item was added:
+ TestCase subclass: #ClassVarScopeTest
+ instanceVariableNames: 'parent child grandchild foo environment'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'KernelTests-Classes'!
+
+ !ClassVarScopeTest commentStamp: 'nice 7/28/2013 16:05' prior: 0!
+ Test that a class variable defined in a superclass takes precedence over a global variable of same name.
+
+ In #setUp:
+
+ Three classes are defined: parent, child and grandchild.
+ A class variable is defined in child.
+ A global with the same name is defined in Smalltalk globals.
+ Methods are defined in all classes getting and setting this class or global variable.
+
+ Test whether methods referencing the variable with that name
+ access the correct variable.!
Item was added:
+ ----- Method: ClassVarScopeTest>>createClass:superClass:classVariableNames: (in category 'private') -----
+ createClass: aSymbol superClass: superClass classVariableNames: aString
+
+ ^SystemChangeNotifier uniqueInstance doSilently: [
+ ClassBuilder new
+ name: aSymbol
+ inEnvironment: environment
+ subclassOf: superClass
+ type: #normal
+ instanceVariableNames: ''
+ classVariableNames: aString
+ poolDictionaries: ''
+ category: 'Test' ]!
Item was added:
+ ----- Method: ClassVarScopeTest>>performTest (in category 'private') -----
+ performTest
+
+ Utilities
+ useAuthorInitials: self className
+ during: [ super performTest ]!
Item was added:
+ ----- Method: ClassVarScopeTest>>setUp (in category 'running') -----
+ setUp
+
+ environment := Environment withName: 'test'.
+ environment importSelf.
+ parent := self createClass: #ClassVarScopeParent superClass: nil classVariableNames: ''.
+ child := self createClass: #ClassVarScopeChild superClass: parent classVariableNames: 'ClassVarScopeFoo'.
+ grandchild := self createClass: #ClassVarScopeGrandchild superClass: child classVariableNames: ''.
+ foo := environment at: #ClassVarScopeFoo put: Object basicNew.
+
+ parent compileSilently: self sourceOfParentGetFoo.
+ parent compileSilently: self sourceOfParentSetFoo.
+
+ parent class compileSilently: self sourceOfParentGetFoo.
+ parent class compileSilently: self sourceOfParentSetFoo.
+
+ child compileSilently: self sourceOfChildGetFoo.
+ child compileSilently: self sourceOfChildSetFoo.
+
+ child class compileSilently: self sourceOfChildGetFoo.
+ child class compileSilently: self sourceOfChildSetFoo.
+
+ grandchild compileSilently: self sourceOfGrandchildGetFoo.
+ grandchild compileSilently: self sourceOfGrandchildSetFoo.
+
+ grandchild class compileSilently: self sourceOfGrandchildGetFoo.
+ grandchild class compileSilently: self sourceOfGrandchildSetFoo!
Item was added:
+ ----- Method: ClassVarScopeTest>>sourceOfChildGetFoo (in category 'query') -----
+ sourceOfChildGetFoo
+ ^'childGetFoo
+ ^ClassVarScopeFoo'!
Item was added:
+ ----- Method: ClassVarScopeTest>>sourceOfChildSetFoo (in category 'query') -----
+ sourceOfChildSetFoo
+ ^'childSetFoo: anObject
+ ClassVarScopeFoo := anObject'!
Item was added:
+ ----- Method: ClassVarScopeTest>>sourceOfGrandchildGetFoo (in category 'query') -----
+ sourceOfGrandchildGetFoo
+ ^'grandchildGetFoo
+ ^ClassVarScopeFoo'!
Item was added:
+ ----- Method: ClassVarScopeTest>>sourceOfGrandchildSetFoo (in category 'query') -----
+ sourceOfGrandchildSetFoo
+ ^'grandchildSetFoo: anObject
+ ClassVarScopeFoo := anObject'!
Item was added:
+ ----- Method: ClassVarScopeTest>>sourceOfParentGetFoo (in category 'query') -----
+ sourceOfParentGetFoo
+ ^'parentGetFoo
+ ^ClassVarScopeFoo'!
Item was added:
+ ----- Method: ClassVarScopeTest>>sourceOfParentSetFoo (in category 'query') -----
+ sourceOfParentSetFoo
+ ^'parentSetFoo: anObject
+ ClassVarScopeFoo := anObject'!
Item was added:
+ ----- Method: ClassVarScopeTest>>tearDown (in category 'running') -----
+ tearDown
+
+ | classes |
+ classes := { grandchild. child. parent }.
+ grandchild := child := parent := nil.
+ classes do: [ :each |
+ each
+ removeFromChanges;
+ removeFromSystemUnlogged ].
+ environment removeKey: #ClassVarScopeFoo ifAbsent: []!
Item was added:
+ ----- Method: ClassVarScopeTest>>testDefinedClassMethodInChild (in category 'tests') -----
+ testDefinedClassMethodInChild
+ self assert: child childGetFoo == nil.
+ child childSetFoo: #bar.
+ self assert: child childGetFoo == #bar!
Item was added:
+ ----- Method: ClassVarScopeTest>>testDefinedClassMethodInGrandchild (in category 'tests') -----
+ testDefinedClassMethodInGrandchild
+ self assert: grandchild grandchildGetFoo == nil.
+ grandchild grandchildSetFoo: #bar.
+ self assert: grandchild grandchildGetFoo == #bar!
Item was added:
+ ----- Method: ClassVarScopeTest>>testDefinedClassMethodInParent (in category 'tests') -----
+ testDefinedClassMethodInParent
+ self assert: parent parentGetFoo == foo.
+ parent parentSetFoo: #bar.
+ self assert: parent parentGetFoo = #bar!
Item was added:
+ ----- Method: ClassVarScopeTest>>testDefinedInstanceMethodInChild (in category 'tests') -----
+ testDefinedInstanceMethodInChild
+ self assert: child basicNew childGetFoo == nil.
+ child basicNew childSetFoo: #bar.
+ self assert: child basicNew childGetFoo == #bar!
Item was added:
+ ----- Method: ClassVarScopeTest>>testDefinedInstanceMethodInGrandchild (in category 'tests') -----
+ testDefinedInstanceMethodInGrandchild
+ self assert: grandchild basicNew grandchildGetFoo == nil.
+ grandchild basicNew grandchildSetFoo: #bar.
+ self assert: grandchild basicNew grandchildGetFoo == #bar!
Item was added:
+ ----- Method: ClassVarScopeTest>>testDefinedInstanceMethodInParent (in category 'tests') -----
+ testDefinedInstanceMethodInParent
+ self assert: parent basicNew parentGetFoo == foo.
+ parent basicNew parentSetFoo: #bar.
+ self assert: parent basicNew parentGetFoo == #bar!
Item was added:
+ ----- Method: ClassVarScopeTest>>testInheritedClassMethodInChild (in category 'tests') -----
+ testInheritedClassMethodInChild
+ self assert: child parentGetFoo == foo.
+ child parentSetFoo: #bar.
+ self assert: child parentGetFoo == #bar!
Item was added:
+ ----- Method: ClassVarScopeTest>>testInheritedClassMethodInGrandchild (in category 'tests') -----
+ testInheritedClassMethodInGrandchild
+ self assert: grandchild childGetFoo == nil.
+ grandchild childSetFoo: #bar.
+ self assert: grandchild childGetFoo == #bar!
Item was added:
+ ----- Method: ClassVarScopeTest>>testInheritedInstanceMethodInChild (in category 'tests') -----
+ testInheritedInstanceMethodInChild
+ self assert: child basicNew parentGetFoo == foo.
+ child basicNew parentSetFoo: #bar.
+ self assert: child basicNew parentGetFoo == #bar!
Item was added:
+ ----- Method: ClassVarScopeTest>>testInheritedInstanceMethodInGrandchild (in category 'tests') -----
+ testInheritedInstanceMethodInGrandchild
+ self assert: grandchild basicNew childGetFoo == nil.
+ grandchild basicNew childSetFoo: #bar.
+ self assert: grandchild basicNew childGetFoo == #bar!
Item was added:
+ LongTestCase subclass: #CompiledMethodComparisonTest
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'KernelTests-Methods'!
Item was added:
+ ----- Method: CompiledMethodComparisonTest>>testHash (in category 'tests') -----
+ testHash
+ <timeout: 120>
+
+ | ai |
+ ai := CompiledMethod allInstances.
+ "We assume here that if two CompiledMethods are equal then they have the same size and header."
+ (ai groupBy: [ :method | { method size. method header } ]) values
+ replace: [ :each | each asArray ];
+ do: [ :methods |
+ 1 to: methods size do: [ :i |
+ | firstMethod |
+ firstMethod := methods at: i.
+ i to: methods size do: [ :j |
+ | secondMethod |
+ secondMethod := methods at: j.
+ firstMethod = secondMethod ifTrue: [
+ self assert: firstMethod hash equals: secondMethod hash ] ] ] ]
+ displayingProgress: 'Testing hashes'.
+ self assert: (ai collect: [ :cm | cm hash ] as: Set) size * 2 >= ai asSet size!
Item was added:
+ ClassTestCase subclass: #CompiledMethodTest
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'KernelTests-Methods'!
+
+ !CompiledMethodTest commentStamp: '<historical>' prior: 0!
+ This is the unit test for the class CompiledMethod. Unit tests are a good way to exercise the functionality of your system in a repeatable and automatic manner. They are therefore recommended if you plan to release anything. For more information, see:
+ - http://www.c2.com/cgi/wiki?UnitTest
+ - http://minnow.cc.gatech.edu/squeak/1547
+ - the sunit class category!
Item was added:
+ ----- Method: CompiledMethodTest>>a1:a2:a3:a4:a5:a6:a7:a8:a9:a10:a11:a12:a13:a14:a15: (in category 'tests - performing') -----
+ a1: a1 a2: a2 a3: a3 a4: a4 a5: a5 a6: a6 a7: a7 a8: a8 a9: a9 a10: a10 a11: a11 a12: a12 a13: a13 a14: a14 a15: a15
+ "I'm a method with the maximum size of arguments that can be executed via normal send but crash on perform :)"
+
+ ^ a1 + a2 - a2!
Item was added:
+ ----- Method: CompiledMethodTest>>expectedFailures (in category 'failures') -----
+ expectedFailures
+
+ Smalltalk isRunningCog ifTrue: [ ^super expectedFailures ].
+ ^#(
+ "Not supported by the interpreter VM. See method comments for details"
+ testPerformInSuperclassCanExecutelongMethodWithTemps
+ )!
Item was added:
+ ----- Method: CompiledMethodTest>>performTest (in category 'private') -----
+ performTest
+
+ Utilities
+ useAuthorInitials: self className
+ during: [ super performTest ]!
Item was added:
+ ----- Method: CompiledMethodTest>>returnPlusOne: (in category 'examples') -----
+ returnPlusOne: anInteger
+ ^anInteger + 1. !
Item was added:
+ ----- Method: CompiledMethodTest>>returnTrue (in category 'examples') -----
+ returnTrue
+ ^true !
Item was added:
+ ----- Method: CompiledMethodTest>>testClosureCompiled (in category 'tests - closures') -----
+ testClosureCompiled
+ self
+ assert: (self class >> #withClosure) isClosureCompiled;
+ assert: (self class >> #withClosureNoNLR) isClosureCompiled!
Item was added:
+ ----- Method: CompiledMethodTest>>testClosureNLRs (in category 'tests - closures') -----
+ testClosureNLRs
+ self
+ assert:
+ ((self class >> #withClosure) embeddedBlockClosures at: 1)
+ hasMethodReturn;
+ assert:
+ ((self class >> #withClosureNoNLR) embeddedBlockClosures at: 1)
+ hasMethodReturn not!
Item was added:
+ ----- Method: CompiledMethodTest>>testClosureSize (in category 'tests - closures') -----
+ testClosureSize
+ | compiledMethod expectedSize |
+ compiledMethod := (self class >> #withClosure).
+ expectedSize := compiledMethod bytecodeSetName
+ caseOf: {
+ ['SistaV1'] -> [3].
+ ['V3PlusClosures'] -> [2]}.
+ self assert: expectedSize equals: (compiledMethod embeddedBlockClosures at: 1) size.
+ compiledMethod := (self class >> #withClosureNoNLR).
+ expectedSize := compiledMethod bytecodeSetName
+ caseOf: {
+ ['SistaV1'] -> [3].
+ ['V3PlusClosures'] -> [2]}.
+ self assert: expectedSize equals: (compiledMethod embeddedBlockClosures at: 1) size.!
Item was added:
+ ----- Method: CompiledMethodTest>>testCopy (in category 'tests - copying') -----
+ testCopy
+ <pragma: #pragma>
+ | method copy |
+ method := thisContext method.
+ self assert: method pragmas notEmpty.
+ copy := method copy.
+ self assert: (method equivalentTo: copy).
+ self assert: method = copy.
+ self assert: method ~~ copy.
+ method pragmas do:
+ [:p|
+ self assert: p method == method].
+ copy pragmas do:
+ [:p|
+ self assert: p method == copy]!
Item was added:
+ ----- Method: CompiledMethodTest>>testCopyWithTrailerBytes (in category 'tests - copying') -----
+ testCopyWithTrailerBytes
+ <pragma: #pragma>
+ | method copy |
+ method := thisContext method.
+ self assert: method pragmas notEmpty.
+ copy := method copyWithTempNames: #('m' 'c').
+ self assert: (method equivalentTo: copy).
+ self deny: method = copy. "copyWithTempNames: changes the length of a method so these are no longer equal."
+ self assert: method symbolic = copy symbolic. "but their bytecode should be the same"
+ self assert: method ~~ copy.
+ method pragmas do:
+ [:p|
+ self assert: p method == method].
+ copy pragmas do:
+ [:p|
+ self assert: p method == copy]!
Item was added:
+ ----- Method: CompiledMethodTest>>testDecompile (in category 'tests - decompiling') -----
+ testDecompile
+ "self debug: #testDecompileTree"
+ | method cls stream |
+
+ Smalltalk removeClassNamed: #TUTU.
+
+ cls := Object subclass: #TUTU
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'KernelTests-Methods'.
+ cls compileSilently: 'foo ^ 10'.
+ method := cls >> #foo.
+ Smalltalk removeClassNamed: #TUTU.
+ stream := String new writeStream.
+ method decompile printOn: stream.
+ self assert: stream contents = 'foo
+ ^ 10'
+
+
+ !
Item was added:
+ ----- Method: CompiledMethodTest>>testHasClosure (in category 'tests - closures') -----
+ testHasClosure
+ self
+ assert: (self class >> #withClosure) containsBlockClosures;
+ assert: (self class >> #withClosureNoNLR) containsBlockClosures;
+ assert: (self class >> #withoutClosure) containsBlockClosures not!
Item was added:
+ ----- Method: CompiledMethodTest>>testIsInstalled (in category 'tests - testing') -----
+ testIsInstalled
+ | method cls |
+
+ method := (self class)>>#returnTrue.
+ self assert: method isInstalled.
+
+ "now make an orphaned method by just deleting the class."
+
+ Smalltalk removeClassNamed: #TUTU.
+
+ cls := Object subclass: #TUTU
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'KernelTests-Methods'.
+ cls compile: 'foo ^ 10'.
+ method := cls >> #foo.
+ Smalltalk removeClassNamed: #TUTU.
+
+ self deny: method isInstalled. !
Item was added:
+ ----- Method: CompiledMethodTest>>testIsQuick (in category 'tests - testing') -----
+ testIsQuick
+ | method |
+
+ method := self class compiledMethodAt: #returnTrue.
+ self assert: (method isQuick).
+
+ method := self class compiledMethodAt: #returnPlusOne:.
+ self deny: (method isQuick).
+
+ !
Item was added:
+ ----- Method: CompiledMethodTest>>testMethodClass (in category 'tests - accessing') -----
+ testMethodClass
+ | method cls binding |
+ method := self class >> #returnTrue.
+ self assert: #returnTrue equals: method selector.
+ "now make an orphaned method by just deleting the class.
+ old: #unknown
+ pre-environment semantics: return Obsolete class
+ environment semantics: return binding's value, which will be nil"
+ (Smalltalk classNamed: #TUTU) ifNotNil:
+ [Smalltalk removeClassNamed: #TUTU].
+ cls := Object
+ subclass: #TUTU
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'KernelTests-Methods'.
+ cls compile: 'foo ^ 10'.
+ method := cls >> #foo.
+ binding := cls binding.
+ self assert: binding value equals: (Smalltalk classNamed: #TUTU) description: 'binding before class removal'.
+ self assert: (Smalltalk classNamed: #TUTU) equals: method methodClass description: 'methodClass before class removal'.
+ Smalltalk removeClassNamed: #TUTU.
+ self assert: binding value equals: method methodClass description: 'methodClass after class removal'.!
Item was added:
+ ----- Method: CompiledMethodTest>>testNew (in category 'tests') -----
+ testNew
+
+ self shouldRaiseError: [self classToBeTested new].!
Item was added:
+ ----- Method: CompiledMethodTest>>testPerformCanExecutelongMethodWithTemps (in category 'tests - performing') -----
+ testPerformCanExecutelongMethodWithTemps
+ "self debug: #testPerformCanExecutelongMethodWithTemps"
+ "the perform: primitive reuses the context of the method calling it. The primitive adds performed selector arguments to the context variables list. So this means that you can execute some methods but not performed them if the calling methods defined too many temps "
+
+ | temp1 temp2 temp3 |
+ temp1 := 33.
+ temp2 := 666.
+ temp3 := 42.
+ self assert: (self perform: #a1:a2:a3:a4:a5:a6:a7:a8:a9:a10:a11:a12:a13:a14:a15: withArguments: #(1 2 3 4 5 6 7 8 9 10 11 12 13 14 15)) = 1.
+ self assert: (self class>>#testPerformCanExecutelongMethodWithTemps) frameSize = CompiledMethod smallFrameSize.
+ self assert: (self class>>#a1:a2:a3:a4:a5:a6:a7:a8:a9:a10:a11:a12:a13:a14:a15:) frameSize = CompiledMethod fullFrameSize.!
Item was added:
+ ----- Method: CompiledMethodTest>>testPerformInSuperclassCanExecutelongMethodWithTemps (in category 'tests - performing') -----
+ testPerformInSuperclassCanExecutelongMethodWithTemps
+ "This test documents a limitation of the standard Squeak VM that has
+ been addressed in the Cog family of VMs. The test will pass on Cog, but
+ is expected to fail on an interpreter VM. The test fails on an interpreter VM
+ because the perform: primitive reuses the context of the method calling it.
+ The primitive adds performed selector arguments to the context variables
+ list. So this means that you can execute some methods but not performed
+ them if the calling methods defined too many temps."
+
+ "self debug: #testPerformInSuperclassCanExecutelongMethodWithTemps"
+
+ | temp1 temp2 temp3 |
+ temp1 := 33.
+ temp2 := 666.
+ temp3 := 42.
+ self assert: (self perform: #a1:a2:a3:a4:a5:a6:a7:a8:a9:a10:a11:a12:a13:a14:a15: withArguments: #(1 2 3 4 5 6 7 8 9 10 11 12 13 14 15) inSuperclass: self class) = 1!
Item was added:
+ ----- Method: CompiledMethodTest>>testSearchForClass (in category 'tests - accessing') -----
+ testSearchForClass
+ | method cls |
+
+ method := (self class)>>#returnTrue.
+ self assert: (method searchForClass = self class).
+
+ "now make an orphaned method. we want to get nil as the class"
+
+ Smalltalk removeClassNamed: #TUTU.
+
+ cls := Object subclass: #TUTU
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'KernelTests-Methods'.
+ cls compile: 'foo ^ 10'.
+ method := cls >> #foo.
+ Smalltalk removeClassNamed: #TUTU.
+
+ self assert: method searchForClass = nil.
+ !
Item was added:
+ ----- Method: CompiledMethodTest>>testSearchForSelector (in category 'tests - accessing') -----
+ testSearchForSelector
+ | method cls |
+
+ method := (self class)>>#returnTrue.
+ self assert: (method searchForSelector = #returnTrue).
+
+ "now make an orphaned method. we want to get nil as the selector"
+
+ Smalltalk removeClassNamed: #TUTU.
+
+ cls := Object subclass: #TUTU
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'KernelTests-Methods'.
+ cls compile: 'foo ^ 10'.
+ method := cls >> #foo.
+ Smalltalk removeClassNamed: #TUTU.
+
+ self assert: method searchForSelector = nil.
+ !
Item was added:
+ ----- Method: CompiledMethodTest>>testSelector (in category 'tests - accessing') -----
+ testSelector
+ | method cls |
+
+ method := (self class)>>#returnTrue.
+ self assert: (method selector = #returnTrue).
+
+ "now make an orphaned method. new semantics: return corrent name"
+
+ Smalltalk removeClassNamed: #TUTU.
+
+ cls := Object subclass: #TUTU
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'KernelTests-Methods'.
+ cls compile: 'foo ^ 10'.
+ method := cls >> #foo.
+ Smalltalk removeClassNamed: #TUTU.
+
+ self assert: method selector = #foo.
+ !
Item was added:
+ ----- Method: CompiledMethodTest>>testValueWithReceiverArguments (in category 'tests - evaluating') -----
+ testValueWithReceiverArguments
+
+ | method value |
+
+ method := self class compiledMethodAt: #returnTrue.
+
+ value := method valueWithReceiver: nil arguments: #().
+ self assert: (value = true).
+
+ method := self class compiledMethodAt: #returnPlusOne:.
+ value := method valueWithReceiver: nil arguments: #(1).
+ self assert: (value = 2). !
Item was added:
+ ----- Method: CompiledMethodTest>>withClosure (in category 'examples') -----
+ withClosure
+ [ ^ 23 ] value!
Item was added:
+ ----- Method: CompiledMethodTest>>withClosureNoNLR (in category 'examples') -----
+ withClosureNoNLR
+ ^ [ 23 ] value!
Item was added:
+ ----- Method: CompiledMethodTest>>withoutClosure (in category 'examples') -----
+ withoutClosure
+ ^ 23 + 42!
Item was added:
+ TestCase subclass: #CompiledMethodTrailerTest
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'KernelTests-Methods'!
Item was added:
+ ----- Method: CompiledMethodTrailerTest>>testEmbeddingSourceCode (in category 'tests') -----
+ testEmbeddingSourceCode
+
+ | trailer newTrailer code |
+
+ trailer := CompiledMethodTrailer new.
+
+ code := 'foo'.
+ trailer sourceCode: code.
+ newTrailer := trailer testEncoding.
+
+ self assert: (trailer kind == #EmbeddedSourceQCompress ).
+ self assert: (newTrailer sourceCode = code).
+
+ "the last bytecode index must be at 0"
+ self assert: (newTrailer endPC = 0).
+
+ code := 'testEmbeddingSourceCode
+
+ | trailer newTrailer code |
+
+ trailer := CompiledMethodTrailer new.
+
+ trailer sourceCode: code.
+ newTrailer := trailer testEncoding.
+
+ self assert: (newTrailer sourceCode = code).'.
+
+ trailer sourceCode: code.
+ self assert: (trailer kind == #EmbeddedSourceZip ).
+ newTrailer := trailer testEncoding.
+
+ self assert: (newTrailer sourceCode = code).
+ "the last bytecode index must be at 0"
+ self assert: (newTrailer endPC = 0).
+ !
Item was added:
+ ----- Method: CompiledMethodTrailerTest>>testEmbeddingTempNames (in category 'tests') -----
+ testEmbeddingTempNames
+
+ | trailer newTrailer code |
+
+ trailer := CompiledMethodTrailer new.
+
+ code := 'foo'.
+ trailer tempNames: code.
+ newTrailer := trailer testEncoding.
+
+ self assert: (trailer kind == #TempsNamesQCompress ).
+ self assert: (newTrailer tempNames = code).
+ "the last bytecode index must be at 0"
+ self assert: (newTrailer endPC = 0).
+
+
+ code := 'testEmbeddingSourceCode
+
+ | trailer newTrailer code |
+
+ trailer := CompiledMethodTrailer new.
+
+ trailer sourceCode: code.
+ newTrailer := trailer testEncoding.
+
+ self assert: (newTrailer sourceCode = code).'.
+
+ trailer tempNames: code.
+ self assert: (trailer kind == #TempsNamesZip ).
+ newTrailer := trailer testEncoding.
+
+ self assert: (newTrailer tempNames = code).
+ "the last bytecode index must be at 0"
+ self assert: (newTrailer endPC = 0).
+ !
Item was added:
+ ----- Method: CompiledMethodTrailerTest>>testEncodingNoTrailer (in category 'tests') -----
+ testEncodingNoTrailer
+
+ | trailer |
+
+ trailer := CompiledMethodTrailer new.
+
+ "by default it should be a no-trailer"
+ self assert: (trailer kind == #NoTrailer ).
+ self assert: (trailer size = 1).
+
+ trailer := trailer testEncoding.
+
+ self assert: (trailer kind == #NoTrailer ).
+ self assert: (trailer size = 1).
+ "the last bytecode index must be at 0"
+ self assert: (trailer endPC = 0).
+ !
Item was added:
+ ----- Method: CompiledMethodTrailerTest>>testEncodingSourcePointer (in category 'tests') -----
+ testEncodingSourcePointer
+
+ | trailer |
+
+ trailer := CompiledMethodTrailer new.
+
+ CompiledMethod allInstancesDo: [:method | | ptr |
+ trailer method: method.
+ self assert: ( (ptr := method sourcePointer) == trailer sourcePointer).
+ "the last bytecode index must be at 0"
+ ptr ~= 0 ifTrue: [
+ self assert: (method endPC = trailer endPC) ].
+ ].!
Item was added:
+ ----- Method: CompiledMethodTrailerTest>>testEncodingVarLengthSourcePointer (in category 'tests') -----
+ testEncodingVarLengthSourcePointer
+
+ | trailer newTrailer |
+
+ trailer := CompiledMethodTrailer new.
+
+ trailer sourcePointer: 1.
+ newTrailer := trailer testEncoding.
+
+ self assert: (newTrailer sourcePointer = 1).
+
+ trailer sourcePointer: 16r100000000000000.
+ newTrailer := trailer testEncoding.
+ self assert: (newTrailer sourcePointer = 16r100000000000000).
+ "the last bytecode index must be at 0"
+ self assert: (newTrailer endPC = 0).
+ !
Item was added:
+ ----- Method: CompiledMethodTrailerTest>>testEncodingZeroSourcePointer (in category 'tests') -----
+ testEncodingZeroSourcePointer
+
+ | trailer |
+
+ trailer := CompiledMethodTrailer new.
+
+ self assert:
+ (trailer sourcePointer: 0) testEncoding sourcePointer = 0
+ !
Item was added:
+ ----- Method: CompiledMethodTrailerTest>>testSourceByIdentifierEncoding (in category 'tests') -----
+ testSourceByIdentifierEncoding
+
+ | trailer id |
+
+ trailer := CompiledMethodTrailer new.
+
+ id := UUID new asString.
+ trailer sourceIdentifier: id.
+
+ self assert: (trailer kind == #SourceByStringIdentifier ).
+
+ trailer := trailer testEncoding.
+
+ self assert: (trailer kind == #SourceByStringIdentifier ).
+ self assert: (trailer sourceIdentifier = id).
+ "the last bytecode index must be at 0"
+ self assert: (trailer endPC = 0).
+ !
Item was added:
+ ----- Method: CompiledMethodTrailerTest>>testSourceBySelectorEncoding (in category 'tests') -----
+ testSourceBySelectorEncoding
+
+ | trailer |
+
+ trailer := CompiledMethodTrailer new.
+
+ trailer setSourceBySelector.
+
+ self assert: (trailer kind == #SourceBySelector ).
+ self assert: (trailer size = 1).
+
+ trailer := trailer testEncoding.
+
+ self assert: (trailer kind == #SourceBySelector ).
+ self assert: (trailer size = 1).
+ "the last bytecode index must be at 0"
+ self assert: (trailer endPC = 0).
+ !
Item was added:
+ TestCase subclass: #ComplexTest
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'KernelTests-Numbers'!
Item was added:
+ ----- Method: ComplexTest>>testAbs (in category 'tests') -----
+ testAbs
+ "self run: #testAbs"
+ "self debug: #testAbs"
+
+ | c |
+ c := (6 - 6 i).
+ self assert: c abs = 72 sqrt.
+ !
Item was added:
+ ----- Method: ComplexTest>>testAdding (in category 'tests') -----
+ testAdding
+ "self run: #testAdding"
+
+ | c |
+ c := (5 - 6 i) + (-5 + 8 i). "Complex with Complex"
+ self assert: (c = (0 + 2 i)).!
Item was added:
+ ----- Method: ComplexTest>>testArCosh (in category 'tests') -----
+ testArCosh
+ | c |
+ c := (2.5 + 0 i).
+ self assert: (c arCosh real closeTo: c real arCosh).
+ self assert: (c arCosh imaginary closeTo: 0).
+ #(-0.5 -2 -3 0 0.5 2 3) do: [:real |
+ #(-0.5 -2 -3 0 0.5 2 3) do: [:imag |
+ c := real + imag i.
+ self assert: (c arCosh cosh real closeTo: c real).
+ self assert: (c arCosh cosh imaginary closeTo: c imaginary).
+ self deny: c arCosh real negative]]!
Item was added:
+ ----- Method: ComplexTest>>testArSinh (in category 'tests') -----
+ testArSinh
+ | c |
+ c := (2.5 + 0 i).
+ self assert: (c arSinh real closeTo: c real arSinh).
+ self assert: (c arSinh imaginary closeTo: 0).
+ #(-0.5 -2 -3 0 0.5 2 3) do: [:real |
+ #(-0.5 -2 -3 0 0.5 2 3) do: [:imag |
+ c := real + imag i.
+ self assert: (c arSinh sinh real closeTo: c real).
+ self assert: (c arSinh sinh imaginary closeTo: c imaginary)]]!
Item was added:
+ ----- Method: ComplexTest>>testArTanh (in category 'tests') -----
+ testArTanh
+ | c |
+ c := (0.5 + 0 i).
+ self assert: (c arTanh real closeTo: c real arTanh).
+ self assert: (c arTanh imaginary closeTo: 0).
+ #(-0.5 -2 -3 0 0.5 2 3) do: [:real |
+ #(-0.5 -2 -3 0 0.5 2 3) do: [:imag |
+ c := real + imag i.
+ self assert: (c arTanh tanh real closeTo: c real).
+ self assert: (c arTanh tanh imaginary closeTo: c imaginary)]]!
Item was added:
+ ----- Method: ComplexTest>>testArcCos (in category 'tests') -----
+ testArcCos
+ | c |
+ c := (0.5 + 0 i).
+ self assert: (c arcCos real closeTo: c real arcCos).
+ self assert: (c arcCos imaginary closeTo: 0).
+ #(-0.5 -2 -3 0 0.5 2 3) do: [:real |
+ #(-0.5 -2 -3 0 0.5 2 3) do: [:imag |
+ c := real + imag i.
+ self assert: (c arcCos cos real closeTo: c real).
+ self assert: (c arcCos cos imaginary closeTo: c imaginary)]]!
Item was added:
+ ----- Method: ComplexTest>>testArcCosPlusArcSin (in category 'tests') -----
+ testArcCosPlusArcSin
+ | c |
+ #(-0.5 -2 -3 0 0.5 2 3) do: [:real |
+ #(-0.5 -2 -3 0 0.5 2 3) do: [:imag |
+ c := real + imag i.
+ self assert: ((c arcCos + c arcSin) real closeTo: Float halfPi).
+ self assert: ((c arcCos + c arcSin) imaginary closeTo: 0.0)]]!
Item was added:
+ ----- Method: ComplexTest>>testArcSin (in category 'tests') -----
+ testArcSin
+ | c |
+ c := (0.5 + 0 i).
+ self assert: (c arcSin real closeTo: c real arcSin).
+ self assert: (c arcSin imaginary closeTo: 0).
+ #(-0.5 -2 -3 0 0.5 2 3) do: [:real |
+ #(-0.5 -2 -3 0 0.5 2 3) do: [:imag |
+ c := real + imag i.
+ self assert: (c arcSin sin real closeTo: c real).
+ self assert: (c arcSin sin imaginary closeTo: c imaginary)]]!
Item was added:
+ ----- Method: ComplexTest>>testArcTan (in category 'tests') -----
+ testArcTan
+ | c |
+ c := (0.5 + 0 i).
+ self assert: (c arcTan real closeTo: c real arcTan).
+ self assert: (c arcTan imaginary closeTo: 0).
+ #(-0.5 -2 -3 0 0.5 2 3) do: [:real |
+ #(-0.5 -2 -3 0 0.5 2 3) do: [:imag |
+ c := real + imag i.
+ self assert: (c arcTan tan real closeTo: c real).
+ self assert: (c arcTan tan imaginary closeTo: c imaginary)]]!
Item was added:
+ ----- Method: ComplexTest>>testArg (in category 'tests') -----
+ testArg
+ "self run: #testArg"
+ "self debug: #testArg"
+
+ | c |
+ c := (0 + 5 i) .
+ self assert: c arg = (Float pi/ 2).
+ !
Item was added:
+ ----- Method: ComplexTest>>testBug1 (in category 'tests - bugs') -----
+ testBug1
+
+ self assert: (0.5 * (2+0i) ln) exp = (0.5 * 2 ln) exp.!
Item was added:
+ ----- Method: ComplexTest>>testComplexCollection (in category 'tests') -----
+ testComplexCollection
+ "self run: #testComplexCollection"
+ "self debug: #testComplexCollection"
+
+ | array array2 |
+ array := Array with: 1 + 2i with: 3 + 4i with: 5 + 6i.
+ array2 := 2 * array.
+ array with: array2 do: [:one :two | self assert: (2 * one) = two ] !
Item was added:
+ ----- Method: ComplexTest>>testConjugated (in category 'tests') -----
+ testConjugated
+
+ | c cc |
+ c := (5 - 6 i).
+ cc := c conjugated.
+ self assert: cc real = c real.
+ self assert: cc imaginary = c imaginary negated.!
Item was added:
+ ----- Method: ComplexTest>>testConversion (in category 'tests') -----
+ testConversion
+ "self run: #testConversion"
+ "self debug: #testConversion"
+
+ self assert: ((1 + 2i) + 1) = (2 + 2 i).
+ self assert: (1 + (1 + 2i)) = (2 + 2 i).
+ self assert: ((1 + 2i) + 1.0) = (2.0 + 2 i).
+ self assert: (1.0 + (1 + 2i)) = (2.0 + 2 i).
+ self assert: ((1 + 2i) + (2/3)) = ((5/3) + 2 i ).
+ self assert: ((2/3) + (1 + 2i)) = ((5/3) + 2 i )!
Item was added:
+ ----- Method: ComplexTest>>testCos (in category 'tests') -----
+ testCos
+ | c c2 |
+ c := (2 + 0 i).
+ self assert: (c cos real closeTo: c real cos).
+ self assert: (c cos imaginary closeTo: 0).
+ c := (2 + 3 i).
+ c2 := c i exp + c i negated exp / 2.
+ self assert: (c cos real closeTo: c2 real).
+ self assert: (c cos imaginary closeTo: c2 imaginary).!
Item was added:
+ ----- Method: ComplexTest>>testCos2PlusSin2 (in category 'tests') -----
+ testCos2PlusSin2
+ | c |
+ #(-0.5 -2 -3 0 0.5 2 3) do: [:real |
+ #(-0.5 -2 -3 0 0.5 2 3) do: [:imag |
+ c := real + imag i.
+ self assert: ((c cos squared + c sin squared) real closeTo: 1).
+ self assert: ((c cos squared + c sin squared) imaginary closeTo: 0.0)]]!
Item was added:
+ ----- Method: ComplexTest>>testCosh (in category 'tests') -----
+ testCosh
+ | c c2 |
+ c := (2 + 0 i).
+ self assert: (c cosh real closeTo: c real cosh).
+ self assert: (c cosh imaginary closeTo: 0).
+ c := (2 + 3 i).
+ c2 := c exp + c negated exp / 2.
+ self assert: (c cosh real closeTo: c2 real).
+ self assert: (c cosh imaginary closeTo: c2 imaginary).
+ c2 := c i cos.
+ self assert: (c cosh real closeTo: c2 real).
+ self assert: (c cosh imaginary closeTo: c2 imaginary).!
Item was added:
+ ----- Method: ComplexTest>>testCosh2MinusSinh2 (in category 'tests') -----
+ testCosh2MinusSinh2
+ | c |
+ #(-0.5 -2 -3 0 0.5 2 3) do: [:real |
+ #(-0.5 -2 -3 0 0.5 2 3) do: [:imag |
+ c := real + imag i.
+ self assert: ((c cosh squared - c sinh squared) real closeTo: 1).
+ self assert: ((c cosh squared - c sinh squared) imaginary closeTo: 0.0)]]!
Item was added:
+ ----- Method: ComplexTest>>testCreation (in category 'tests') -----
+ testCreation
+ "self run: #testCreation"
+
+ | c |
+ c := 5 i.
+ self assert: (c real = 0).
+ self assert: (c imaginary = 5).
+
+ c := 6 + 7 i.
+ self assert: (c real = 6).
+ self assert: ( c imaginary = 7).
+
+ c := 5.6 - 8 i.
+ self assert: (c real = 5.6).
+ self assert: (c imaginary = -8).
+
+ c := Complex real: 10 imaginary: 5.
+ self assert: (c real = 10).
+ self assert: (c imaginary = 5).
+
+ c := Complex abs: 5 arg: (Float pi/2).
+ self assert: (c real rounded = 0).
+ self assert: (c imaginary = 5).
+ !
Item was added:
+ ----- Method: ComplexTest>>testDivision1 (in category 'tests') -----
+ testDivision1
+ "self run: #testDivision1"
+ "self debug: #testDivision1"
+
+ | c1 c2 quotient |
+ c1 := 2.0e252 + 3.0e70 i.
+ c2 := c1.
+ quotient := c1 / c2.
+
+ "This used to fail when / was not protected against floating point overflow in intermediate computations
+ but it should now work correctly if divideSecureBy: is correctly used as fallback case"
+ self assert: (quotient - 1) isZero
+
+ !
Item was added:
+ ----- Method: ComplexTest>>testEquality (in category 'tests') -----
+ testEquality
+ "self run: #testEquality"
+ "self debug: #testEquality"
+
+ self assert: 0i = 0.
+ self assert: (2 - 5i) = ((1 -4 i) + (1 - 1i)).
+ self assert: 0i isZero.
+ self deny: (1 + 3 i) = 1.
+ self deny: (1 + 3 i) = (1 + 2i).
+
+ "Some more stuff"
+ self deny: (1 i) = nil.
+ self deny: nil = (1 i).
+
+ self deny: (1 i) = #(1 2 3).
+ self deny: #(1 2 3) = (1 i).
+
+ self deny: (1 i) = 0.
+ self deny: 0 = (1 i).
+
+ self assert: (1 + 0 i) = 1.
+ self assert: 1 = (1+ 0 i).
+
+ self assert: (1 + 0 i) = 1.0.
+ self assert: 1.0 = (1+ 0 i).
+
+ self assert: (1/2 + 0 i) = (1/2).
+ self assert: (1/2) = (1/2+ 0 i).!
Item was added:
+ ----- Method: ComplexTest>>testLn (in category 'tests') -----
+ testLn
+ self assert: (Float e + 0 i) ln = Float e ln "See Bug 1815 on Mantis"!
Item was added:
+ ----- Method: ComplexTest>>testMultiplyByI (in category 'tests') -----
+ testMultiplyByI
+
+ | c |
+ c := (5 - 6 i).
+ self assert: (c * 1i = c i)!
Item was added:
+ ----- Method: ComplexTest>>testMultiplyDoesNotOverflow (in category 'tests') -----
+ testMultiplyDoesNotOverflow
+
+ | c1 c2 product smallProduct scale |
+ c1 := (1 + 1 i) sqrt * Float fmax sqrt.
+ product := c1 squared.
+ self assert: product real isFinite.
+ self assert: product imaginary isFinite.
+ self assert: (product real - Float fmax) / Float fmax ulp < 3.
+ self assert: (product imaginary - Float fmax) / Float fmax ulp < 3.
+
+ "a more tricky case"
+ c1 := 1.0 + 0.25 i.
+ c2 := 1.125+ 0.5 i.
+ smallProduct := c1 * c2.
+ "check that we will not overflow in precondition"
+ self assert: smallProduct real abs <= 1.
+ self assert: smallProduct imaginary abs <= 1.
+ "now retry with a large scale"
+ scale := Float fmax.
+ product := c1 * scale * c2.
+ self assert: product real isFinite.
+ self assert: product imaginary isFinite.
+ self assert: (scale * smallProduct real - product real) / (scale * smallProduct real) ulp < 3.
+ self assert: (scale * smallProduct imaginary - product imaginary) / (scale * smallProduct imaginary) ulp < 3.!
Item was added:
+ ----- Method: ComplexTest>>testNegated (in category 'tests') -----
+ testNegated
+ "self run: #testNegated"
+ "self debug: #testNegated"
+
+ | c |
+ c := (2 + 5 i) .
+ self assert: c negated = (-2 - 5i).
+ !
Item was added:
+ ----- Method: ComplexTest>>testRaisedTo (in category 'tests') -----
+ testRaisedTo
+
+ | c c3 |
+ c := (5 - 6 i).
+ c3 := (c raisedTo: 0.2) raisedTo: 5.
+ self assert: (c3 real closeTo: c real).
+ self assert: (c3 imaginary closeTo: c imaginary).!
Item was added:
+ ----- Method: ComplexTest>>testRaisedToInteger (in category 'tests') -----
+ testRaisedToInteger
+
+ | c c3 |
+ c := (5 - 6 i).
+ c3 := (c * c * c).
+ self assert: (c3 = (c raisedToInteger: 3)).
+ self assert: (c3 reciprocal = (c raisedToInteger: -3)).!
Item was added:
+ ----- Method: ComplexTest>>testReciprocal (in category 'tests') -----
+ testReciprocal
+ "self run: #testReciprocal"
+ "self debug: #testReciprocal"
+
+ | c |
+ c := (2 + 5 i).
+ self assert: c reciprocal = ((2/29) - (5/29)i).
+ !
Item was added:
+ ----- Method: ComplexTest>>testReciprocalDoesNotOverflow (in category 'tests') -----
+ testReciprocalDoesNotOverflow
+ "Note: intermediate overflow might cause the answer to be zero in careless implementation"
+
+ | c scale cScaled cScaledInv expected |
+ c := (1 + 1i).
+ scale := Float fmax.
+ cScaled := c * scale.
+ cScaledInv := cScaled reciprocal.
+ expected := c reciprocal real / scale + (c reciprocal imaginary / scale) i.
+ self assert: (expected real- cScaledInv real) abs / expected real ulp < 3.
+ self assert: (expected imaginary - cScaledInv imaginary) abs / expected imaginary ulp < 3.!
Item was added:
+ ----- Method: ComplexTest>>testReciprocalError (in category 'tests') -----
+ testReciprocalError
+ "self run: #testReciprocalError"
+ "self debug: #testReciprocalError"
+
+ | c |
+ c := (0 i).
+ self should: [c reciprocal] raise: ZeroDivide
+ !
Item was added:
+ ----- Method: ComplexTest>>testSecureDivision1 (in category 'tests') -----
+ testSecureDivision1
+ "self run: #testSecureDivision1"
+ "self debug: #testSecureDivision1"
+
+ | c1 c2 quotient |
+ c1 := 2.0e252 + 3.0e70 i.
+ c2 := c1.
+ quotient := c1 divideSecureBy: c2.
+ self assert: (quotient - 1) isZero.
+ !
Item was added:
+ ----- Method: ComplexTest>>testSecureDivision2 (in category 'tests') -----
+ testSecureDivision2
+ "self run: #testSecureDivision2"
+ "self debug: #testSecureDivision2"
+
+ | c1 c2 quotient |
+ c1 := 2.0e252 + 3.0e70 i.
+ c2 := c1.
+ quotient := c1 divideFastAndSecureBy: c2.
+ self assert: (quotient - 1) isZero.
+ !
Item was added:
+ ----- Method: ComplexTest>>testSecureDivisionDoesNotOverflow (in category 'tests') -----
+ testSecureDivisionDoesNotOverflow
+
+ | c1 c2 scale |
+ "Note: this test used to fail with legacy version of divideSecureBy:"
+ c1 := (2 + 1i).
+ c2 := (1 + 1i).
+ scale := Float fmax.
+ self testSecureDivisionOf: c1 by: c2 scaledBy: scale.
+ "And this one fails with incomplete correction of above method"
+ c1 := (1/2 + 1i) / (5 << 48).
+ c2 := (1 + 1i).
+ scale := Float fminDenormalized.
+ self testSecureDivisionOf: c1 by: c2 scaledBy: scale!
Item was added:
+ ----- Method: ComplexTest>>testSecureDivisionOf:by:scaledBy: (in category 'tests') -----
+ testSecureDivisionOf: c1 by: c2 scaledBy: scale
+ "Note: this test used to fail with legacy version of divideSecureBy:"
+
+ | quo expected |
+ quo := c1 / c2.
+ expected := quo real / scale + (quo imaginary / scale) i.
+ "check in precondition that the scaled division c1/(c2*scale) would not oevrflow"
+ self assert: expected real isFinite.
+ self assert: expected imaginary isFinite.
+ "now retry with scaling"
+ quo := c1 divideSecureBy: (c2 * scale).
+ self assert: quo real isFinite.
+ self assert: quo imaginary isFinite.
+ self assert: (expected real - quo real) abs / (expected real ulp) < 3.
+ self assert: (expected imaginary - quo imaginary) abs / (expected imaginary ulp) < 3.!
Item was added:
+ ----- Method: ComplexTest>>testSin (in category 'tests') -----
+ testSin
+ | c c2 |
+ c := (2 + 0 i).
+ self assert: (c sin real closeTo: c real sin).
+ self assert: (c sin imaginary closeTo: 0).
+ c := 2 + 3 i.
+ c2 := c i exp - c i negated exp / 2 i.
+ self assert: (c sin real closeTo: c2 real).
+ self assert: (c sin imaginary closeTo: c2 imaginary).!
Item was added:
+ ----- Method: ComplexTest>>testSinh (in category 'tests') -----
+ testSinh
+ | c c2 |
+ c := (2 + 0 i).
+ self assert: (c sinh real closeTo: c real sinh).
+ self assert: (c sinh imaginary closeTo: 0).
+ c := 2 + 3 i.
+ c := c cosh squared - c sinh squared.
+ self assert: (c real closeTo: 1).
+ self assert: (c imaginary closeTo: 0).
+ c2 := c exp - c negated exp / 2.
+ self assert: (c sinh real closeTo: c2 real).
+ self assert: (c sinh imaginary closeTo: c2 imaginary).
+ c2 := c i sin i negated.
+ self assert: (c sinh real closeTo: c2 real).
+ self assert: (c sinh imaginary closeTo: c2 imaginary).!
Item was added:
+ ----- Method: ComplexTest>>testSqrt (in category 'tests') -----
+ testSqrt
+ -3 to: 3 do: [:re | -2 to: 2 do: [:im |
+ | c s t |
+ c := re asFloat + im asFloat i.
+ s := c sqrt.
+ t := s squared.
+ self assert: (t real - c real) abs / 4 < c abs asFloat ulp.
+ self assert: (t imaginary - c imaginary) abs / 4 < c abs asFloat ulp.
+ self assert: s imaginary signBit = c imaginary signBit]]!
Item was added:
+ ----- Method: ComplexTest>>testSquared (in category 'tests') -----
+ testSquared
+ "self run: #testSquared"
+ "self debug: #testSquared"
+
+ | c c2 |
+ c := (6 - 6 i).
+ c2 := (c squared).
+ self assert: c2 imaginary = -72.
+ self assert: c2 real = 0.!
Item was added:
+ ----- Method: ComplexTest>>testTan (in category 'tests') -----
+ testTan
+ | c c2 |
+ c := (2 + 0 i).
+ self assert: (c tan real closeTo: c real tan).
+ self assert: (c tan imaginary closeTo: 0).
+ c := 2 + 3 i.
+ c2 := c sin / c cos.
+ self assert: (c2 real closeTo: c tan real).
+ self assert: (c2 imaginary closeTo: c tan imaginary).!
Item was added:
+ ----- Method: ComplexTest>>testTanh (in category 'tests') -----
+ testTanh
+ | c c2 |
+ c := (2 + 0 i).
+ self assert: (c tanh real closeTo: c real tanh).
+ self assert: (c tanh imaginary closeTo: 0).
+ c := 2 + 3 i.
+ c2 := c sinh / c cosh.
+ self assert: (c2 real closeTo: c tanh real).
+ self assert: (c2 imaginary closeTo: c tanh imaginary).!
Item was added:
+ TestCase subclass: #ContextTest
+ instanceVariableNames: 'aCompiledMethod aReceiver aSender aContext'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'KernelTests-Methods'!
+
+ !ContextTest commentStamp: 'ct 1/27/2020 13:03' prior: 0!
+ I am an SUnit Test of Context. See also BlockClosureTest.
+ See pages 430-437 of A. Goldberg and D. Robson's Smalltalk-80 The Language (aka the purple book), which deal with Contexts. My fixtures are from their example. To see how blocks are implemented in this version of Squeak see http://www.mirandabanda.org/cogblog/2008/06/07/closures-part-i/ and http://www.mirandabanda.org/cogblog/2008/07/22/closures-part-ii-the-bytecod…. (The Squeak V3 byte codes are not quite the same as Smalltalk-80, and the SistaV1 byetcodes are quite different.)
+ My fixtures are:
+ aReceiver - just some arbitrary object, "Rectangle origin: 100@100 corner: 200@200"
+ aSender - just some arbitrary object, thisContext
+ aCompiledMethod - just some arbitrary method, "Rectangle rightCenter".
+ aContext - just some arbitray context ...
+
+ !
Item was added:
+ ----- Method: ContextTest>>privRestartTest (in category 'private') -----
+ privRestartTest
+ "This tests may loop endlessly if incorrect, so call it from another method testing it does not time out"
+ |a firstTimeThrough |
+ firstTimeThrough := true.
+ a := 10.
+
+ self assert: 30 equals: [|b|
+ self assert: 10 = a .
+ self assert: nil == b.
+ b := a + 20.
+ firstTimeThrough ifTrue: [
+ firstTimeThrough := false.
+ thisContext restart.].
+ b] value
+ !
Item was added:
+ ----- Method: ContextTest>>setUp (in category 'running') -----
+ setUp
+ super setUp.
+ aCompiledMethod := Rectangle methodDict at: #rightCenter.
+ aReceiver := 100@100 corner: 200@200.
+ aSender := thisContext.
+ aContext := Context sender: aSender receiver: aReceiver method: aCompiledMethod arguments: #(). !
Item was added:
+ ----- Method: ContextTest>>testActivateReturnValue (in category 'tests') -----
+ testActivateReturnValue
+ self assert: (aSender activateReturn: aContext value: #()) isContext.
+ self assert: ((aSender activateReturn: aContext value: #()) receiver = aContext).!
Item was added:
+ ----- Method: ContextTest>>testCopyStack (in category 'tests') -----
+ testCopyStack
+ self assert: aContext copyStack printString = aContext printString.!
Item was added:
+ ----- Method: ContextTest>>testCopyTo (in category 'tests') -----
+ testCopyTo
+
+ | context depth targetSender |
+ context := thisContext.
+ depth := 1.
+ targetSender := context.
+ [ (targetSender := targetSender sender) isNil ] whileFalse: [
+ | original copy |
+ original := context.
+ copy := context copyTo: targetSender.
+ 1 to: depth do: [ :index |
+ index = 1 ifFalse: [
+ "Since we're copying thisContext, the pc and stackPtr may be different for the current frame."
+ self
+ assert: original pc equals: copy pc;
+ assert: original stackPtr equals: copy stackPtr ].
+ self
+ deny: original == copy;
+ assert: original method equals: copy method;
+ assert: original closure equals: copy closure;
+ assert: original receiver equals: copy receiver.
+ original := original sender.
+ copy := copy sender ].
+ self
+ assert: copy isNil;
+ assert: original == targetSender.
+ depth := depth + 1 ]!
Item was added:
+ ----- Method: ContextTest>>testFindContextSuchThat (in category 'tests') -----
+ testFindContextSuchThat
+ self assert: (aContext findContextSuchThat: [:each| true]) printString = aContext printString.
+ self assert: (aContext hasContext: aContext). !
Item was added:
+ ----- Method: ContextTest>>testMessageNotUnderstood (in category 'tests') -----
+ testMessageNotUnderstood
+
+ "A simulation error (recursive message not understood) occurs that cannot be handled by the simulated code"
+ self
+ should:
+ [Context runSimulated:
+ [[TestEmptyClass new foo]
+ on: Error do: [:ex | ex]]]
+ raise: Error.
+
+ "The simulator sends #doesNotUnderstand: to the receiver even if the lookup class has no superclass."
+ self assert:
+ [Context runSimulated:
+ [self
+ executeShould: [ProtoObject new foo]
+ inScopeOf: MessageNotUnderstood]].
+ self assert:
+ [Context runSimulated:
+ [self
+ executeShould: [Compiler evaluate: 'super foo' for: Object new]
+ inScopeOf: MessageNotUnderstood]].!
Item was added:
+ ----- Method: ContextTest>>testMethodContext (in category 'tests') -----
+ testMethodContext
+ self assert: aContext home notNil.
+ self assert: aContext receiver notNil.
+ self assert: aContext method isCompiledMethod.!
Item was added:
+ ----- Method: ContextTest>>testMethodIsBottomContext (in category 'tests') -----
+ testMethodIsBottomContext
+ self assert: aContext bottomContext = aSender.
+ self assert: aContext secondFromBottom = aContext.!
Item was added:
+ ----- Method: ContextTest>>testObjectsAsMethod (in category 'tests') -----
+ testObjectsAsMethod
+
+ | result error |
+ SystemChangeNotifier uniqueInstance doSilently: [
+ self class addSelector: #foo withMethod: (TestObjectForMethod new xxxMethod: thisContext homeMethod)].
+
+ result := Context runSimulated: [[self foo] on: Error do: [:ex | error := ex]].
+ error ifNotNil: [self fail: error].
+
+ SystemChangeNotifier uniqueInstance doSilently: [
+ [self assert: self foo equals: result]
+ ensure: [self class removeSelector: #foo]].!
Item was added:
+ ----- Method: ContextTest>>testPrimitive100 (in category 'tests') -----
+ testPrimitive100
+
+ {
+ {#isNil. {}. Object}. "valid 0-arg message"
+ {#=. {true}. UndefinedObject}. "valid unary message"
+ {#ifNil:ifNotNil:. {[2]. [:x | x]}. Object}. "valid binary message"
+ {{}. #=. {true}. SequenceableCollection}. "mirror primitive"
+ {#isNil}. "missing arguments"
+ {#isNil. 'not an array'}. "invalid arguments"
+ {#isNil. {}}. "missing lookupClass"
+ {#isNil. {'excess arg'}. Object}. "too many arguments"
+ {#=. {}. UndefinedObject}. "missing argument"
+ {#isNil. {}. Boolean}. "lookupClass not in inheritance chain"
+ } do: [:args |
+ self
+ assert: (nil tryPrimitive: 100 withArgs: args)
+ equals: (Context runSimulated: [nil tryPrimitive: 100 withArgs: args])].!
Item was added:
+ ----- Method: ContextTest>>testPrimitive83 (in category 'tests') -----
+ testPrimitive83
+
+ {
+ {#isNil}. "valid 0-arg message"
+ {#=. true}. "valid unary message"
+ {#ifNil:ifNotNil:. [2]. [:x | x]}. "valid binary message"
+ {#isNil. 'excess arg'}. "too many arguments"
+ {#=}. "missing argument"
+ } do: [:args |
+ self
+ assert: (nil tryPrimitive: 83 withArgs: args)
+ equals: (Context runSimulated: [nil tryPrimitive: 83 withArgs: args])].!
Item was added:
+ ----- Method: ContextTest>>testPrimitive84 (in category 'tests') -----
+ testPrimitive84
+
+ {
+ {#isNil. {}}. "valid 0-arg message"
+ {#=. {true}}. "valid unary message"
+ {#ifNil:ifNotNil:. {[2]. [:x | x]}}. "valid binary message"
+ {#isNil}. "missing arguments"
+ {#isNil. 'not an array'}. "invalid arguments"
+ {#isNil. {'excess arg'}}. "too many arguments"
+ {#=. {}}. "missing argument"
+ } do: [:args |
+ self
+ assert: (nil tryPrimitive: 84 withArgs: args)
+ equals: (Context runSimulated: [nil tryPrimitive: 84 withArgs: args])].!
Item was added:
+ ----- Method: ContextTest>>testRestart (in category 'tests') -----
+ testRestart
+ self should: [self privRestartTest] notTakeMoreThan: 0.1 second!
Item was added:
+ ----- Method: ContextTest>>testReturn (in category 'tests') -----
+ testReturn
+ "Why am I overriding setUp? Because sender must be thisContext, i.e, testReturn, not setUp."
+ aContext := Context sender: thisContext receiver: aReceiver method: aCompiledMethod arguments: #().
+ self assert: (aContext return: 5) = 5!
Item was added:
+ ----- Method: ContextTest>>testSetUp (in category 'tests') -----
+ testSetUp
+ "Note: In addition to verifying that the setUp worked the way it was expected to, testSetUp is used to illustrate the meaning of the simple access methods, methods that are not normally otherwise 'tested'"
+ self assert: aContext isContext.
+ self deny: aContext isExecutingBlock.
+ self deny: aContext isClosure.
+ self deny: aContext isDead.
+ "self assert: aMethodContext home = aReceiver."
+ "self assert: aMethodContext blockHome = aReceiver."
+ self assert: aContext receiver = aReceiver.
+ self assert: aContext method isCompiledMethod.
+ self assert: aContext method = aCompiledMethod.
+ self assert: aContext methodNode selector = #rightCenter.
+ self assert: (aContext methodNodeFormattedAndDecorated: true) selector = #rightCenter.
+ self assert: aContext client printString = 'ContextTest>>#testSetUp'.
+ !
Item was added:
+ TestCase subclass: #DelayTest
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'KernelTests-Processes'!
Item was added:
+ ----- Method: DelayTest>>testBounds (in category 'tests - limits') -----
+ testBounds
+ "self run: #testBounds"
+
+ self should: [Delay forMilliseconds: -1] raise: Error.
+
+ "We expect these to succeed."
+ Delay forMilliseconds: SmallInteger maxVal + 1.
+ (Delay forMilliseconds: Float pi) wait. "Wait 3ms"
+ !
Item was added:
+ ----- Method: DelayTest>>testMultiProcessWaitOnSameDelay (in category 'tests - limits') -----
+ testMultiProcessWaitOnSameDelay
+ "Ensure that waiting on the same delay from multiple processes raises an error"
+ | delay p1 p2 wasRun |
+ delay := Delay forSeconds: 1.
+ wasRun := false.
+ p1 := [delay wait] forkAt: Processor activePriority+1.
+ p2 := [
+ self should:[delay wait] raise: Error.
+ wasRun := true.
+ ] forkAt: Processor activePriority+1.
+ p1 terminate.
+ p2 terminate.
+ self assert: wasRun.
+
+ !
Item was added:
+ ----- Method: DelayTest>>testMultiSchedule (in category 'tests - limits') -----
+ testMultiSchedule
+ "Ensure that scheduling the same delay twice raises an error"
+ | delay |
+ delay := Delay forSeconds: 1.
+ delay schedule.
+ self should:[delay schedule] raise: Error.
+ !
Item was added:
+ ClassTestCase subclass: #DependentsArrayTest
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'KernelTests-Objects'!
+
+ !DependentsArrayTest commentStamp: '<historical>' prior: 0!
+ This class is to test the special implementation of DependentsArray.
+
+ DependentsArray size will not count nil elements (the ones reclaimed by garbage collector).
+ Consequently, any message implemented with a construction like (1 to: self size do: [:i | ]) and sent to the dependents of any object might not behave as supposed to.!
Item was added:
+ ----- Method: DependentsArrayTest>>testAddingTwice (in category 'tests') -----
+ testAddingTwice
+
+ | test dep2 deps |
+ test := Object new.
+ dep2 := String with: $z with: $u with: $t.
+
+ test addDependent: String new.
+ test addDependent: dep2.
+
+ Smalltalk garbageCollect. "this will make first dependent vanish, replaced by nil"
+
+ test addDependent: dep2.
+
+ deps := test dependents.
+ self should: [deps asIdentitySet size = deps size] description: 'No object should be added twice in dependents'!
Item was added:
+ ----- Method: DependentsArrayTest>>testCanDiscardEdits (in category 'tests') -----
+ testCanDiscardEdits
+ "self debug: #testCanDiscardEdits."
+
+ | anObject aView |
+ anObject := Object new.
+ "A Project may always discard edits."
+ aView := Project new.
+ anObject addDependent: Object new. "this entry should be garbage collected"
+ anObject addDependent: aView.
+
+ Smalltalk garbageCollect. "force garbage collection"
+
+ self
+ should: [anObject dependents size = 1]
+ description: 'first dependent of anObject should have been collected, second should not'.
+
+ self
+ shouldnt: [anObject canDiscardEdits]
+ description: 'anObject cannot discard edits because aView is a dependent of anObject and aView has unaccepted edits'.!
Item was added:
+ ----- Method: DependentsArrayTest>>testSize (in category 'tests') -----
+ testSize
+
+ self
+ assert: (DependentsArray with: nil) size = 0;
+ assert: (DependentsArray with: nil with: 1 with: nil) size = 1;
+ assert: (DependentsArray with: 1 with: 3) size = 2;
+ assert: (DependentsArray with: nil with: nil with: nil) size = 0!
Item was added:
+ ClassTestCase subclass: #ExtendedNumberParserTest
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'KernelTests-Numbers'!
Item was added:
+ ----- Method: ExtendedNumberParserTest>>testFractionPartWithoutIntegerPart (in category 'tests') -----
+ testFractionPartWithoutIntegerPart
+ "The integer part before the decimal is optional"
+
+ self assert: (ExtendedNumberParser parse: '.5') = (1/2).
+ self assert: (ExtendedNumberParser parse: '.5') isFloat.
+
+ self assert: (ExtendedNumberParser parse: '.3e2') = 30.
+ self assert: (ExtendedNumberParser parse: '.3e2') isFloat.
+
+ self assert: (ExtendedNumberParser parse: '-.4e2') = -40.
+ self assert: (ExtendedNumberParser parse: '-.4e2') isFloat.
+
+ self assert: (ExtendedNumberParser parse: '+.5e2') = 50.
+ self assert: (ExtendedNumberParser parse: '+.5e2') isFloat.
+
+ self assert: (ExtendedNumberParser parse: '+.6e+2') = 60.
+ self assert: (ExtendedNumberParser parse: '+.6e+2') isFloat.
+
+ self assert: (ExtendedNumberParser parse: '-.7e+2') = -70.
+ self assert: (ExtendedNumberParser parse: '-.7e+2') isFloat.
+
+ self assert: (ExtendedNumberParser parse: '+2r.1e-2') = (1/8).
+ self assert: (ExtendedNumberParser parse: '+2r.1e-2') isFloat.
+
+ self assert: (ExtendedNumberParser parse: '-4r.1e-2') = (-1/64).
+ self assert: (ExtendedNumberParser parse: '-4r.1e-2') isFloat.!
Item was added:
+ ----- Method: ExtendedNumberParserTest>>testIntegerPartWithoutFraction (in category 'tests') -----
+ testIntegerPartWithoutFraction
+ "The fraction part after the decimal is optional"
+
+ self assert: (ExtendedNumberParser parse: '1.') = 1.
+ self assert: (ExtendedNumberParser parse: '1.') isFloat.
+
+ self assert: (ExtendedNumberParser parse: '3.e2') = 300.
+ self assert: (ExtendedNumberParser parse: '3.e2') isFloat.
+
+ self assert: (ExtendedNumberParser parse: '-4.e2') = -400.
+ self assert: (ExtendedNumberParser parse: '-4.e2') isFloat.
+
+ self assert: (ExtendedNumberParser parse: '+5.e2') = 500.
+ self assert: (ExtendedNumberParser parse: '+5.e2') isFloat.
+
+ self assert: (ExtendedNumberParser parse: '+6.e+2') = 600.
+ self assert: (ExtendedNumberParser parse: '+6.e+2') isFloat.
+
+ self assert: (ExtendedNumberParser parse: '-7.e+2') = -700.
+ self assert: (ExtendedNumberParser parse: '-7.e+2') isFloat.
+
+ self assert: (ExtendedNumberParser parse: '+2r1.e-2') = (1/4).
+ self assert: (ExtendedNumberParser parse: '+2r1.e-2') isFloat.
+
+ self assert: (ExtendedNumberParser parse: '-4r1.e-2') = (-1/16).
+ self assert: (ExtendedNumberParser parse: '-4r1.e-2') isFloat.!
Item was added:
+ ----- Method: ExtendedNumberParserTest>>testInvalidExponent (in category 'tests') -----
+ testInvalidExponent
+ "The leading number is returned, the invalid part is ignored"
+
+ self assert: (ExtendedNumberParser parse: '1e') = 1.
+ self assert: (ExtendedNumberParser parse: '1eZ') = 1.
+ self assert: (ExtendedNumberParser parse: '+1eW') = 1.
+ self assert: (ExtendedNumberParser parse: '-1eX') = -1.
+
+ self assert: (ExtendedNumberParser parse: '2e-') = 2.
+ self assert: (ExtendedNumberParser parse: '2e--1') = 2.
+ self assert: (ExtendedNumberParser parse: '2e-+1') = 2.
+ self assert: (ExtendedNumberParser parse: '2e-Z') = 2.
+ self assert: (ExtendedNumberParser parse: '+2e-W') = 2.
+ self assert: (ExtendedNumberParser parse: '-2e-X') = -2.
+
+ self assert: (ExtendedNumberParser parse: '3e+') = 3.
+ self assert: (ExtendedNumberParser parse: '3e+-') = 3.
+ self assert: (ExtendedNumberParser parse: '3e+-1') = 3.
+ self assert: (ExtendedNumberParser parse: '+3e+W') = 3.
+ self assert: (ExtendedNumberParser parse: '-3e+Z') = -3.!
Item was added:
+ ----- Method: ExtendedNumberParserTest>>testInvalidRadix (in category 'tests') -----
+ testInvalidRadix
+ "The leading number is returned, the invalid part is ignored"
+
+ self assert: (ExtendedNumberParser parse: '1r') = 1.
+ self assert: (ExtendedNumberParser parse: '+1r') = 1.
+ self assert: (ExtendedNumberParser parse: '-1r') = -1.
+ self assert: (ExtendedNumberParser parse: '-1r+') = -1.
+ self assert: (ExtendedNumberParser parse: '-1r-') = -1.
+
+ self assert: (ExtendedNumberParser parse: '-2r.') = -2.
+ self assert: (ExtendedNumberParser parse: '-2r-.') = -2.
+ self assert: (ExtendedNumberParser parse: '+2r-.') = 2.
+
+ self assert: (ExtendedNumberParser parse: '+2r3.') = 2.
+ self assert: (ExtendedNumberParser parse: '+2r.3') = 2.
+ self assert: (ExtendedNumberParser parse: '+2r-.3') = 2.!
Item was added:
+ ----- Method: ExtendedNumberParserTest>>testInvalidScale (in category 'tests') -----
+ testInvalidScale
+ "The leading number is returned, the invalid part is ignored"
+
+ self assert: (ExtendedNumberParser parse: '1s') = 1.
+ self assert: (ExtendedNumberParser parse: '1sZ') = 1.
+ self assert: (ExtendedNumberParser parse: '+1sW') = 1.
+ self assert: (ExtendedNumberParser parse: '-1sX') = -1.
+
+ self assert: (ExtendedNumberParser parse: '2s-') = 2.
+ self assert: (ExtendedNumberParser parse: '2s--1') = 2.
+ self assert: (ExtendedNumberParser parse: '2s-+1') = 2.
+ self assert: (ExtendedNumberParser parse: '2s-1') = 2.
+ self assert: (ExtendedNumberParser parse: '+2s-2') = 2.
+ self assert: (ExtendedNumberParser parse: '-2s-3') = -2.
+
+ self assert: (ExtendedNumberParser parse: '3s+') = 3.
+ self assert: (ExtendedNumberParser parse: '3s+-') = 3.
+ self assert: (ExtendedNumberParser parse: '3s+-1') = 3.
+ self assert: (ExtendedNumberParser parse: '+3s+2') = 3.
+ self assert: (ExtendedNumberParser parse: '-3s+3') = -3.!
Item was added:
+ ----- Method: ExtendedNumberParserTest>>testPositive (in category 'tests') -----
+ testPositive
+ "A leading + sign is allowed"
+
+ self assert: (ExtendedNumberParser parse: '+1') = 1.
+ self assert: (ExtendedNumberParser parse: '+22') = 22.
+ self assert: (ExtendedNumberParser parse: '+2r11') = 3.
+ self assert: (ExtendedNumberParser parse: '+2r+101') = 5.
+ self assert: (ExtendedNumberParser parse: '+2r-101') = -5.
+ self assert: (ExtendedNumberParser parse: '-2r+101') = -5.
+
+ self assert: (ExtendedNumberParser parse: '+1.') isFloat.
+ self assert: (ExtendedNumberParser parse: '+1.') = 1.
+ self assert: (ExtendedNumberParser parse: '+21.') = 21.
+ self assert: (ExtendedNumberParser parse: '+3r21.') = 7.
+ self assert: (ExtendedNumberParser parse: '+3r+201.') = 19.
+ self assert: (ExtendedNumberParser parse: '+3r-201.') = -19.
+ self assert: (ExtendedNumberParser parse: '-3r+201.') = -19.!
Item was added:
+ ----- Method: ExtendedNumberParserTest>>testPositiveExponent (in category 'tests') -----
+ testPositiveExponent
+ "A leading + sign is allowed in exponent"
+
+ self assert: (ExtendedNumberParser parse: '1e+2') = 100.
+ self assert: (ExtendedNumberParser parse: '1e+2') isInteger.
+ self assert: (ExtendedNumberParser parse: '-1e+2') = -100.
+
+ self assert: (ExtendedNumberParser parse: '1.e+2') = 100.
+ self assert: (ExtendedNumberParser parse: '1.e+2') isFloat.
+ self assert: (ExtendedNumberParser parse: '-1.0e+2') = -100.!
Item was added:
+ ----- Method: ExtendedNumberParserTest>>testUppercaseExponent (in category 'tests') -----
+ testUppercaseExponent
+ "An uppercase exponent is allowed"
+
+ self assert: 0.01 equals: (ExtendedNumberParser parse: '1.00E-2').
+ self assert: 305.0 equals: (ExtendedNumberParser parse: '3.05D+2').!
Item was added:
+ ClassTestCase subclass: #FalseTest
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'KernelTests-Objects'!
+
+ !FalseTest commentStamp: '<historical>' prior: 0!
+ This is the unit test for the class False. Unit tests are a good way to exercise the functionality of your system in a repeatable and automatic manner. They are therefore recommended if you plan to release anything. For more information, see:
+ - http://www.c2.com/cgi/wiki?UnitTest
+ - http://minnow.cc.gatech.edu/squeak/1547
+ - the sunit class category
+ !
Item was added:
+ ----- Method: FalseTest>>testAND (in category 'tests') -----
+ testAND
+
+ self assert: (false & true) = false.
+ self assert: (false & false) = false.!
Item was added:
+ ----- Method: FalseTest>>testAnd (in category 'tests') -----
+ testAnd
+
+ self assert: (false and: ['alternativeBlock']) = false.!
Item was added:
+ ----- Method: FalseTest>>testAsBit (in category 'tests') -----
+ testAsBit
+
+ self assert: (false asBit = 0).!
Item was added:
+ ----- Method: FalseTest>>testIfFalse (in category 'tests') -----
+ testIfFalse
+
+ self assert: ((false ifFalse: ['alternativeBlock']) = 'alternativeBlock'). !
Item was added:
+ ----- Method: FalseTest>>testIfFalseIfTrue (in category 'tests') -----
+ testIfFalseIfTrue
+
+ self assert: (false ifFalse: ['falseAlternativeBlock']
+ ifTrue: ['trueAlternativeBlock']) = 'falseAlternativeBlock'. !
Item was added:
+ ----- Method: FalseTest>>testIfTrue (in category 'tests') -----
+ testIfTrue
+
+ self assert: (false ifTrue: ['alternativeBlock']) = nil. !
Item was added:
+ ----- Method: FalseTest>>testIfTrueIfFalse (in category 'tests') -----
+ testIfTrueIfFalse
+
+ self assert: (false ifTrue: ['trueAlternativeBlock']
+ ifFalse: ['falseAlternativeBlock']) = 'falseAlternativeBlock'. !
Item was added:
+ ----- Method: FalseTest>>testInMemory (in category 'tests') -----
+ testInMemory
+
+ self assert: (false isInMemory = true).!
Item was added:
+ ----- Method: FalseTest>>testNew (in category 'tests') -----
+ testNew
+
+ self shouldRaiseError: [False new].!
Item was added:
+ ----- Method: FalseTest>>testNot (in category 'tests') -----
+ testNot
+
+ self assert: (false not = true).!
Item was added:
+ ----- Method: FalseTest>>testOR (in category 'tests') -----
+ testOR
+
+ self assert: (false | true) = true.
+ self assert: (false | false) = false.!
Item was added:
+ ----- Method: FalseTest>>testOr (in category 'tests') -----
+ testOr
+
+ self assert: (false or: ['alternativeBlock']) = 'alternativeBlock'.!
Item was added:
+ ----- Method: FalseTest>>testPrintOn (in category 'tests') -----
+ testPrintOn
+
+ self assert: (String streamContents: [:stream | false printOn: stream]) = 'false'. !
Item was added:
+ ----- Method: FalseTest>>testXor (in category 'tests') -----
+ testXor
+ self assert: (false xor: true) = true.
+ self assert: (false xor: false) = false.
+ self assert: (false xor: [true]) = true.
+ self assert: (false xor: [false]) = false.
+ "Verify that boolean with non-boolean raise errors."
+ self should: [false xor: [1]] raise: Error.
+ self should: [false xor: 1] raise: Error.!
Item was added:
+ ClassTestCase subclass: #FloatTest
+ instanceVariableNames: 'exactInteger float greaterInexactInt smallerInexactInt greaterFloat smallerFloat boxedFloat greaterBoxedFloat smallerBoxedFloat'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'KernelTests-Numbers'!
+
+ !FloatTest commentStamp: 'fbs 3/8/2004 22:13' prior: 0!
+ I provide a test suite for Float values. Examine my tests to see how Floats should behave, and see how to use them.!
Item was added:
+ ----- Method: FloatTest class>>testClassConstantsPasses (in category 'utilities') -----
+ testClassConstantsPasses
+ "Answer if testClassConstants passes. This can be used in e.g. the Kernel Package prolog
+ to test if Float initialize needs to be run."
+ [self new testClassConstants]
+ on: TestResult failure
+ do: [:ex| ^false].
+ ^true!
Item was added:
+ ----- Method: FloatTest>>assert:equals:withinUlp: (in category 'asserting') -----
+ assert: expected equals: actual withinUlp: maxUlp
+ self assert: (expected - actual) abs <= (maxUlp * expected asFloat ulp)!
Item was added:
+ ----- Method: FloatTest>>assertIsNegativeZero: (in category 'asserting') -----
+ assertIsNegativeZero: aFloat
+ "Assert that aFloat is Float negativeZero"
+ self assert: aFloat = 0.0.
+ self assert: aFloat signBit = 1!
Item was added:
+ ----- Method: FloatTest>>assertIsPositiveZero: (in category 'asserting') -----
+ assertIsPositiveZero: aFloat
+ "Assert that aFloat is Float zero (the positive one)"
+ self assert: aFloat = 0.0.
+ self assert: aFloat signBit = 0!
Item was added:
+ ----- Method: FloatTest>>floatLiteralsIn: (in category 'private') -----
+ floatLiteralsIn: method
+ | floatLiterals |
+ floatLiterals := OrderedCollection new.
+ method allLiteralsDo:
+ [:lit| lit isFloat ifTrue: [floatLiterals addLast: lit]].
+ ^floatLiterals!
Item was added:
+ ----- Method: FloatTest>>methodContainsFloatLiteral: (in category 'private') -----
+ methodContainsFloatLiteral: method
+ method isQuick ifFalse:
+ [method allLiteralsDo:
+ [:lit| lit isFloat ifTrue: [^true]]].
+ ^false!
Item was added:
+ ----- Method: FloatTest>>methodsMaybeContainingBrokenCompiledConstants (in category 'private') -----
+ methodsMaybeContainingBrokenCompiledConstants
+ "Answer a set of all methods in the system which contain float constants that differ from those obtaiuned by
+ recompiling. These may indicate an old compiler issue, or indeed an issue with the current compiler. This is a
+ variant of testCompiledConstants used for collecting the set of methods rather than testing that none exist."
+ | identifiedPatients |
+ identifiedPatients := IdentitySet new.
+ CurrentReadOnlySourceFiles cacheDuring:
+ [self systemNavigation allSelectorsAndMethodsDo:
+ [:class :selector :method|
+ (self methodContainsFloatLiteral: method) ifTrue:
+ [| newMethodAndNode newLiterals oldLiterals |
+ newMethodAndNode := class compile: method getSource asString notifying: nil trailer: CompiledMethodTrailer empty ifFail: nil.
+ newLiterals := self floatLiteralsIn: newMethodAndNode method.
+ oldLiterals := self floatLiteralsIn: method.
+ "Convenience doit for recompiling broken methods:..."
+ "class recompile: selector"
+ newLiterals size = oldLiterals size
+ ifFalse: [identifiedPatients add: method]
+ ifTrue:
+ [newLiterals with: oldLiterals do:
+ [:new :old|
+ (new asIEEE64BitWord = old asIEEE64BitWord
+ or: [new isNaN and: old isNaN]) ifFalse:
+ [identifiedPatients add: method]]]]]].
+ ^identifiedPatients!
Item was added:
+ ----- Method: FloatTest>>setUp (in category 'running') -----
+ setUp
+ exactInteger := 1 << (Float precision + 2).
+ float := exactInteger asFloat.
+ greaterInexactInt := exactInteger + 1.
+ smallerInexactInt := exactInteger - 1.
+ greaterFloat := float successor.
+ smallerFloat := float predecessor.
+
+ boxedFloat := Float new: 2.
+ boxedFloat basicAt: 1 put: (float basicAt: 1).
+ boxedFloat basicAt: 2 put: (float basicAt: 2).
+ greaterBoxedFloat := Float new: 2.
+ greaterBoxedFloat basicAt: 1 put: (greaterFloat basicAt: 1).
+ greaterBoxedFloat basicAt: 2 put: (greaterFloat basicAt: 2).
+ smallerBoxedFloat := Float new: 2.
+ smallerBoxedFloat basicAt: 1 put: (smallerFloat basicAt: 1).
+ smallerBoxedFloat basicAt: 2 put: (smallerFloat basicAt: 2).!
Item was added:
+ ----- Method: FloatTest>>test32bitConversion (in category 'tests - IEEE 754') -----
+ test32bitConversion
+ "Except for NaN, we can convert a 32bits float to a 64bits float exactly.
+ Thus we can convert the 64bits float to the original 32bits float pattern."
+
+ #(16r0 "zero"
+ 16r80000000 "negative zero"
+ 16r1 "min unormalized"
+ 16r12345 "a unnormalized"
+ 16r801FEDCB "a negative unnormalized"
+ 16r7FFFFF "largest unnormalized"
+ 16r800000 "smallest normalized"
+ 16r468ACDEF "a normalized float"
+ 16rCABD1234 "a negative normalized float"
+ 16r7F7FFFFF "largest finite float"
+ 16r7F800000 "positive infinity"
+ 16rFF800000 "negative infinity"
+ )
+ do: [:originalWord | self assert: (Float fromIEEE32Bit: originalWord) asIEEE32BitWord = originalWord]!
Item was added:
+ ----- Method: FloatTest>>test32bitGradualUnderflow (in category 'tests - IEEE 754') -----
+ test32bitGradualUnderflow
+ "method asIEEE32BitWord did not respect IEEE gradual underflow"
+
+ | conv expected exponentPart |
+
+ "IEEE 32 bits Float have 1 bit sign/8 bit exponent/23 bits of mantissa after leading 1
+ 2r1.mmmmmmmmmmmmmmmmmmmmmmm * (2 raisedTo: 2reeeeeeee-127) * sign
+ except when 2reeeeeeee isZero, which is a gradual underflow:
+ 2r0.mmmmmmmmmmmmmmmmmmmmmmm * (2 raisedTo: 2r00000000-126) * sign
+ and when 2reeeeeeee = 255, which is infinity if mantissa all zero or nan otherwise"
+
+ "case 1: This example is the first gradual underflow case"
+ conv := 2r0.11111111111111111111111e-126 asIEEE32BitWord.
+
+ "expected float encoded as sign/exponent/mantissa (whithout leading 1 or 0)"
+ exponentPart := 0.
+ expected := exponentPart bitOr: 2r11111111111111111111111.
+ self assert: expected = conv.
+
+ "case 2: smallest number"
+ conv := 2r0.00000000000000000000001e-126 asIEEE32BitWord.
+ expected := exponentPart bitOr: 2r1.
+ self assert: expected = conv.
+
+ "case 3: round to nearest even also in underflow cases... here round to upper"
+ conv := 2r0.000000000000000000000011e-126 asIEEE32BitWord.
+ expected := exponentPart bitOr: 2r10.
+ self assert: expected = conv.
+
+ "case 4: round to nearest even also in underflow cases... here round to lower"
+ conv := 2r0.000000000000000000000101e-126 asIEEE32BitWord.
+ expected := exponentPart bitOr: 2r10.
+ self assert: expected = conv.
+
+ "case 5: round to nearest even also in underflow cases... here round to upper"
+ conv := 2r0.0000000000000000000001011e-126 asIEEE32BitWord.
+ expected := exponentPart bitOr: 2r11.
+ self assert: expected = conv.
+ !
Item was added:
+ ----- Method: FloatTest>>test32bitRoundingMode (in category 'tests - IEEE 754') -----
+ test32bitRoundingMode
+ "method asIEEE32BitWord did not respect IEEE default rounding mode"
+
+ | conv expected exponentPart |
+
+ "IEEE 32 bits Float have 1 bit sign/8 bit exponent/23 bits of mantissa after leading 1
+ 2r1.mmmmmmmmmmmmmmmmmmmmmmm * (2 raisedTo: 2reeeeeeee-127) * sign
+ except when 2reeeeeeee isZero, which is a gradual underflow:
+ 2r0.mmmmmmmmmmmmmmmmmmmmmmm * (2 raisedTo: 2r00000000-127) * sign
+ and when 2reeeeeeee = 255, which is infinity if mantissa all zero or nan otherwise"
+
+ "This example has two extra bits in mantissa for testing rounding mode
+ case 1: should obviously round to upper"
+ conv := 2r1.0000000000000000000000111e25 asIEEE32BitWord.
+
+ "expected float encoded as sign/exponent/mantissa (whithout leading 1)"
+ exponentPart := 25+127 bitShift: 23. "127 is 2r01111111 or 16r7F"
+ expected := exponentPart bitOr: 2r10.
+ self assert: expected = conv.
+
+ "case 2: exactly in the mid point of two 32 bit float: round toward nearest even (to upper)"
+ conv := 2r1.0000000000000000000000110e25 asIEEE32BitWord.
+ expected := exponentPart bitOr: 2r10.
+ self assert: expected = conv.
+
+ "case 3: exactly in the mid point of two 32 bit float: round toward nearest even (to lower)"
+ conv := 2r1.0000000000000000000000010e25 asIEEE32BitWord.
+ expected := exponentPart bitOr: 2r0.
+ self assert: expected = conv.
+
+ "case 4: obviously round to upper"
+ conv := 2r1.0000000000000000000000011e25 asIEEE32BitWord.
+ expected := exponentPart bitOr: 2r1.
+ self assert: expected = conv.
+ !
Item was added:
+ ----- Method: FloatTest>>testArCosh (in category 'tests - mathematical functions') -----
+ testArCosh
+ self assert: 1.0 arCosh = 0.0.
+ self deny: Float infinity arCosh isFinite.
+ self assert: (2.5 arCosh cosh closeTo: 2.5).!
Item was added:
+ ----- Method: FloatTest>>testArSinh (in category 'tests - mathematical functions') -----
+ testArSinh
+ self assertIsPositiveZero: 0.0 arSinh.
+ self assertIsNegativeZero: Float negativeZero arSinh.
+ self deny: Float infinity arSinh isFinite.
+ self assert: (0.5 arSinh negated closeTo: 0.5 negated arSinh).
+ self assert: (0.5 arSinh sinh closeTo: 0.5).
+ self assert: (-2.5 arSinh sinh closeTo: -2.5).!
Item was added:
+ ----- Method: FloatTest>>testArTanh (in category 'tests - mathematical functions') -----
+ testArTanh
+ self assertIsPositiveZero: 0.0 arTanh.
+ self assertIsNegativeZero: Float negativeZero arTanh.
+ self deny: 1 arTanh isFinite.
+ self assert: (0.5 arTanh negated closeTo: 0.5 negated arTanh).
+ self assert: (0.5 arTanh tanh closeTo: 0.5).
+ self assert: (-0.5 arTanh tanh closeTo: -0.5).!
Item was added:
+ ----- Method: FloatTest>>testArcTan (in category 'tests - mathematical functions') -----
+ testArcTan
+
+ self assert: ((100 arcTan: 100) closeTo: Float pi / 4).
+ self assert: ((-100 arcTan: 100) closeTo: Float pi / -4).
+ self assert: ((100 arcTan: -100) closeTo: Float pi * 3 / 4).
+ self assert: ((-100 arcTan: -100) closeTo: Float pi * -3 / 4).
+ self assert: ((0 arcTan: 100) closeTo: 0).
+ self assert: ((0 arcTan: -100) closeTo: Float pi).
+ self assert: ((100 arcTan: 0) closeTo: Float pi / 2).
+ self assert: ((-100 arcTan: 0) closeTo: Float pi / -2).
+
+ self assert: ((Float negativeZero arcTan: 100) closeTo: 0).
+ self assert: ((Float negativeZero arcTan: -100) closeTo: Float pi * -1).
+
+ self assert: (0 arcTan: 0) = 0.
+ self assert: (Float negativeZero arcTan: 0) = 0.
+ self assert: ((0 arcTan: Float negativeZero) closeTo: Float pi).
+ self assert: ((Float negativeZero arcTan: Float negativeZero) closeTo: Float pi negated). !
Item was added:
+ ----- Method: FloatTest>>testCeiling (in category 'tests - conversion') -----
+ testCeiling
+ self assert: 1.0 ceiling = 1.
+ self assert: 1.1 ceiling = 2.
+ self assert: -2.0 ceiling = -2.
+ self assert: -2.1 ceiling = -2.!
Item was added:
+ ----- Method: FloatTest>>testCharacterization (in category 'tests - characterization') -----
+ testCharacterization
+
+ "Test the largest finite representable floating point value"
+ self assert: Float fmax successor = Float infinity.
+ self assert: Float infinity predecessor = Float fmax.
+ self assert: Float fmax negated predecessor = Float negativeInfinity.
+ self assert: Float negativeInfinity successor = Float fmax negated.
+
+ "Test the smallest positive representable floating point value"
+ self assert: Float fmin predecessor = 0.0.
+ self assert: 0.0 successor = Float fmin.
+ self assert: Float fmin negated successor = 0.0.
+ self assert: 0.0 predecessor = Float fmin negated.
+
+ "Test the relative precision"
+ self assert: Float one + Float epsilon > Float one.
+ self assert: Float one + Float epsilon = Float one successor.
+ self assert: Float one + (Float epsilon / Float radix) = Float one.
+
+ "Test maximum and minimum exponent"
+ self assert: Float fmax exponent = Float emax.
+ self assert: Float fminNormalized exponent = Float emin.
+ Float denormalized ifTrue: [
+ self assert: Float fminDenormalized exponent = (Float emin + 1 - Float precision)].
+
+ "Alternative tests for maximum and minimum"
+ self assert: (Float radix - Float epsilon) * (Float radix raisedTo: Float emax) = Float fmax.
+ self assert: Float epsilon * (Float radix raisedTo: Float emin) = Float fmin.
+
+ "Test sucessors and predecessors"
+ self assert: Float one predecessor successor = Float one.
+ self assert: Float one successor predecessor = Float one.
+ self assert: Float one negated predecessor successor = Float one negated.
+ self assert: Float one negated successor predecessor = Float one negated.
+ self assert: Float infinity successor = Float infinity.
+ self assert: Float negativeInfinity predecessor = Float negativeInfinity.
+ self assertIsNegativeZero: Float fmin negated successor.
+ self assert: Float nan predecessor isNaN.
+ self assert: Float nan successor isNaN.
+
+ "SPECIFIC FOR IEEE 754 double precision - 64 bits"
+ self assert: Float fmax hex = '7FEFFFFFFFFFFFFF'.
+ self assert: Float fminDenormalized hex = '0000000000000001'.
+ self assert: Float fminNormalized hex = '0010000000000000'.
+ self assert: 0.0 hex = '0000000000000000'.
+ self assert: Float negativeZero hex = '8000000000000000'.
+ self assert: Float one hex = '3FF0000000000000'.
+ self assert: Float infinity hex = '7FF0000000000000'.
+ self assert: Float negativeInfinity hex = 'FFF0000000000000'.!
Item was added:
+ ----- Method: FloatTest>>testClassConstants (in category 'tests - characterization') -----
+ testClassConstants
+
+ "Test all the class constants that are floats to check that they are valid.
+ Sometimes compiler bugs mean that the initialization method is incorrect, etc"
+ | expectedVariables unexpectedVariables "these two are for determining if this test is correct, not its results"
+ finiteVariables infiniteVariables nanVariables |
+ finiteVariables := #(Pi Halfpi Twopi ThreePi RadiansPerDegree Ln2 Ln10 Sqrt2 E Epsilon MaxVal MaxValLn NegativeZero).
+ infiniteVariables := #(Infinity NegativeInfinity).
+ nanVariables := #(NaN).
+ expectedVariables := Set new.
+ unexpectedVariables := Set new.
+ Float classPool keysAndValuesDo:
+ [:name :value|
+ value isFloat
+ ifTrue:
+ [(finiteVariables includes: name) ifTrue:
+ [expectedVariables add: name.
+ self assert: value isFinite.
+ self deny: value isInfinite.
+ self deny: value isNaN].
+ (infiniteVariables includes: name) ifTrue:
+ [expectedVariables add: name.
+ self deny: value isFinite.
+ self assert: value isInfinite.
+ self deny: value isNaN].
+ (nanVariables includes: name) ifTrue:
+ [expectedVariables add: name.
+ self deny: value isFinite.
+ self deny: value isInfinite.
+ self assert: value isNaN].
+ (expectedVariables includes: name) ifFalse:
+ [unexpectedVariables add: name]]
+ ifFalse:
+ [self deny: ((finiteVariables includes: name) or: [(infiniteVariables includes: name) or: [nanVariables includes: name]])]].
+ "Now check that test itself is working as intended..."
+ self assert: unexpectedVariables isEmpty.
+ self assert: expectedVariables = (finiteVariables, infiniteVariables, nanVariables) asSet!
Item was added:
+ ----- Method: FloatTest>>testCloseTo (in category 'tests - compare') -----
+ testCloseTo
+ self deny: (Float nan closeTo: Float nan) description: 'NaN isn''t close to anything'.
+ self deny: (Float nan closeTo: 1.0) description: 'NaN isn''t close to anything'.
+ self deny: (1.0 closeTo: Float nan) description: 'NaN isn''t close to anything'.
+
+ self deny: (-1.0 closeTo: 1.0).
+ self deny: (1.0 closeTo: Float infinity).
+ self assert: (Float infinity closeTo: Float infinity) description: 'since they are =, they also are closeTo:'.
+
+ self assert: (1.0/3.0 closeTo: 1/3).
+ self assert: (1.0e-8 closeTo: 0).
+ self assert: (0 closeTo: 1.0e-8).
+ self assert: (1+1.0e-8 closeTo: 1.0).
+
+ self assert: (1000000001.0 closeTo: 1000000000.0).
+ self deny: (1000000001 closeTo: 1000000000) description: 'exact representation are considered closeTo: only if equal'.!
Item was added:
+ ----- Method: FloatTest>>testCloseToFurthestCloseToNeasrest (in category 'tests - compare') -----
+ testCloseToFurthestCloseToNeasrest
+ | x nearest furthest |
+ x := 1.0e-6.
+ nearest := 1.0e-7.
+ furthest := 0.0.
+ self assert: (x - nearest) abs < (x - furthest) abs.
+ self assert: (x closeTo: furthest) ==> (x closeTo: nearest)!
Item was added:
+ ----- Method: FloatTest>>testCloseToIsSymmetric (in category 'tests - compare') -----
+ testCloseToIsSymmetric
+ self assert: ((1<<2000) reciprocal closeTo: 1.0e-6) equals: (1.0e-6 closeTo: (1<<2000) reciprocal)!
Item was added:
+ ----- Method: FloatTest>>testComparison (in category 'tests - compare') -----
+ testComparison
+
+ "test equality when Float conversion loose bits"
+ | a b c |
+ a := 16r1FFFFFFFFFFFFF1.
+ b := 16r1FFFFFFFFFFFFF3.
+ c := a asFloat.
+ self assert: ((a = c) & (b = c)) ==> (a = b).
+
+ "Test equality when Float conversion exact"
+ self assert: 16r1FFFFFFFFFFFFF = 16r1FFFFFFFFFFFFF asFloat.
+ self assert: 16r1FFFFFFFFFFFFF = 16r1FFFFFFFFFFFFF asFloat asInteger.
+
+ "Test inequality when Float conversion loose bits"
+ self assert: (((1 bitShift: 54)+1)/(1 bitShift: 54)) > 1.
+ self assert: (((1 bitShift: 54)+1)/(1 bitShift: 54)) > 1.0.
+
+ self assert: (((1 bitShift: 54)-1)/(1 bitShift: 54)) < 1.
+ self assert: (((1 bitShift: 54)-1)/(1 bitShift: 54)) < 1.0.
+
+ "Test exact vs inexact arithmetic"
+ (1 to: 100) do: [:i |
+ i isPowerOfTwo
+ ifTrue: [self assert: (1/i) = (1/i) asFloat]
+ ifFalse: [self deny: (1/i) = (1/i) asFloat]].
+
+ "Test overflow (compare to infinity)"
+ a := (11 raisedTo: 400) / 2.
+ b := (13 raisedTo: 400) / 2.
+ c := a asFloat.
+ self assert: ((a = c) & (b = c)) ==> (a = b).
+
+ "every integer is smaller than infinity"
+ self assert: a < Float infinity.
+ self assert: a > Float negativeInfinity.
+
+ "Test underflow"
+ self deny: 1 / (11 raisedTo: 400) = 0.
+ self deny: 1 / (11 raisedTo: 400) = 0.0.
+
+ "Test hash code"
+ self assert:
+ ((Set new: 3) add: 3; add: 3.0; size) =
+ ((Set new: 4) add: 3; add: 3.0; size).!
Item was added:
+ ----- Method: FloatTest>>testComparisonSmallFromBoxed (in category 'tests - compare') -----
+ testComparisonSmallFromBoxed
+ "Comparison should work the same, boxed or not"
+
+ self assert: boxedFloat = float.
+ self deny: boxedFloat ~= float.
+ self deny: boxedFloat = smallerFloat.
+ self assert: boxedFloat ~= greaterFloat.
+
+ self assert: boxedFloat < greaterFloat.
+ self assert: boxedFloat <= greaterFloat.
+ self deny: boxedFloat > greaterFloat.
+ self deny: boxedFloat >= greaterFloat.
+
+ self deny: boxedFloat < smallerFloat.
+ self deny: boxedFloat <= smallerFloat.
+ self assert: boxedFloat > smallerFloat.
+ self assert: boxedFloat >= smallerFloat.!
Item was added:
+ ----- Method: FloatTest>>testComparisonSmallWithBoxed (in category 'tests - compare') -----
+ testComparisonSmallWithBoxed
+ "Comparison should work the same, boxed or not"
+
+ self assert: float = boxedFloat.
+ self deny: float ~= boxedFloat.
+ self deny: float = smallerBoxedFloat.
+ self assert: float ~= greaterBoxedFloat.
+
+ self assert: float < greaterBoxedFloat.
+ self assert: float <= greaterBoxedFloat.
+ self deny: float > greaterBoxedFloat.
+ self deny: float >= greaterBoxedFloat.
+
+ self deny: float < smallerBoxedFloat.
+ self deny: float <= smallerBoxedFloat.
+ self assert: float > smallerBoxedFloat.
+ self assert: float >= smallerBoxedFloat.!
Item was added:
+ ----- Method: FloatTest>>testComparisonWhenPrimitiveFails (in category 'tests - compare') -----
+ testComparisonWhenPrimitiveFails
+ "This is related to http://bugs.squeak.org/view.php?id=7361"
+
+ self deny: 0.5 < (1/4).
+ self deny: 0.5 < (1/2).
+ self assert: 0.5 < (3/4).
+
+ self deny: 0.5 <= (1/4).
+ self assert: 0.5 <= (1/2).
+ self assert: 0.5 <= (3/4).
+
+ self assert: 0.5 > (1/4).
+ self deny: 0.5 > (1/2).
+ self deny: 0.5 > (3/4).
+
+ self assert: 0.5 >= (1/4).
+ self assert: 0.5 >= (1/2).
+ self deny: 0.5 >= (3/4).
+
+ self deny: 0.5 = (1/4).
+ self assert: 0.5 = (1/2).
+ self deny: 0.5 = (3/4).
+
+ self assert: 0.5 ~= (1/4).
+ self deny: 0.5 ~= (1/2).
+ self assert: 0.5 ~= (3/4).!
Item was added:
+ ----- Method: FloatTest>>testCompiledConstants (in category 'tests') -----
+ testCompiledConstants
+ "Test that any methods containing a floating point literal have been correctly compiled."
+ CurrentReadOnlySourceFiles cacheDuring:
+ [self systemNavigation allSelectorsAndMethodsDo:
+ [:class :selector :method|
+ (self methodContainsFloatLiteral: method) ifTrue:
+ [| newMethodAndNode newLiterals oldLiterals |
+ newMethodAndNode := class compile: method getSource asString notifying: nil trailer: CompiledMethodTrailer empty ifFail: nil.
+ newLiterals := self floatLiteralsIn: newMethodAndNode method.
+ oldLiterals := self floatLiteralsIn: method.
+ "Convenience doit for recompiling broken methods:..."
+ "class recompile: selector"
+ self assert: newLiterals size = oldLiterals size.
+ newLiterals with: oldLiterals do:
+ [:new :old|
+ self assert: (new asIEEE64BitWord = old asIEEE64BitWord
+ or: [new isNaN and: old isNaN])]]]]!
Item was added:
+ ----- Method: FloatTest>>testContinuedFractions (in category 'tests - arithmetic') -----
+ testContinuedFractions
+ self assert: (Float pi asApproximateFractionAtOrder: 1) = (22/7).
+ self assert: (Float pi asApproximateFractionAtOrder: 3) = (355/113)!
Item was added:
+ ----- Method: FloatTest>>testCopy (in category 'tests') -----
+ testCopy
+ "Elementary tests"
+ self assert: 2.0 copy = 2.0.
+ self assert: -0.5 copy = -0.5.
+
+ "Are exceptional Floats preserved by the copy ?"
+ self assert: Float nan copy isNaN.
+ self assert: Float infinity copy = Float infinity.
+ self assert: Float negativeInfinity copy = Float negativeInfinity.
+
+ "Is the sign of zero preserved by the copy ?"
+ self assert: 0.0 copy hex = 0.0 hex.
+ self assert: Float negativeZero copy hex = Float negativeZero hex.!
Item was added:
+ ----- Method: FloatTest>>testCopySign (in category 'tests - zero behavior') -----
+ testCopySign
+ self assert: (0.0 copySignTo: 1) = 1.
+ self assert: (Float negativeZero copySignTo: 1) = -1.
+ self assertIsNegativeZero: (-1 copySignTo: 0.0).
+ self assertIsPositiveZero: (1 copySignTo: Float negativeZero).!
Item was added:
+ ----- Method: FloatTest>>testCosh (in category 'tests - mathematical functions') -----
+ testCosh
+ self assert: (0.0 cosh closeTo: 1).
+ self deny: Float infinity cosh isFinite.
+ self assert: (2.0 cosh squared - 2.0 sinh squared closeTo: 1).
+ self assert: (2.0 cosh closeTo: 2.0 negated cosh).!
Item was added:
+ ----- Method: FloatTest>>testDegreeCos (in category 'tests - mathematical functions') -----
+ testDegreeCos
+ "Following tests use approximate equality, because cosine are generally evaluated using inexact Floating point arithmetic"
+ self assert: (45.0 degreeCos squared - 0.5) abs <= Float epsilon.
+ self assert: (60.0 degreeCos - 0.5) abs <= Float epsilon.
+ self assert: (120.0 degreeCos + 0.5) abs <= Float epsilon.
+ -360.0 to: 360.0 do: [:i |
+ self assert: (i degreeCos closeTo: i degreesToRadians cos)].
+
+ "Following tests use strict equality which is a requested property of degreeCos"
+ -10.0 to: 10.0 do: [:k |
+ self assert: (k*360 + 90) degreeCos = 0.
+ self assert: (k*360 - 90) degreeCos = 0.
+ self assert: (k*360 + 180) degreeCos + 1 = 0.
+ self assert: (k*360) degreeCos - 1 = 0.].!
Item was added:
+ ----- Method: FloatTest>>testDegreeCosForExceptionalValues (in category 'tests - mathematical functions') -----
+ testDegreeCosForExceptionalValues
+ self assert: Float nan degreeCos isNaN.
+ self assert: Float infinity degreeCos isNaN.
+ self assert: Float negativeInfinity degreeCos isNaN.!
Item was added:
+ ----- Method: FloatTest>>testDegreeSin (in category 'tests - mathematical functions') -----
+ testDegreeSin
+ "Following tests use approximate equality, because sine are generally evaluated using inexact Floating point arithmetic"
+ self assert: (45.0 degreeSin squared - 0.5) abs <= Float epsilon.
+ self assert: (30.0 degreeSin - 0.5) abs <= Float epsilon.
+ self assert: (-30.0 degreeSin + 0.5) abs <= Float epsilon.
+ -360.0 to: 360.0 do: [:i |
+ self assert: (i degreeSin closeTo: i degreesToRadians sin)].
+
+ "Following tests use strict equality which is a requested property of degreeSin"
+ -10.0 to: 10.0 do: [:k |
+ self assert: (k*360 + 90) degreeSin - 1 = 0.
+ self assert: (k*360 - 90) degreeSin + 1= 0.
+ self assert: (k*360 + 180) degreeSin = 0.
+ self assert: (k*360) degreeSin = 0.].!
Item was added:
+ ----- Method: FloatTest>>testDegreeSinForExceptionalValues (in category 'tests - mathematical functions') -----
+ testDegreeSinForExceptionalValues
+ self assert: Float nan degreeSin isNaN.
+ self assert: Float infinity degreeSin isNaN.
+ self assert: Float negativeInfinity degreeSin isNaN.!
Item was added:
+ ----- Method: FloatTest>>testDivide (in category 'tests - arithmetic') -----
+ testDivide
+
+ self assert: 1.5 / 2.0 = 0.75.
+
+ self assert: 2.0 / 1 = 2.0.
+
+ self should: [ 2.0 / 0 ] raise: ZeroDivide.
+ self should: [ 2.0 / 0.0 ] raise: ZeroDivide.
+ self should: [ 1.2 / Float negativeZero ] raise: ZeroDivide.
+ self should: [ 1.2 / (1.3 - 1.3) ] raise: ZeroDivide
+ !
Item was added:
+ ----- Method: FloatTest>>testExactComparisonFromSmallInt (in category 'tests - compare') -----
+ testExactComparisonFromSmallInt
+ "Those tests works when using naive (integer asFloat = float) comparison.
+ This is because the conversion asFloat are exact."
+
+ {float. boxedFloat} do: [:f |
+ self assert: exactInteger = f.
+ self deny: exactInteger ~= f.
+ self assert: exactInteger <= f.
+ self deny: exactInteger < f.
+ self assert: exactInteger >= f.
+ self deny: exactInteger > f].
+
+ {greaterFloat. greaterBoxedFloat} do: [:f |
+ self deny: exactInteger = f.
+ self assert: exactInteger ~= f.
+ self assert: exactInteger <= f.
+ self assert: exactInteger < f.
+ self deny: exactInteger >= f.
+ self deny: exactInteger > f].
+
+ {smallerFloat. smallerBoxedFloat} do: [:f |
+ self deny: exactInteger = f.
+ self assert: exactInteger ~= f.
+ self deny: exactInteger <= f.
+ self deny: exactInteger < f.
+ self assert: exactInteger >= f.
+ self assert: exactInteger > f].!
Item was added:
+ ----- Method: FloatTest>>testExactComparisonWithSmallInt (in category 'tests - compare') -----
+ testExactComparisonWithSmallInt
+ "Those tests works when using naive (integer asFloat = float) comparison.
+ This is because the conversion asFloat are exact."
+
+ {float. boxedFloat} do: [:f |
+ self assert: f = exactInteger.
+ self deny: f ~= exactInteger.
+ self assert: f <= exactInteger.
+ self deny: f < exactInteger.
+ self assert: f >= exactInteger.
+ self deny: f > exactInteger].
+
+ {greaterFloat. greaterBoxedFloat} do: [:f |
+ self deny: f = exactInteger.
+ self assert: f ~= exactInteger.
+ self deny: f <= exactInteger.
+ self deny: f < exactInteger.
+ self assert: f >= exactInteger.
+ self assert: f > exactInteger].
+
+ {smallerFloat. smallerBoxedFloat} do: [:f |
+ self deny: f = exactInteger.
+ self assert: f ~= exactInteger.
+ self assert: f <= exactInteger.
+ self assert: f < exactInteger.
+ self deny: f >= exactInteger.
+ self deny: f > exactInteger].!
Item was added:
+ ----- Method: FloatTest>>testFloatRounded (in category 'tests - conversion') -----
+ testFloatRounded
+ "5000000000000001 asFloat has an exact representation (no round off error).
+ It should round to nearest integer without loosing bits.
+ This is a no regression test on http://bugs.squeak.org/view.php?id=7134"
+
+ | x y int r |
+
+ "This is a preamble asserting exactness of representation
+ and quality of various conversions"
+ int := 5000000000000001.
+ x := int asFloat.
+ y := (5 asFloat squared squared squared squared timesTwoPower: 15) + 1.
+ self assert: x = y.
+ self assert: x asTrueFraction = int.
+
+ "this one should be true for any float
+ in order to conform to ISO/IEC 10967-2"
+ self assert: x rounded = x asTrueFraction rounded.
+ self assert: x negated rounded = x negated asTrueFraction rounded.
+
+ "a random test"
+ r := Random new.
+ 10000 timesRepeat: [
+ x := r next * 1.9999e16 + 1.0e12 .
+ self assert: x rounded = x asTrueFraction rounded.
+ self assert: x negated rounded = x negated asTrueFraction rounded]!
Item was added:
+ ----- Method: FloatTest>>testFloatTruncated (in category 'tests - conversion') -----
+ testFloatTruncated
+ "(10 raisedTo: 16) asFloat has an exact representation (no round off error).
+ It should convert back to integer without loosing bits.
+ This is a no regression test on http://bugs.impara.de/view.php?id=3504"
+
+ | x y int r |
+ int := 10 raisedTo: 16.
+ x := int asFloat.
+ y := (5 raisedTo: 16) asFloat timesTwoPower: 16.
+ self assert: x = y.
+
+ self assert: x asInteger = int.
+
+ "this one should be true for any float"
+ self assert: x asInteger = x asTrueFraction asInteger.
+
+ "a random test"
+ r := Random new.
+ 10000 timesRepeat: [
+ x := r next * 1.9999e16 + 1.0e12 .
+ self assert: x truncated = x asTrueFraction truncated].
+
+ "test an edge case (see https://github.com/OpenSmalltalk/opensmalltalk-vm/issues/376)"
+ self assert: SmallInteger maxVal + 1 equals: (SmallInteger maxVal + 1) asFloat asInteger!
Item was added:
+ ----- Method: FloatTest>>testFloor (in category 'tests - conversion') -----
+ testFloor
+ self assert: 1.0 floor = 1.
+ self assert: 1.1 floor = 1.
+ self assert: -2.0 floor = -2.
+ self assert: -2.1 floor = -3.!
Item was added:
+ ----- Method: FloatTest>>testFloorLog2 (in category 'tests - mathematical functions') -----
+ testFloorLog2
+ "Float internal representation of Float being in base 2, we expect (aFloat floorLog: 2) to be exact."
+
+ | aBitLess aBitMore |
+ aBitMore := 1 + Float epsilon.
+ aBitLess := 1 - Float epsilon.
+ Float emin + 1 to: Float emax - 1 do: [:exp |
+ | exactPowerOfTwo |
+ exactPowerOfTwo := 1.0 timesTwoPower: exp.
+ self assert: (exactPowerOfTwo floorLog: 2) equals: exp.
+ self assert: (exactPowerOfTwo * aBitMore floorLog: 2) equals: exp.
+ self assert: (exactPowerOfTwo * aBitLess floorLog: 2) equals: exp - 1].!
Item was added:
+ ----- Method: FloatTest>>testFractionAsExactFloat (in category 'tests - conversion') -----
+ testFractionAsExactFloat
+ {
+ 1/2.
+ 1<<Float precision - 1 / (1 << 8).
+ Float fminNormalized asFraction.
+ Float fmin asFraction * 3.
+ Float fmin asFraction.
+ }
+ do: [:f | self assert: f asExactFloat equals: f asFloat]!
Item was added:
+ ----- Method: FloatTest>>testFractionAsFloat (in category 'tests - conversion') -----
+ testFractionAsFloat
+ "use a random test"
+
+ | r m frac err collec |
+ r := Random new seed: 1234567.
+ m := (2 raisedTo: 54) - 1.
+ 200 timesRepeat: [
+ frac := ((r nextInt: m) * (r nextInt: m) + 1) / ((r nextInt: m) * (r nextInt: m) + 1).
+ err := (frac - frac asFloat asTrueFraction) * frac reciprocal * (1 bitShift: 52).
+ self assert: err < (1/2)].
+
+ collec := #(16r10000000000000 16r1FFFFFFFFFFFFF 1 2 16r20000000000000 16r20000000000001 16r3FFFFFFFFFFFFF 16r3FFFFFFFFFFFFE 16r3FFFFFFFFFFFFD).
+ collec do: [:num |
+ collec do: [:den |
+ frac := Fraction numerator: num denominator: den.
+ err := (frac - frac asFloat asTrueFraction) * frac reciprocal * (1 bitShift: 52).
+ self assert: err <= (1/2)]].!
Item was added:
+ ----- Method: FloatTest>>testFractionAsFloat2 (in category 'tests - conversion') -----
+ testFractionAsFloat2
+ "test rounding to nearest even"
+
+ self assert: ((1<<52)+0+(1/4)) asFloat asTrueFraction = ((1<<52)+0).
+ self assert: ((1<<52)+0+(1/2)) asFloat asTrueFraction = ((1<<52)+0).
+ self assert: ((1<<52)+0+(3/4)) asFloat asTrueFraction = ((1<<52)+1).
+ self assert: ((1<<52)+1+(1/4)) asFloat asTrueFraction = ((1<<52)+1).
+ self assert: ((1<<52)+1+(1/2)) asFloat asTrueFraction = ((1<<52)+2).
+ self assert: ((1<<52)+1+(3/4)) asFloat asTrueFraction = ((1<<52)+2).!
Item was added:
+ ----- Method: FloatTest>>testFractionAsFloatWithUnderflow (in category 'tests - conversion') -----
+ testFractionAsFloatWithUnderflow
+ "test rounding to nearest even"
+
+ | underflowPower |
+ underflowPower := Float emin - Float precision.
+ self assert: (2 raisedTo: underflowPower) asFloat = 0.0.
+ self assert: (2 raisedTo: underflowPower) negated asFloat = 0.0.
+ self assert: (2 raisedTo: underflowPower) negated asFloat signBit = 1 description: 'a negative underflow should return a negative zero'.!
Item was added:
+ ----- Method: FloatTest>>testFractionIsAnExactFloat (in category 'tests - conversion') -----
+ testFractionIsAnExactFloat
+ self assert: (1/2) isAnExactFloat.
+ self assert: (1<<Float precision - 1 / (1 << 8)) isAnExactFloat.
+ self assert: (Float fmin asFraction * 3) isAnExactFloat.
+ self assert: Float fmin asFraction isAnExactFloat.
+ self deny: (Float fmin asFraction / 2) isAnExactFloat.
+ self deny: (Float fmin asFraction * 3 / 2) isAnExactFloat.
+ self deny: (1 / 3) isAnExactFloat.
+ self deny: (1<<Float precision + 1 / 2) isAnExactFloat.!
Item was added:
+ ----- Method: FloatTest>>testHugeIntegerCloseTo (in category 'tests - infinity behavior') -----
+ testHugeIntegerCloseTo
+ "This is a test for bug http://bugs.squeak.org/view.php?id=7368"
+
+ "FloatTest new testHugeIntegerCloseTo"
+
+ self deny: (1.0 closeTo: 200 factorial).
+ self deny: (200 factorial closeTo: 1.0).
+ self assert: (Float infinity closeTo: 200 factorial) = (200 factorial closeTo: Float infinity).!
Item was added:
+ ----- Method: FloatTest>>testInexactComparisonFromSmallInt (in category 'tests - compare') -----
+ testInexactComparisonFromSmallInt
+ "Those tests would fail if using naive (integer asFloat = float) comparison.
+ This is because the conversion asFloat are inexact and loose bits."
+
+ {float. boxedFloat} do: [:f |
+ self deny: smallerInexactInt = f.
+ self assert: greaterInexactInt ~= f.
+
+ self assert: greaterInexactInt > f.
+ self deny: greaterInexactInt <= f.
+ self assert: smallerInexactInt < f.
+ self deny: smallerInexactInt >= f].!
Item was added:
+ ----- Method: FloatTest>>testInexactComparisonOKFromSmallInt (in category 'tests - compare') -----
+ testInexactComparisonOKFromSmallInt
+ "asFloat conversion is monotonic:
+ intA < intB ==> (intA asFloat <= intB asFloat).
+ Thus those tests would work if using naive (integer asFloat op: float) comparison,
+ even if asFloat conversion is inexact."
+
+ {greaterFloat . greaterBoxedFloat} do: [:f |
+ self deny: smallerInexactInt = f.
+ self assert: smallerInexactInt ~= f.
+
+ self assert: smallerInexactInt < f.
+ self assert: smallerInexactInt <= f.
+ self deny: smallerInexactInt > f.
+ self deny: smallerInexactInt >= f].!
Item was added:
+ ----- Method: FloatTest>>testInexactComparisonOKWithSmallInt (in category 'tests - compare') -----
+ testInexactComparisonOKWithSmallInt
+ "asFloat conversion is monotonic:
+ intA < intB ==> (intA asFloat <= intB asFloat).
+ Thus those tests would work if using naive (integer asFloat op: float) comparison,
+ even if asFloat conversion is inexact."
+
+ {smallerFloat . smallerBoxedFloat} do: [:f |
+ self deny: f = greaterInexactInt.
+ self assert: f ~= greaterInexactInt.
+
+ self assert: f < greaterInexactInt.
+ self assert: f <= greaterInexactInt.
+ self deny: f > greaterInexactInt.
+ self deny: f >= greaterInexactInt].!
Item was added:
+ ----- Method: FloatTest>>testInexactComparisonWithSmallInt (in category 'tests - compare') -----
+ testInexactComparisonWithSmallInt
+ "Those tests would fail if using naive (integer asFloat = float) comparison.
+ This is because the conversion asFloat are inexact and loose bits."
+
+ {float. boxedFloat} do: [:f |
+ self deny: f = greaterInexactInt.
+ self assert: f ~= smallerInexactInt.
+
+ self assert: f < greaterInexactInt.
+ self deny: f >= greaterInexactInt.
+ self assert: f > smallerInexactInt.
+ self deny: f <= smallerInexactInt].!
Item was added:
+ ----- Method: FloatTest>>testInfinity1 (in category 'tests - infinity behavior') -----
+ testInfinity1
+ "FloatTest new testInfinity1"
+
+ | i1 i2 |
+
+ i1 := 10000 exp.
+ i2 := 1000000000 exp.
+ self assert: i1 isInfinite & i2 isInfinite & (i1 = i2).
+ "All infinities are equal. (This is a very substantial difference to NaN's, which are never equal."
+ !
Item was added:
+ ----- Method: FloatTest>>testInfinity2 (in category 'tests - infinity behavior') -----
+ testInfinity2
+ "FloatTest new testInfinity2"
+
+ | i1 i2 |
+ i1 := 10000 exp.
+ i2 := 1000000000 exp.
+ i2 := 0 - i2. " this is entirely ok. You can compute with infinite values."
+
+ self assert: i1 isInfinite & i2 isInfinite & i1 positive & i2 negative.
+ self deny: i1 = i2.
+ "All infinities are signed. Negative infinity is not equal to Infinity"
+ !
Item was added:
+ ----- Method: FloatTest>>testInfinity3 (in category 'tests - IEEE 754') -----
+ testInfinity3
+ self assert: (Float negativeInfinity asIEEE32BitWord printPaddedWith: $0 to: 32 base: 2) =
+ '11111111100000000000000000000000'.
+ self assert: (Float fromIEEE32Bit:
+ (Integer readFrom: '11111111100000000000000000000000' readStream base: 2))
+ = Float negativeInfinity!
Item was added:
+ ----- Method: FloatTest>>testInfinityCloseTo (in category 'tests - infinity behavior') -----
+ testInfinityCloseTo
+ "This is a test for bug http://bugs.squeak.org/view.php?id=6729:"
+
+ "FloatTest new testInfinityCloseTo"
+
+ self deny: (Float infinity closeTo: Float negativeInfinity).
+ self deny: (Float negativeInfinity closeTo: Float infinity).!
Item was added:
+ ----- Method: FloatTest>>testIntegerAsFloat (in category 'tests - conversion') -----
+ testIntegerAsFloat
+ "assert IEEE 754 round to nearest even mode is honoured"
+
+ self deny: 16r1FFFFFFFFFFFF0801 asFloat = 16r1FFFFFFFFFFFF0800 asFloat. "this test is on 65 bits"
+ self deny: 16r1FFFFFFFFFFFF0802 asFloat = 16r1FFFFFFFFFFFF0800 asFloat. "this test is on 64 bits"
+ self assert: 16r1FFFFFFFFFFF1F800 asFloat = 16r1FFFFFFFFFFF20000 asFloat. "nearest even is upper"
+ self assert: 16r1FFFFFFFFFFFF0800 asFloat = 16r1FFFFFFFFFFFF0000 asFloat. "nearest even is lower"
+ !
Item was added:
+ ----- Method: FloatTest>>testIsDenormal (in category 'tests - characterization') -----
+ testIsDenormal
+ self assert: Float fminNormalized predecessor isDenormal.
+ self assert: Float fminDenormalized isDenormal.
+ self assert: Float fminDenormalized negated isDenormal.
+
+ self deny: Float fminNormalized isDenormal.
+ self deny: 0.0 isDenormal.
+ self deny: 1.0 isDenormal.
+ self deny: Float fmax isDenormal.
+ self deny: Float infinity isDenormal.
+ self deny: Float negativeInfinity isDenormal.
+ self deny: Float nan isDenormal.!
Item was added:
+ ----- Method: FloatTest>>testIsFinite (in category 'tests - characterization') -----
+ testIsFinite
+ self assert: Float fminDenormalized isFinite.
+ self assert: 0.0 isFinite.
+ self assert: Float pi negated isFinite.
+ self assert: Float fmax isFinite.
+
+ self deny: Float infinity isFinite.
+ self deny: Float negativeInfinity isFinite.
+ self deny: Float nan isFinite.!
Item was added:
+ ----- Method: FloatTest>>testIsPowerOfTwo (in category 'tests - characterization') -----
+ testIsPowerOfTwo
+
+ -1023 - 51 to: 1023 do: [ :each |
+ | n |
+ n := 1.0 timesTwoPower: each.
+ self
+ assert: n isPowerOfTwo;
+ deny: n negated isPowerOfTwo ].
+ { 0.0. 3.0. 0.3. Float nan. Float infinity } do: [ :each |
+ self
+ deny: each isPowerOfTwo;
+ deny: each negated isPowerOfTwo ].
+ !
Item was added:
+ ----- Method: FloatTest>>testIsZero (in category 'tests - zero behavior') -----
+ testIsZero
+ self assert: 0.0 isZero.
+ self assert: Float negativeZero isZero.
+ self deny: 0.1 isZero.!
Item was added:
+ ----- Method: FloatTest>>testLargeIntegerIsAnExactFloat (in category 'tests - conversion') -----
+ testLargeIntegerIsAnExactFloat
+ self assert: Float fmax asInteger isAnExactFloat.
+ self deny: (Float fmax asInteger + (Float fmax ulp / 2) asInteger) isAnExactFloat.
+ self deny: (Float fmax asInteger * 2) isAnExactFloat!
Item was added:
+ ----- Method: FloatTest>>testLargeNegativeIntegerAsFloat (in category 'tests - conversion') -----
+ testLargeNegativeIntegerAsFloat
+ "assert IEEE 754 round to nearest even mode is honoured"
+
+ self assert: SmallInteger minVal asFloat negative.
+ self assert: SmallInteger minVal isAnExactFloat description: 'this test requires this condition. If not met, change the test'.
+ self assert: SmallInteger minVal equals: SmallInteger minVal asFloat. "this test requires integrity of negative SmallInteger asFloat"
+ self assert: SmallInteger minVal asFloat - 1.0 equals: (SmallInteger minVal - 1) asFloat "same for LargeNegativeInteger"
+ !
Item was added:
+ ----- Method: FloatTest>>testLiteralEqualityOfNan (in category 'tests - compare') -----
+ testLiteralEqualityOfNan
+ | nan |
+ nan := Float nan.
+ self assert: (nan literalEqual: nan)
+ description: 'Float nan is not equal to itself, though it is literally equal'.!
Item was added:
+ ----- Method: FloatTest>>testLiteralEqualityOfZeroAndNegativeZero (in category 'tests - compare') -----
+ testLiteralEqualityOfZeroAndNegativeZero
+ self assert: 1
+ equals: (Compiler evaluate: '1>2 ifTrue: [0.0] ifFalse: [-0.0]') signBit
+ description: 'Float zero and negativeZero are not literally substituable'.!
Item was added:
+ ----- Method: FloatTest>>testLog2near1 (in category 'tests - mathematical functions') -----
+ testLog2near1
+ self assert: 1.0 predecessor ln / 2 ln equals: 1.0 predecessor log2 withinUlp: 2.
+ self assert: 1.0 successor ln / 2 ln equals: 1.0 successor log2 withinUlp: 2!
Item was added:
+ ----- Method: FloatTest>>testMaxExactInteger (in category 'tests') -----
+ testMaxExactInteger
+ "
+ FloatTest new testMaxExactInteger
+ "
+
+ self assert: Float maxExactInteger asFloat truncated = Float maxExactInteger.
+ 0 to: 10000 do: [ :j |
+ self assert: (Float maxExactInteger-j) asFloat truncated = (Float maxExactInteger-j) ].
+ self deny: (Float maxExactInteger+1) asFloat truncated = (Float maxExactInteger+1)
+ !
Item was added:
+ ----- Method: FloatTest>>testNaN1 (in category 'tests - NaN behavior') -----
+ testNaN1
+ "FloatTest new testNaN1"
+
+ self assert: Float nan == Float nan.
+ self deny: Float nan = Float nan.
+ "a NaN is not equal to itself."
+ !
Item was added:
+ ----- Method: FloatTest>>testNaN2 (in category 'tests - NaN behavior') -----
+ testNaN2
+ "Two NaN values are always considered to be different.
+ On an little-endian machine (32 bit Intel), Float nan is 16rFFF80000 16r00000000.
+ On a big-endian machine (PowerPC), Float nan is 16r7FF80000 16r00000000. Changing
+ the bit pattern of the first word of a NaN produces another value that is still
+ considered equal to NaN. This test should work on both little endian and big
+ endian machines. However, it is not guaranteed to work on future 64 bit versions
+ of Squeak, for which Float may have different internal representations."
+
+ "FloatTest new testNaN2"
+
+ | nan1 nan2 |
+ nan1 := Float nan copy.
+ nan2 := Float nan copy.
+
+ "test two instances of NaN with the same bit pattern"
+ self deny: nan1 = nan2.
+ self deny: nan1 == nan2.
+ self deny: nan1 = nan1.
+ self assert: nan1 == nan1.
+
+ "change the bit pattern of nan1"
+ self assert: nan1 size = 2.
+ self assert: (nan1 at: 2) = 0.
+ nan1 at: 1 put: (nan1 at: 1) + 999.
+ self assert: nan1 isNaN.
+ self assert: nan2 isNaN.
+ self deny: (nan1 at: 1) = (nan2 at: 1).
+
+ "test two instances of NaN with different bit patterns"
+ self deny: nan1 = nan2.
+ self deny: nan1 == nan2.
+ self deny: nan1 = nan1.
+ self assert: nan1 == nan1
+ !
Item was added:
+ ----- Method: FloatTest>>testNaN3 (in category 'tests - NaN behavior') -----
+ testNaN3
+ "FloatTest new testNaN3"
+
+ | set item identitySet |
+ set := Set new.
+ set add: (item := Float nan).
+ self deny: (set includes: item).
+ identitySet := IdentitySet new.
+ identitySet add: (item := Float nan).
+ self assert: (identitySet includes: item).
+ "as a NaN is not equal to itself, it can not be retrieved from a set"
+ !
Item was added:
+ ----- Method: FloatTest>>testNaN4 (in category 'tests - NaN behavior') -----
+ testNaN4
+ "FloatTest new testNaN4"
+
+ | dict |
+ dict := Dictionary new.
+ dict at: Float nan put: #NaN.
+ self deny: (dict includes: Float nan).
+ "as a NaN is not equal to itself, it can not be retrieved when it is used as a dictionary key"
+ !
Item was added:
+ ----- Method: FloatTest>>testNaN5 (in category 'tests - IEEE 754') -----
+ testNaN5
+ | nanstr |
+
+ "check the NaN string representation conforms to IEEE 754"
+ nanstr := Float nan asIEEE32BitWord printPaddedWith: $0 to: 32 base: 2.
+ self
+ assert: (#($0 $1) includes: (nanstr at: 1));
+ assert: (nanstr copyFrom: 2 to: 9) = '11111111';
+ assert: (#($0 $1) includes: (nanstr at: 10)); "accept both quiet and signalled NaNs"
+ assert: ((nanstr copyFrom: 11 to: 32) reject: [ :c | #($0 $1) includes: c ]) isEmpty.
+
+ "check a correct quiet NaN is created from a string"
+ self assert: (Float fromIEEE32Bit:
+ (Integer readFrom: '01111111110000000000000000000000' readStream base: 2)) isNaN!
Item was added:
+ ----- Method: FloatTest>>testNaNCompare (in category 'tests - NaN behavior') -----
+ testNaNCompare
+ "IEEE 754 states that NaN cannot be ordered.
+ As a consequence, every arithmetic comparison involving a NaN SHOULD return false.
+ Except the is different test (~=).
+ This test does verify this rule"
+
+ | compareSelectors theNaN anotherNaN comparand brokenMethods warningMessage |
+ compareSelectors := #(#< #<= #> #>= #=).
+ theNaN := Float nan.
+ anotherNaN := Float infinity - Float infinity.
+ comparand := {1. 2.3. Float infinity. 2/3. 1.25s2. 2 raisedTo: 50}.
+ comparand := comparand , (comparand collect: [:e | e negated]).
+ comparand := comparand , {theNaN. anotherNaN}.
+
+ "do a first pass to collect all broken methods"
+ brokenMethods := Set new.
+ comparand do: [:comp |
+ compareSelectors do: [:op |
+ (theNaN perform: op with: comp) ifTrue: [brokenMethods add: (theNaN class lookupSelector: op)].
+ (comp perform: op with: theNaN) ifTrue: [brokenMethods add: (comp class lookupSelector: op)]].
+ (theNaN ~= comp) ifFalse: [brokenMethods add: (theNaN class lookupSelector: #~=)].
+ (comp ~= theNaN) ifFalse: [brokenMethods add: (comp class lookupSelector: #~=)]].
+
+ "build a warning message to tell about all broken methods at once"
+ warningMessage := String streamContents: [:s |
+ s nextPutAll: 'According to IEEE 754 comparing with a NaN should always return false, except ~= that should return true.'; cr.
+ s nextPutAll: 'All these methods failed to do so. They are either broken or call a broken one'.
+ brokenMethods do: [:e | s cr; print: e methodClass; nextPutAll: '>>'; print: e selector]].
+
+ "Redo the tests so as to eventually open a debugger on one of the failures"
+ brokenMethods := Set new.
+ comparand do: [:comp2 |
+ compareSelectors do: [:op2 |
+ self deny: (theNaN perform: op2 with: comp2) description: warningMessage.
+ self deny: (comp2 perform: op2 with: theNaN) description: warningMessage].
+ self assert: (theNaN ~= comp2) description: warningMessage.
+ self assert: (comp2 ~= theNaN) description: warningMessage].!
Item was added:
+ ----- Method: FloatTest>>testNaNisLiteral (in category 'tests - NaN behavior') -----
+ testNaNisLiteral
+ self deny: Float nan isLiteral description: 'there is no literal representation of NaN'!
Item was added:
+ ----- Method: FloatTest>>testNegativeZeroAbs (in category 'tests - zero behavior') -----
+ testNegativeZeroAbs
+ self assert: Float negativeZero abs signBit = 0 description: 'the absolute value of a negative zero is zero'!
Item was added:
+ ----- Method: FloatTest>>testNegativeZeroSign (in category 'tests - zero behavior') -----
+ testNegativeZeroSign
+ self assert: Float negativeZero sign = 0.
+ self assert: Float negativeZero signBit = 1 "That's how we can distinguish from positive zero"!
Item was added:
+ ----- Method: FloatTest>>testNthRoot (in category 'tests - mathematical functions') -----
+ testNthRoot
+ "
+ FloatTest new testNthRoot
+ "
+ self should: [ -1.23 nthRoot: 4 ] raise: ArithmeticError!
Item was added:
+ ----- Method: FloatTest>>testPrintPaddedWithTo (in category 'tests - printing') -----
+ testPrintPaddedWithTo
+ "This bug was reported in http://lists.gforge.inria.fr/pipermail/pharo-users/2011-February/001569.html.
+ The problem was caused by treating the format specifier as a number rather than
+ as a string, such the the number may be a Float subject to floating point rounding
+ errors. The solution to treat the format specifier as a string, and extract the integer
+ fields before and after the decimal point in the string."
+
+ self assert: [(1.0 printPaddedWith: $0 to: 2.2) = '01.00'].
+ self assert: [(1.0 printPaddedWith: $X to: 2.2) = 'X1.0X'].
+ self assert: [(1.0 printPaddedWith: $0 to: 2) = '01.0'].
+ self assert: [(12345.6789 printPaddedWith: $0 to: 2) = '12345.6789'].
+ self assert: [(12345.6789 printPaddedWith: $0 to: 2.2) = '12345.6789'].
+ self assert: [(12.34 printPaddedWith: $0 to: 2.2) = '12.34'].
+ self assert: [(12345.6789 printPaddedWith: $0 to: 2.2) = '12345.6789'].
+ self assert: [(123.456 printPaddedWith: $X to: 4.4) = 'X123.456X'].
+ self assert: [(1.0 printPaddedWith: $0 to: 2.1) = '01.0'].
+ self assert: [(1.0 printPaddedWith: $0 to: 2.2) = '01.00'].
+ self assert: [(1.0 printPaddedWith: $0 to: 2.3) = '01.000']. "previously failed due to float usage"
+ self assert: [(1.0 printPaddedWith: $0 to: 2.4) = '01.0000']. "previously failed due to float usage"
+ self assert: [(1.0 printPaddedWith: $0 to: 2.5) = '01.00000']
+
+ !
Item was added:
+ ----- Method: FloatTest>>testRaisedTo (in category 'tests - mathematical functions') -----
+ testRaisedTo
+ "
+ FloatTest new testRaisedTo
+ "
+ self should: [ -1.23 raisedTo: 1/4 ] raise: ArithmeticError!
Item was added:
+ ----- Method: FloatTest>>testReadFromManyDigits (in category 'tests - conversion') -----
+ testReadFromManyDigits
+ "A naive algorithm may interpret these representations as Infinity or NaN.
+ This is http://bugs.squeak.org/view.php?id=6982"
+
+ | s1 s2 |
+ s1 := '1' , (String new: 321 withAll: $0) , '.0e-321'.
+ s2 := '0.' , (String new: 320 withAll: $0) , '1e321'.
+ self assert: (Number readFrom: s1) = 1.
+ self assert: (Number readFrom: s2) = 1.!
Item was added:
+ ----- Method: FloatTest>>testReciprocal (in category 'tests - arithmetic') -----
+ testReciprocal
+
+ self
+ assert: 1.0 reciprocal = 1.0;
+ assert: 2.0 reciprocal = 0.5;
+ assert: -1.0 reciprocal = -1.0;
+ assert: -2.0 reciprocal = -0.5.
+
+ self should: [ 0.0 reciprocal ] raise: ZeroDivide!
Item was added:
+ ----- Method: FloatTest>>testRounded (in category 'tests - conversion') -----
+ testRounded
+ self assert: 0.9 rounded = 1.
+ self assert: 1.0 rounded = 1.
+ self assert: 1.1 rounded = 1.
+ self assert: -1.9 rounded = -2.
+ self assert: -2.0 rounded = -2.
+ self assert: -2.1 rounded = -2.
+
+ "In case of tie, round to upper magnitude"
+ self assert: 1.5 rounded = 2.
+ self assert: -1.5 rounded = -2.!
Item was added:
+ ----- Method: FloatTest>>testSetOfFloat (in category 'tests') -----
+ testSetOfFloat
+ "Classical disagreement between hash and = did lead to a bug.
+ This is a non regression test from http://bugs.squeak.org/view.php?id=3360"
+
+ | size3 size4 |
+ size3 := (Set new: 3) add: 3; add: 3.0; size.
+ size4 := (Set new: 4) add: 3; add: 3.0; size.
+ self assert: size3 = size4 description: 'The size of a Set should not depend on its capacity.'!
Item was added:
+ ----- Method: FloatTest>>testSign (in category 'tests') -----
+ testSign
+
+ "Set up"
+ | negatives negz positives strictNegatives strictPositives zero |
+ strictPositives := {2. 2.5. Float infinity}.
+ strictNegatives := {-3. -3.25. Float negativeInfinity}.
+ zero := 0.0.
+ negz := Float negativeZero.
+ positives := strictPositives copyWith: zero.
+ negatives := strictNegatives copyWith: negz.
+
+ "The sign of non zeros"
+ strictPositives do: [:aPositive | self assert: aPositive sign = 1].
+ strictNegatives do: [:aNegative | self assert: aNegative sign = -1].
+
+ "The sign of zeros"
+ self assert: zero sign = 0.
+ self assert: negz sign = 0. "remark that negz can't be distinguished from zero and is thus considered positive..."
+ self assert: negz signBit = 1. "but we can differentiate"
+
+ "Test the copy sign functions"
+ positives do: [:aPositiveSign |
+ positives do: [:aPositive |
+ self assert: (aPositive sign: aPositiveSign) = aPositive].
+ negatives do: [:aNegative |
+ self assert: (aNegative sign: aPositiveSign) = aNegative negated].
+ (zero sign: aPositiveSign) signBit = 0.
+ (negz sign: aPositiveSign) signBit = 0].
+
+ negatives do: [:aNegativeSign |
+ positives do: [:aPositive |
+ self assert: (aPositive sign: aNegativeSign) = aPositive negated].
+ negatives do: [:aNegative |
+ self assert: (aNegative sign: aNegativeSign) = aNegative].
+ (zero sign: aNegativeSign) signBit = 1.
+ (negz sign: aNegativeSign) signBit = 1].!
Item was added:
+ ----- Method: FloatTest>>testSignificandAndExponent (in category 'tests - characterization') -----
+ testSignificandAndExponent
+ | denormals exceptionals normals |
+
+ normals := {Float pi. Float pi * 100.0. Float pi/ -100.0. Float fmax. Float fminNormalized}.
+ denormals := {0.0. Float negativeZero. Float fminNormalized predecessor. Float fmin negated}.
+ exceptionals := {Float nan. Float infinity. Float negativeInfinity.}.
+
+ normals , denormals , exceptionals do: [:aFloat |
+ "Any Float can be decomposed into its significand and exponent, and the significand holds the sign"
+ aFloat isNaN
+ ifTrue: [self assert: (aFloat significand timesTwoPower: aFloat exponent) isNaN]
+ ifFalse: [self
+ assert: (aFloat significand timesTwoPower: aFloat exponent)
+ equals: aFloat]].
+
+ normals , denormals do: [:aFloat |
+ "The significand magnitude is in interval [1.0,2.0( "
+ aFloat = 0.0
+ ifTrue: [self assert: aFloat significand equals: 0]
+ ifFalse: [self
+ assert: aFloat significand abs >= 1.0;
+ assert: aFloat significand abs < 2.0]]!
Item was added:
+ ----- Method: FloatTest>>testSignificandAsInteger (in category 'tests - characterization') -----
+ testSignificandAsInteger
+ | mantissaBits denormalPowersOfTwo denormals exceptionals normalPowersOfTwo normals |
+ "There are 52 bits used for representing the mantissa (plus an eventual leading 1, see below)"
+ mantissaBits := Float precision - 1.
+
+ normals := {Float pi. Float pi * 100.0. Float pi/ -100.0. Float fmax. Float fminNormalized}.
+ denormals := {0.0. Float negativeZero. Float fminNormalized predecessor. Float fmin negated}.
+ exceptionals := {Float nan. Float infinity. Float negativeInfinity.}.
+ normalPowersOfTwo := (-10 to: 10) collect: [:i | 1.0 timesTwoPower: i].
+ denormalPowersOfTwo := (Float emin - mantissaBits to: Float emin - 1) collect: [:i | 1.0 timesTwoPower: i].
+
+ normals do: [:aNormalFloat |
+ "Assume the mantissa is written in least 52 bits of hex format, with an implied 1 on position 53"
+ self
+ assert: (((Integer readFrom: aNormalFloat hex base: 16) bitAnd: 1<<mantissaBits-1) bitOr: 1<<mantissaBits)
+ equals: aNormalFloat significandAsInteger].
+
+ denormals , exceptionals do: [:aDenormalOrExceptionalFloat |
+ "For every other Float, zero, denormal or exceptional, no implied leading one"
+ self
+ assert: ((Integer readFrom: aDenormalOrExceptionalFloat hex base: 16) bitAnd: 1<<mantissaBits-1)
+ equals: aDenormalOrExceptionalFloat significandAsInteger].
+
+ normalPowersOfTwo do: [:aNormalPowerOfTwoFloat |
+ "The significand of a power of two is a power of two, with high bit of expected precision"
+ self assert: aNormalPowerOfTwoFloat significandAsInteger isPowerOfTwo.
+ self assert: aNormalPowerOfTwoFloat significandAsInteger highBit equals: Float precision.
+ self assert: aNormalPowerOfTwoFloat successor significandAsInteger equals: aNormalPowerOfTwoFloat significandAsInteger + 1.
+ "The last one is not true for fminNormalized"
+ aNormalPowerOfTwoFloat = Float fminNormalized or: [
+ self assert: aNormalPowerOfTwoFloat predecessor significandAsInteger equals: aNormalPowerOfTwoFloat significandAsInteger * 2 - 1]].
+
+ denormalPowersOfTwo do: [:aDenormalPowerOfTwoFloat |
+ "The significand of a denormal power of two is a power of two, just with less bits"
+ self assert: aDenormalPowerOfTwoFloat significandAsInteger isPowerOfTwo.
+ self assert: aDenormalPowerOfTwoFloat significandAsInteger highBit equals: Float precision + aDenormalPowerOfTwoFloat exponent - Float emin.
+ aDenormalPowerOfTwoFloat successor = Float fminNormalized or: [
+ self assert: aDenormalPowerOfTwoFloat successor significandAsInteger equals: aDenormalPowerOfTwoFloat significandAsInteger + 1].
+ self assert: aDenormalPowerOfTwoFloat predecessor significandAsInteger equals: aDenormalPowerOfTwoFloat significandAsInteger - 1.].
+
+ "Well known value for a few extremal cases"
+ self assert: Float fmax significandAsInteger equals: 1 << Float precision - 1.
+ self assert: Float fmin significandAsInteger equals: 1.
+ self assert: 0.0 significandAsInteger equals: 0.
+ self assert: Float infinity significandAsInteger equals: 0.
+ self assert: Float nan significandAsInteger > 0!
Item was added:
+ ----- Method: FloatTest>>testSinh (in category 'tests - mathematical functions') -----
+ testSinh
+ self assertIsPositiveZero: 0.0 sinh.
+ self assertIsNegativeZero: Float negativeZero sinh.
+ self deny: Float infinity sinh isFinite.
+ self assert: (2.0 cosh squared - 2.0 sinh squared closeTo: 1).
+ self assert: (2.0 sinh negated closeTo: 2.0 negated sinh).!
Item was added:
+ ----- Method: FloatTest>>testSqrtFallback (in category 'tests - mathematical functions') -----
+ testSqrtFallback
+ | fallBackMethod |
+ fallBackMethod := Float>>#sqrt.
+ {Float fmin. Float fmin * 2.0. Float fmin * 63.0. Float fmax. Float fmax predecessor predecessor.
+ 1.0. 2.0. 3.0. 4.0. 5.0}
+ do: [:f |
+ | s sm sp |
+ "check against the primitives - if they are absent, it does not test anything..."
+ s := fallBackMethod valueWithReceiver: f arguments: Array new.
+ self assert: s equals: f sqrt.
+
+ "in case we don't have the primitive, use exact arithmetic and a bit of logic"
+ sm := s asTrueFraction - (s ulp asTrueFraction / 2).
+ sp := s asTrueFraction + (s ulp asTrueFraction / 2).
+
+ self assert: s asTrueFraction squared < f ==> [sp squared > f]
+ description: '(s)^2 < (s+ulp/2)^2 <= f => s is more than ulp/2 away from the true square root of f'.
+ self assert: s asTrueFraction squared > f ==> [sm squared < f]
+ description: 'f <= (s-ulp/2)^2 < (s)^2 ==> s is more than ulp/2 away from the true square root of f'].
+ self assertIsNegativeZero: (fallBackMethod valueWithReceiver: Float negativeZero arguments: Array new).
+ self assertIsPositiveZero: (fallBackMethod valueWithReceiver: 0.0 arguments: Array new).
+ self assert: (fallBackMethod valueWithReceiver: Float nan arguments: Array new) isNaN.
+ self assert: (fallBackMethod valueWithReceiver: Float infinity arguments: Array new) equals: Float infinity.
+ self should: [fallBackMethod valueWithReceiver: -2.0 arguments: Array new] raise: DomainError!
Item was added:
+ ----- Method: FloatTest>>testStoreBase16 (in category 'tests - printing') -----
+ testStoreBase16
+ "This bug was reported in mantis http://bugs.squeak.org/view.php?id=6695"
+
+ self
+ assert: (20.0 storeStringBase: 16) = '16r14.0'
+ description: 'the radix prefix should not be omitted, except in base 10'!
Item was added:
+ ----- Method: FloatTest>>testStoreOn (in category 'tests') -----
+ testStoreOn
+ "If storeOn: prints exactly and the parser avoid cumulating round off Errors,
+ then Float should be read back exactly.
+ Note: there is no guarantee to restore the bit pattern of NaN though"
+
+ self assert: (Compiler evaluate: Float halfPi storeString) = Float halfPi.
+ self assert: (Compiler evaluate: Float halfPi negated storeString) = Float halfPi negated.
+ self assert: (Compiler evaluate: Float infinity storeString) = Float infinity.
+ self assert: (Compiler evaluate: Float negativeInfinity storeString) = Float negativeInfinity.
+ self assert: (Compiler evaluate: Float nan storeString) isNaN.!
Item was added:
+ ----- Method: FloatTest>>testStringAsNumber (in category 'tests - conversion') -----
+ testStringAsNumber
+ "This covers parsing in Number>>readFrom:"
+ | aFloat |
+ aFloat := '10r-12.3456' asNumber.
+ self assert: -12.3456 = aFloat.
+ aFloat := '10r-12.3456e2' asNumber.
+ self assert: -1234.56 = aFloat.
+ aFloat := '10r-12.3456d2' asNumber.
+ self assert: -1234.56 = aFloat.
+ aFloat := '10r-12.3456q2' asNumber.
+ self assert: -1234.56 = aFloat.
+ aFloat := '-12.3456q2' asNumber.
+ self assert: -1234.56 = aFloat.
+ aFloat := '12.3456q2' asNumber.
+ self assert: 1234.56 = aFloat.
+ self
+ should: [ 'invalid number' asNumber ]
+ raise: NumberParserError!
Item was added:
+ ----- Method: FloatTest>>testTanh (in category 'tests - mathematical functions') -----
+ testTanh
+ self assertIsPositiveZero: 0.0 tanh.
+ self assertIsNegativeZero: Float negativeZero tanh.
+ self assert: (Float infinity tanh closeTo: 1).
+ self assert: (2.0 cosh squared - 2.0 sinh squared closeTo: 1).
+ self assert: (2.0 tanh negated closeTo: 2.0 negated tanh).!
Item was added:
+ ----- Method: FloatTest>>testTimesTwoPowerGradualUnderflow (in category 'tests - arithmetic') -----
+ testTimesTwoPowerGradualUnderflow
+ "Here is a vicious case where timesTwoPower is inexact because it underflows.
+ And two consecutive inexact operations lead to a different result than a single one.
+ Typically expressed as multiple of Float fmin in base 2,
+ 2r1011*Float fmin shifted by -3 with round to nearest, tie to even mode:
+ -> round(1.011) -> 1.0 = fmin
+ But if first shifted by -2 then by -1:
+ -> round(10.11) -> 11.0 = 3*fmin
+ -> round(1.1) -> 10.0 = 2*fmin
+ Or first shifted by -1 then by -2:
+ -> round(101.1) -> 110.0 = 6*fmin
+ -> round(1.1) -> 10.0 = 2*fmin
+ A naive implementation that split the shift uncarefully might fail to handle such case correctly."
+ | f |
+ f := 2r1011 asFloat.
+ "scan the whole range of possible exponents for this significand"
+ Float fmin exponent + f exponent to: Float fmax exponent - f exponent
+ do:
+ [:exp |
+ | g |
+ g := f timesTwoPower: exp.
+ self assert: (g timesTwoPower: Float fmin exponent - g exponent) = Float fmin].!
Item was added:
+ ----- Method: FloatTest>>testTimesTwoPowerOverflow (in category 'tests - arithmetic') -----
+ testTimesTwoPowerOverflow
+ self assert: (Float fminNormalized timesTwoPower: Float emax - Float emin) equals: (2.0 raisedTo: Float emax).
+ self assert: (Float zero timesTwoPower: SmallInteger maxVal squared) equals: Float zero.
+ !
Item was added:
+ ----- Method: FloatTest>>testTimesTwoPowerUnderflow (in category 'tests - arithmetic') -----
+ testTimesTwoPowerUnderflow
+ self assert: ((2.0 raisedTo: Float emax) timesTwoPower: Float emin - Float emax) equals: Float fminNormalized.
+ self assert: (Float infinity timesTwoPower: SmallInteger minVal * SmallInteger maxVal) equals: Float infinity.
+ !
Item was added:
+ ----- Method: FloatTest>>testTruncated (in category 'tests - conversion') -----
+ testTruncated
+ self assert: 1.0 truncated = 1.
+ self assert: 1.1 truncated = 1.
+ self assert: -2.0 truncated = -2.
+ self assert: -2.1 truncated = -2.!
Item was added:
+ ----- Method: FloatTest>>testUlp (in category 'tests - characterization') -----
+ testUlp
+
+ {Float pi predecessor. Float pi. Float pi successor} do:
+ [:f |
+ self assert: (f * 2) ulp = (f ulp * 2).
+ self assert: (f / 2) ulp = (f ulp / 2).
+ self deny: f + f ulp = f.
+ self deny: f - f ulp = f.
+ "Tests below are valid as long as default rounding mode (to nearest even) is used"
+ self assert: f significandAsInteger odd ==> (f ulp / 2.0 + f = f successor).
+ self assert: f significandAsInteger even ==> (f ulp / 2.0 + f = f)].
+
+ self assert: 0.0 ulp = Float fmin.
+ self assert: 1.0 ulp = Float epsilon.
+ self assert: Float nan ulp isNaN.
+ self assert: Float infinity ulp = Float infinity.
+ self assert: Float negativeInfinity ulp = Float infinity.
+
+ self assert: ((0 to: Float precision - 1) allSatisfy: [:each | (Float fmin timesTwoPower: each) ulp = Float fmin]). !
Item was added:
+ ----- Method: FloatTest>>testZero1 (in category 'tests - zero behavior') -----
+ testZero1
+ "FloatTest new testZero1"
+
+ self assert: Float negativeZero = 0 asFloat.
+ self assert: (Float negativeZero at: 1) ~= (0 asFloat at: 1).
+
+ "The negative zero has a bit representation that is different from the bit representation of the positive zero. Nevertheless, both values are defined to be equal."
+ !
Item was added:
+ ----- Method: FloatTest>>testZero2 (in category 'tests - IEEE 754') -----
+ testZero2
+ self assert: (Float negativeZero asIEEE32BitWord printPaddedWith: $0 to: 32 base: 2) =
+ '10000000000000000000000000000000'.
+ self assert: (Float fromIEEE32Bit:
+ (Integer readFrom: '10000000000000000000000000000000' readStream base: 2))
+ = Float negativeZero!
Item was added:
+ ----- Method: FloatTest>>testZeroRaisedToNegativePower (in category 'tests - arithmetic') -----
+ testZeroRaisedToNegativePower
+ "this is a test related to http://bugs.squeak.org/view.php?id=6781"
+
+ self should: [0.0 raisedTo: -1] raise: ZeroDivide.
+ self should: [0.0 raisedTo: -1.0] raise: ZeroDivide.!
Item was added:
+ ClassTestCase subclass: #FractionTest
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'KernelTests-Numbers'!
Item was added:
+ ----- Method: FractionTest>>assert:classAndValueEquals: (in category 'private') -----
+ assert: a classAndValueEquals: b
+ self assert: a class = b class.
+ self assert: a = b!
Item was added:
+ ----- Method: FractionTest>>testCeiling (in category 'tests - conversions') -----
+ testCeiling
+ self assert: (3 / 2) ceiling = 2.
+ self assert: (-3 / 2) ceiling = -1.!
Item was added:
+ ----- Method: FractionTest>>testDegreeCos (in category 'tests - mathematical functions') -----
+ testDegreeCos
+ "self run: #testDegreeCos"
+
+ -361/3 to: 359/3 do: [:i |
+ self assert: (i degreeCos closeTo: i degreesToRadians cos)].!
Item was added:
+ ----- Method: FractionTest>>testDegreeSin (in category 'tests - mathematical functions') -----
+ testDegreeSin
+ "self run: #testDegreeSin"
+
+ -361/3 to: 359/3 do: [:i |
+ self assert: (i degreeSin closeTo: i degreesToRadians sin)].!
Item was added:
+ ----- Method: FractionTest>>testExactRaisedTo (in category 'tests - mathematical functions') -----
+ testExactRaisedTo
+ "
+ FractionTest new testExactRaisedTo
+ "
+ | f |
+ self assert: (4/9 raisedTo: 1/2) classAndValueEquals: 2/3.
+ self assert: (9/4 raisedTo: 1/2) classAndValueEquals: 3/2.
+ #( 1 5 29 135 1234 567890 123123123 456456456456 98765432109876543210987654321 987123987123987123987123987123987123987123987123) pairsDo: [ :a :b |
+ f := a / b.
+ self assert: (f squared raisedTo: 1/2) classAndValueEquals: f.
+ self assert: (f negated squared raisedTo: 1/2) classAndValueEquals: f.
+ f := b / a.
+ self assert: (f squared raisedTo: 1/2) classAndValueEquals: f.
+ self assert: (f negated squared raisedTo: 1/2) classAndValueEquals: f ].
+
+ self assert: (8/27 raisedTo: 1/3) classAndValueEquals: 2/3.
+ self assert: (27/8 raisedTo: 1/3) classAndValueEquals: 3/2.
+ #( 1 5 29 135 1234 567890 123123123 456456456456 98765432109876543210987654321 987123987123987123987123987123987123987123987123) pairsDo: [ :a :b |
+ f := a / b.
+ self assert: ((f raisedTo: 3) raisedTo: 1/3) classAndValueEquals: f.
+ self assert: ((f negated raisedTo: 3) raisedTo: 1/3) classAndValueEquals: f negated.
+ f := b / a.
+ self assert: ((f raisedTo: 3) raisedTo: 1/3) classAndValueEquals: f.
+ self assert: ((f negated raisedTo: 3) raisedTo: 1/3) classAndValueEquals: f negated ].
+
+ self assert: (4/9 raisedTo: 3/2) classAndValueEquals: 8/27.
+ self assert: (8/27 raisedTo: 2/3) classAndValueEquals: 4/9.
+ #( 1 5 29 135 1234 567890 123123123 456456456456 98765432109876543210987654321 987123987123987123987123987123987123987123987123) pairsDo: [ :a :b |
+ f := a / b.
+ self assert: ((f raisedTo: 3) raisedTo: 2/3) classAndValueEquals: f*f.
+ self assert: ((f raisedTo: 2) raisedTo: 3/2) classAndValueEquals: f*f*f.
+ self assert: ((f negated raisedTo: 3) raisedTo: 2/3) classAndValueEquals: f*f.
+ self assert: ((f negated raisedTo: 2) raisedTo: 3/2) classAndValueEquals: f*f*f.
+ f := b / a.
+ self assert: ((f raisedTo: 3) raisedTo: 2/3) classAndValueEquals: f*f.
+ self assert: ((f raisedTo: 2) raisedTo: 3/2) classAndValueEquals: f*f*f.
+ self assert: ((f negated raisedTo: 3) raisedTo: 2/3) classAndValueEquals: f*f.
+ self assert: ((f negated raisedTo: 2) raisedTo: 3/2) classAndValueEquals: f*f*f ].
+
+ self assert: (32/243 raisedTo: 3/5) classAndValueEquals: 8/27.
+ self assert: (8/27 raisedTo: 5/3) classAndValueEquals: 32/243.
+ #( 1 5 29 135 1234 567890 123123123 456456456456 98765432109876543210987654321 987123987123987123987123987123987123987123987123) pairsDo: [ :a :b |
+ f := a / b.
+ self assert: ((f raisedTo: 5) raisedTo: 3/5) classAndValueEquals: f*f*f.
+ self assert: ((f raisedTo: 3) raisedTo: 5/3) classAndValueEquals: f*f*f*f*f.
+ self assert: ((f negated raisedTo: 5) raisedTo: 3/5) classAndValueEquals: (f*f*f) negated.
+ self assert: ((f negated raisedTo: 3) raisedTo: 5/3) classAndValueEquals: (f*f*f*f*f) negated.
+
+ self assert: ((f raisedTo: -5) raisedTo: 3/5) classAndValueEquals: 1/(f*f*f).
+ self assert: ((f raisedTo: -3) raisedTo: 5/3) classAndValueEquals: 1/(f*f*f*f*f).
+ self assert: ((f negated raisedTo: -5) raisedTo: 3/5) classAndValueEquals: -1/(f*f*f).
+ self assert: ((f negated raisedTo: -3) raisedTo: 5/3) classAndValueEquals: -1/(f*f*f*f*f).
+ self assert: ((f raisedTo: 5) raisedTo: -3/5) classAndValueEquals: 1/(f*f*f).
+ self assert: ((f raisedTo: 3) raisedTo: -5/3) classAndValueEquals: 1/(f*f*f*f*f).
+ self assert: ((f negated raisedTo: 5) raisedTo: -3/5) classAndValueEquals: -1/(f*f*f).
+ self assert: ((f negated raisedTo: 3) raisedTo: -5/3) classAndValueEquals: -1/(f*f*f*f*f).
+
+ "No exact result => Float result"
+ self assert: ((f raisedTo: 3) +1 raisedTo: 5/3) isFloat.
+ self assert: ((f negated raisedTo: 3) -1 raisedTo: 5/3) isFloat.
+
+ f := b / a.
+ self assert: ((f raisedTo: 5) raisedTo: 3/5) classAndValueEquals: f*f*f.
+ self assert: ((f raisedTo: 3) raisedTo: 5/3) classAndValueEquals: f*f*f*f*f.
+ self assert: ((f negated raisedTo: 5) raisedTo: 3/5) classAndValueEquals: (f*f*f) negated.
+ self assert: ((f negated raisedTo: 3) raisedTo: 5/3) classAndValueEquals: (f*f*f*f*f) negated.
+
+ "No exact result => Float result"
+ self assert: ((f raisedTo: 3) +1 raisedTo: 5/3) isFloat.
+ self assert: ((f negated raisedTo: 3) -1 raisedTo: 5/3) isFloat ].!
Item was added:
+ ----- Method: FractionTest>>testExactSqrt (in category 'tests - mathematical functions') -----
+ testExactSqrt
+ "
+ FractionTest new testExactSqrt
+ "
+ | f |
+ self assert: (4/9) sqrt classAndValueEquals: 2/3.
+ #( 1 5 29 135 1234 567890 123123123 456456456456 98765432109876543210987654321 987123987123987123987123987123987123987123987123) pairsDo: [ :i :j |
+ f := i / j.
+ self assert: f squared sqrt classAndValueEquals: f.
+ f := j / i.
+ self assert: f squared sqrt classAndValueEquals: f ]!
Item was added:
+ ----- Method: FractionTest>>testFloor (in category 'tests - conversions') -----
+ testFloor
+ self assert: (3 / 2) floor = 1.
+ self assert: (-3 / 2) floor = -2.!
Item was added:
+ ----- Method: FractionTest>>testFloorLog (in category 'tests - mathematical functions') -----
+ testFloorLog
+ self assert: (1/100 floorLog: 10) = -2.
+ self assert: (((2 raisedTo: Float emax + 11)/3) floorLog: 10)
+ = ((Float emax + 11)*2 log - 3 log) floor description: 'Fraction>>log should not overflow'.
+ self assert: ((3/(2 raisedTo: Float precision - Float emin)) floorLog: 10)
+ = ((Float emin - Float precision)*2 log + 3 log) floor description: 'Fraction>>log should not underflow'!
Item was added:
+ ----- Method: FractionTest>>testFloorLogExactness (in category 'tests - mathematical functions') -----
+ testFloorLogExactness
+
+ 1 + (Float fminDenormalized floorLog: 10) to: -1 do: [:n |
+ self assert: ((10 raisedTo: n) floorLog: 10) = n].
+
+ "Float version is not exact for at least 2 reasons:
+ 1/(10 raisedTo: n) asFloat is not exact
+ (aFloat log: radix) is not exact
+
+ (1 + (Float fminDenormalized floorLog: 10) to: -1) count: [:n |
+ ((10 raisedTo: n) asFloat floorLog: 10) ~= n]."
+ !
Item was added:
+ ----- Method: FractionTest>>testFractionPrinting (in category 'tests - printing') -----
+ testFractionPrinting
+
+ self assert: (353/359) printString = '(353/359)'.
+ self assert: ((2/3) printStringBase: 2) = '(10/11)'.
+ self assert: ((2/3) storeStringBase: 2) = '(2r10/2r11)'.
+ self assert: ((5/7) printStringBase: 3) = '(12/21)'.
+ self assert: ((5/7) storeStringBase: 3) = '(3r12/3r21)'.
+ self assert: ((11/13) printStringBase: 4) = '(23/31)'.
+ self assert: ((11/13) storeStringBase: 4) = '(4r23/4r31)'.
+ self assert: ((17/19) printStringBase: 5) = '(32/34)'.
+ self assert: ((17/19) storeStringBase: 5) = '(5r32/5r34)'.
+ self assert: ((23/29) printStringBase: 6) = '(35/45)'.
+ self assert: ((23/29) storeStringBase: 6) = '(6r35/6r45)'.
+ self assert: ((31/37) printStringBase: 7) = '(43/52)'.
+ self assert: ((31/37) storeStringBase: 7) = '(7r43/7r52)'.
+ self assert: ((41/43) printStringBase: 8) = '(51/53)'.
+ self assert: ((41/43) storeStringBase: 8) = '(8r51/8r53)'.
+ self assert: ((47/53) printStringBase: 9) = '(52/58)'.
+ self assert: ((47/53) storeStringBase: 9) = '(9r52/9r58)'.
+ self assert: ((59/61) printStringBase: 10) = '(59/61)'.
+ self assert: ((59/61) storeStringBase: 10) = '(59/61)'.
+ self assert: ((67/71) printStringBase: 11) = '(61/65)'.
+ self assert: ((67/71) storeStringBase: 11) = '(11r61/11r65)'.
+ self assert: ((73/79) printStringBase: 12) = '(61/67)'.
+ self assert: ((73/79) storeStringBase: 12) = '(12r61/12r67)'.
+ self assert: ((83/89) printStringBase: 13) = '(65/6B)'.
+ self assert: ((83/89) storeStringBase: 13) = '(13r65/13r6B)'.
+ self assert: ((97/101) printStringBase: 14) = '(6D/73)'.
+ self assert: ((97/101) storeStringBase: 14) = '(14r6D/14r73)'.
+ self assert: ((103/107) printStringBase: 15) = '(6D/72)'.
+ self assert: ((103/107) storeStringBase: 15) = '(15r6D/15r72)'.
+ self assert: ((109/113) printStringBase: 16) = '(6D/71)'.
+ self assert: ((109/113) storeStringBase: 16) = '(16r6D/16r71)'.
+ self assert: ((127/131) printStringBase: 17) = '(78/7C)'.
+ self assert: ((127/131) storeStringBase: 17) = '(17r78/17r7C)'.
+ self assert: ((137/139) printStringBase: 18) = '(7B/7D)'.
+ self assert: ((137/139) storeStringBase: 18) = '(18r7B/18r7D)'.
+ self assert: ((149/151) printStringBase: 19) = '(7G/7I)'.
+ self assert: ((149/151) storeStringBase: 19) = '(19r7G/19r7I)'.
+ self assert: ((157/163) printStringBase: 20) = '(7H/83)'.
+ self assert: ((157/163) storeStringBase: 20) = '(20r7H/20r83)'.
+ self assert: ((167/173) printStringBase: 21) = '(7K/85)'.
+ self assert: ((167/173) storeStringBase: 21) = '(21r7K/21r85)'.
+ self assert: ((179/181) printStringBase: 22) = '(83/85)'.
+ self assert: ((179/181) storeStringBase: 22) = '(22r83/22r85)'.
+ self assert: ((191/193) printStringBase: 23) = '(87/89)'.
+ self assert: ((191/193) storeStringBase: 23) = '(23r87/23r89)'.
+ self assert: ((197/199) printStringBase: 24) = '(85/87)'.
+ self assert: ((197/199) storeStringBase: 24) = '(24r85/24r87)'.
+ self assert: ((211/223) printStringBase: 25) = '(8B/8N)'.
+ self assert: ((211/223) storeStringBase: 25) = '(25r8B/25r8N)'.
+ self assert: ((227/229) printStringBase: 26) = '(8J/8L)'.
+ self assert: ((227/229) storeStringBase: 26) = '(26r8J/26r8L)'.
+ self assert: ((233/239) printStringBase: 27) = '(8H/8N)'.
+ self assert: ((233/239) storeStringBase: 27) = '(27r8H/27r8N)'.
+ self assert: ((241/251) printStringBase: 28) = '(8H/8R)'.
+ self assert: ((241/251) storeStringBase: 28) = '(28r8H/28r8R)'.
+ self assert: ((257/263) printStringBase: 29) = '(8P/92)'.
+ self assert: ((257/263) storeStringBase: 29) = '(29r8P/29r92)'.
+ self assert: ((269/271) printStringBase: 30) = '(8T/91)'.
+ self assert: ((269/271) storeStringBase: 30) = '(30r8T/30r91)'.
+ self assert: ((277/281) printStringBase: 31) = '(8T/92)'.
+ self assert: ((277/281) storeStringBase: 31) = '(31r8T/31r92)'.
+ self assert: ((283/293) printStringBase: 32) = '(8R/95)'.
+ self assert: ((283/293) storeStringBase: 32) = '(32r8R/32r95)'.
+ self assert: ((307/311) printStringBase: 33) = '(9A/9E)'.
+ self assert: ((307/311) storeStringBase: 33) = '(33r9A/33r9E)'.
+ self assert: ((313/317) printStringBase: 34) = '(97/9B)'.
+ self assert: ((313/317) storeStringBase: 34) = '(34r97/34r9B)'.
+ self assert: ((331/337) printStringBase: 35) = '(9G/9M)'.
+ self assert: ((331/337) storeStringBase: 35) = '(35r9G/35r9M)'.
+ self assert: ((347/349) printStringBase: 36) = '(9N/9P)'.
+ self assert: ((347/349) storeStringBase: 36) = '(36r9N/36r9P)'.
+
+ self assert: ((-2/3) printStringBase: 2) = '(-10/11)'.
+ self assert: ((-2/3) storeStringBase: 2) = '(-2r10/2r11)'.
+ self assert: ((5 / -7) printStringBase: 3) = '(-12/21)'.
+ self assert: ((5 / -7) storeStringBase: 3) = '(-3r12/3r21)'.
+ !
Item was added:
+ ----- Method: FractionTest>>testFractionReading (in category 'tests - printing') -----
+ testFractionReading
+ "Numerator literal syntax"
+ self assert: (Fraction readFrom: '4') equals: 4.
+ self assert: (Fraction readFrom: '45') equals: 45.
+ self assert: (Fraction readFrom: '-45') equals: -45.
+ self assert: (Fraction readFrom: '4e2') equals: 400.
+ self assert: (Fraction readFrom: '33e-2') equals: 33/100.
+ self assert: (Fraction readFrom: '4r123') equals: 1 * 4 + 2 * 4 + 3.
+ self assert: (Fraction readFrom: '-4r123e5') equals: 1 * 4 + 2 * 4 + 3 * (4 raisedTo: 5) negated.
+
+ "Numerator/Denominator literals syntax"
+ self assert: (Fraction readFrom: '23/17') equals: 23/17.
+ self assert: (Fraction readFrom: '-122/17') equals: -122/17.
+ self assert: (Fraction readFrom: '-3r21e4/8r57e6') equals: (2 * 3 + 1 * (3 raisedTo: 4)) negated /(5 * 8 + 7 * (8 raisedTo: 6)).
+
+ "Decimal integer part.fraction part literal syntax"
+ self assert: (Fraction readFrom: '0.1') equals: 1/10.
+ self assert: (Fraction readFrom: '0.071') equals: 71/1000.
+ self assert: (Fraction readFrom: '-0.071e2') equals: -71/10.
+ self assert: (Fraction readFrom: '0.07100e-2') equals: 71/100000.
+
+ "Extended syntax"
+ self assert: (Fraction readFrom: '+4') equals: 4.
+ self assert: (Fraction readFrom: '.13') equals: 13/100.
+ self assert: (Fraction readFrom: '30.e-2') equals: 3/10.
+ self assert: (Fraction readFrom: '+30.e+4') equals: 300000.
+
+ "Errors"
+ self should: [(Fraction readFrom: '')] raise: Error.
+ self should: [(Fraction readFrom: '.')] raise: Error.
+ self should: [(Fraction readFrom: 'e3')] raise: Error.
+ self should: [(Fraction readFrom: '+e2')] raise: Error.
+ self should: [(Fraction readFrom: '-.e+2')] raise: Error.
+ self should: [(Fraction readFrom: '/2')] raise: Error.!
Item was added:
+ ----- Method: FractionTest>>testFractionReadingBase (in category 'tests - printing') -----
+ testFractionReadingBase
+ {17/25. -132/271. 127. -1000} do: [:fraction |
+ #(2 3 8 10 16) do: [:base |
+ | printed |
+ printed := (fraction printStringBase: base) copyWithoutAll: '()'.
+ self assert: (Fraction readFrom: printed base: base) equals: fraction]].!
Item was added:
+ ----- Method: FractionTest>>testInexactRaisedTo (in category 'tests - mathematical functions') -----
+ testInexactRaisedTo
+ "
+ FractionTest new testInexactRaisedTo
+ "
+ self assert: (((1 << 1024 + 1) / (1 << 1024 + 3)) raisedTo: 1/3) = 1.0.
+ self assert: (((1 << 1024 + 1) / (1 << 1024 + 3)) negated raisedTo: 1/3) = -1.0!
Item was added:
+ ----- Method: FractionTest>>testInexactSqrt (in category 'tests - mathematical functions') -----
+ testInexactSqrt
+ "
+ FractionTest new testInexactSqrt
+ "
+ self assert: ((1 << 1024 + 1) / (1 << 1024 + 3)) sqrt = 1.0!
Item was added:
+ ----- Method: FractionTest>>testIntegerWholeDivision (in category 'tests - arithmetic') -----
+ testIntegerWholeDivision
+
+ self assert: 4 / (2/3) classAndValueEquals: 6.
+
+ self assert: 4 / (-2/3) classAndValueEquals: -6.
+
+ self assert: -4 / (-2/3) classAndValueEquals: 6.
+
+ self assert: -4 / (2/3) classAndValueEquals: -6.!
Item was added:
+ ----- Method: FractionTest>>testIntegerWholeMultiplication (in category 'tests - arithmetic') -----
+ testIntegerWholeMultiplication
+
+ self assert: 4 * (3/2) classAndValueEquals: 6.
+
+ self assert: 4 * (-3/2) classAndValueEquals: -6.
+
+ self assert: -4 * (-3/2) classAndValueEquals: 6.
+
+ self assert: -4 * (3/2) classAndValueEquals: -6.!
Item was added:
+ ----- Method: FractionTest>>testLn (in category 'tests - mathematical functions') -----
+ testLn
+ self assert: ((1/100) ln closeTo: -2 * 10 ln).
+ self assert: (((2 raisedTo: Float emax + 11)/3) ln closeTo: (Float emax + 11)*2 ln - 3 ln) description: 'Fraction>>ln should not overflow'.
+ self assert: ((3/(2 raisedTo: Float precision - Float emin)) ln closeTo: (Float emin - Float precision)*2 ln + 3 ln) description: 'Fraction>>ln should not underflow'!
Item was added:
+ ----- Method: FractionTest>>testLog (in category 'tests - mathematical functions') -----
+ testLog
+ self assert: ((1/100) log closeTo: -2).
+ self assert: (((2 raisedTo: Float emax + 11)/3) log closeTo: (Float emax + 11)*2 log - 3 log) description: 'Fraction>>log should not overflow'.
+ self assert: ((3/(2 raisedTo: Float precision - Float emin)) log closeTo: (Float emin - Float precision)*2 log + 3 log) description: 'Fraction>>log should not underflow'!
Item was added:
+ ----- Method: FractionTest>>testNthRoot (in category 'tests - mathematical functions') -----
+ testNthRoot
+ self assert: ((-2 raisedTo: 35) / (3 raisedTo: 20) raisedTo: 1/5) equals: (-2 raisedTo: 7) / (3 raisedTo: 4).
+ self assert: (1 / (1 << 2000) raisedTo: 1/100) equals: 1 / (1 << 20)!
Item was added:
+ ----- Method: FractionTest>>testRaisedToErrorConditions (in category 'tests - mathematical functions') -----
+ testRaisedToErrorConditions
+ "
+ FractionTest new testRaisedToErrorConditions
+ "
+ self should: [ (-1/16) raisedTo: 1/4 ] raise: ArithmeticError.
+ self should: [ ((1 << 1024 + 1) / (1 << 1024 + 3)) negated raisedTo: 1/4 ] raise: ArithmeticError!
Item was added:
+ ----- Method: FractionTest>>testReciprocal (in category 'tests - arithmetic') -----
+ testReciprocal
+
+ self
+ assert: (1/2) reciprocal classAndValueEquals: 2;
+ assert: (3/4) reciprocal equals: (4/3);
+ assert: (-1/3) reciprocal classAndValueEquals: -3;
+ assert: (-3/5) reciprocal equals: (-5/3)!
Item was added:
+ ----- Method: FractionTest>>testRounded (in category 'tests - conversions') -----
+ testRounded
+ self assert: (4 / 5) rounded = 1.
+ self assert: (6 / 5) rounded = 1.
+ self assert: (-4 / 5) rounded = -1.
+ self assert: (-6 / 5) rounded = -1.
+
+ "In case of tie, round to upper magnitude"
+ self assert: (3 / 2) rounded = 2.
+ self assert: (-3 / 2) rounded = -2.!
Item was added:
+ ----- Method: FractionTest>>testSqrtErrorConditions (in category 'tests - mathematical functions') -----
+ testSqrtErrorConditions
+ "
+ FractionTest new testSqrtErrorConditions
+ "
+ self should: [ (-1/4) sqrt ] raise: DomainError.
+ self should: [ ((1 << 1024 + 1) / (1 << 1024 + 3)) negated sqrt ] raise: DomainError!
Item was added:
+ ----- Method: FractionTest>>testThatFractionDenominatorIsPositive (in category 'tests - invariants') -----
+ testThatFractionDenominatorIsPositive
+ self assert: (-3 / 2) numerator negative description: 'a Fraction sign is allways carried by its numerator'.
+ self assert: (-3 / 2) denominator positive description: 'a Fraction denominator is allways positive'.
+
+ self assert: (3 / -2) numerator negative description: 'a Fraction sign is allways carried by its numerator'.
+ self assert: (3 / -2) denominator positive description: 'a Fraction denominator is allways positive'.
+
+ self assert: (-3 / -2) numerator positive description: 'two negative signs are simplified'.
+ self assert: (-3 / -2) denominator positive description: 'a Fraction denominator is allways positive'.!
Item was added:
+ ----- Method: FractionTest>>testThatFractionIsReduced (in category 'tests - invariants') -----
+ testThatFractionIsReduced
+ self assert: (4 / 6) numerator equals: 2.
+ self assert: (4 / 6) denominator equals: 3.
+
+ self assert: (4 / 2) classAndValueEquals: 2.
+
+ "Fraction class>>#numerator:denominator: does not automatically reduce the Fraction.
+ Since it does not guaranty above invariant, it must be used with care."
+ self assert: (Fraction numerator: 4 denominator: 6) numerator equals: 4.
+ self assert: (Fraction numerator: 4 denominator: 6) denominator equals: 6.
+ self assert: (Fraction numerator: 4 denominator: 6) reduced numerator equals: 2.
+ self assert: (Fraction numerator: 4 denominator: 6) reduced denominator equals: 3.!
Item was added:
+ ----- Method: FractionTest>>testTruncated (in category 'tests - conversions') -----
+ testTruncated
+ self assert: (3 / 2) truncated = 1.
+ self assert: (-3 / 2) truncated = -1.!
Item was added:
+ ----- Method: FractionTest>>testWholeDifference (in category 'tests - arithmetic') -----
+ testWholeDifference
+
+ self assert: (2/3) - (5/3) classAndValueEquals: -1.!
Item was added:
+ ----- Method: FractionTest>>testWholeDivision (in category 'tests - arithmetic') -----
+ testWholeDivision
+
+ self assert: (3/2) / (3/4) classAndValueEquals: 2.
+
+ self assert: (3/2) / (-3/4) classAndValueEquals: -2.
+
+ self assert: (-3/2) / (-3/4) classAndValueEquals: 2.
+
+ self assert: (-3/2) / (3/4) classAndValueEquals: -2.!
Item was added:
+ ----- Method: FractionTest>>testWholeMultiplication (in category 'tests - arithmetic') -----
+ testWholeMultiplication
+
+ self assert: (3/2) * (4/3) classAndValueEquals: 2.
+
+ self assert: (3/2) * (-4/3) classAndValueEquals: -2.
+
+ self assert: (-3/2) * (-4/3) classAndValueEquals: 2.
+
+ self assert: (-3/2) * (4/3) classAndValueEquals: -2.!
Item was added:
+ ----- Method: FractionTest>>testWholeSum (in category 'tests - arithmetic') -----
+ testWholeSum
+
+ self assert: (5/3) + (1/3) classAndValueEquals: 2.!
Item was added:
+ TestCase subclass: #InstVarRefLocatorTest
+ instanceVariableNames: 'tt'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'KernelTests-Methods'!
+
+ !InstVarRefLocatorTest commentStamp: '<historical>' prior: 0!
+ This is the unit test for the class InstVarRefLocator. Unit tests are a good way to exercise the functionality of your system in a repeatable and automatic manner. They are therefore recommended if you plan to release anything. For more information, see:
+ - http://www.c2.com/cgi/wiki?UnitTest
+ - http://minnow.cc.gatech.edu/squeak/1547
+ - the sunit class category!
Item was added:
+ ----- Method: InstVarRefLocatorTest>>example1 (in category 'examples') -----
+ example1
+ | ff |
+ (1 < 2) ifTrue: [tt ifNotNil: [ff := 'hallo']].
+ ^ ff.!
Item was added:
+ ----- Method: InstVarRefLocatorTest>>example2 (in category 'examples') -----
+ example2
+ | ff|
+ ff := 1.
+ (1 < 2) ifTrue: [ff ifNotNil: [ff := 'hallo']].
+ ^ ff.!
Item was added:
+ ----- Method: InstVarRefLocatorTest>>hasInstVarRef: (in category 'private') -----
+ hasInstVarRef: aMethod
+ "Answer whether the receiver references an instance variable."
+
+ | scanner end printer |
+
+ scanner := InstructionStream on: aMethod.
+ printer := InstVarRefLocator new.
+ end := scanner method endPC.
+
+ [scanner pc <= end] whileTrue: [
+ (printer interpretNextInstructionUsing: scanner) ifTrue: [^true].
+ ].
+ ^false!
Item was added:
+ ----- Method: InstVarRefLocatorTest>>testExample1 (in category 'tests') -----
+ testExample1
+ | method |
+
+ method := self class compiledMethodAt: #example1.
+ self assert: (self hasInstVarRef: method).!
Item was added:
+ ----- Method: InstVarRefLocatorTest>>testExample2 (in category 'tests') -----
+ testExample2
+ | method |
+
+ method := self class compiledMethodAt: #example2.
+ self deny: (self hasInstVarRef: method).!
Item was added:
+ ----- Method: InstVarRefLocatorTest>>testInstructions (in category 'tests') -----
+ testInstructions
+ Object methodDict do: [:method | | scanner printer end |
+ scanner := InstructionStream on: method.
+ printer := InstVarRefLocator new.
+ end := scanner method endPC.
+
+ [scanner pc <= end] whileTrue: [
+ printer interpretNextInstructionUsing: scanner.
+ ].
+ ].!
Item was added:
+ TestCase subclass: #InstructionClientTest
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'KernelTests-Methods'!
+
+ !InstructionClientTest commentStamp: '<historical>' prior: 0!
+ This is the unit test for the class InstructionClient. Unit tests are a good way to exercise the functionality of your system in a repeatable and automatic manner. They are therefore recommended if you plan to release anything. For more information, see:
+ - http://www.c2.com/cgi/wiki?UnitTest
+ - http://minnow.cc.gatech.edu/squeak/1547
+ - the sunit class category!
Item was added:
+ ----- Method: InstructionClientTest>>testInstructions (in category 'tests') -----
+ testInstructions
+ "just interpret all of methods of Object"
+
+ | client |
+ client := InstructionClient new.
+ Object methodDict do: [:method |
+ | scanner |
+ scanner := (InstructionStream on: method).
+ [scanner pc <= method endPC] whileTrue: [
+ scanner interpretNextInstructionFor: client]].
+ !
Item was added:
+ ClassTestCase subclass: #InstructionPrinterTest
+ instanceVariableNames: 'tt'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'KernelTests-Methods'!
+
+ !InstructionPrinterTest commentStamp: '<historical>' prior: 0!
+ This is the unit test for the class InstructionPrinter. Unit tests are a good way to exercise the functionality of your system in a repeatable and automatic manner. They are therefore recommended if you plan to release anything. For more information, see:
+ - http://www.c2.com/cgi/wiki?UnitTest
+ - http://minnow.cc.gatech.edu/squeak/1547
+ - the sunit class category!
Item was added:
+ ----- Method: InstructionPrinterTest>>example1 (in category 'examples') -----
+ example1
+ | ff|
+ (1 < 2) ifTrue: [tt ifNotNil: [ff := 'hallo']].
+ ^ ff.!
Item was added:
+ ----- Method: InstructionPrinterTest>>testInstructions (in category 'tests') -----
+ testInstructions
+ "just print all of methods of Object and see if no error accours"
+
+ | printer |
+ printer := InstructionPrinter.
+ Object methodDict do: [:method |
+ String streamContents: [:stream |
+ (printer on: method) printInstructionsOn: stream]].
+ !
Item was added:
+ TestCase subclass: #IntegerDigitLogicTest
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'KernelTests-Numbers'!
Item was added:
+ ----- Method: IntegerDigitLogicTest>>testAndSingleBitWithMinusOne (in category 'tests') -----
+ testAndSingleBitWithMinusOne
+ "And a single bit with -1 and test for same value"
+ 1 to: 100 do: [:i | self assert: ((1 bitShift: i) bitAnd: -1) = (1 bitShift: i)].!
Item was added:
+ ----- Method: IntegerDigitLogicTest>>testLargeShift (in category 'tests') -----
+ testLargeShift
+ "A sanity check for LargeInteger bitShifts"
+
+ | suite |
+ suite := #( "some numbers on 64 bits or less"
+ '101101011101001100110111110110011101101101000001110110011'
+ '1101101001100010011001101110100000111011011010100011101100'
+ '101101101011110011001100110011011101011001111000100011101000'
+ '10101101101000101001111111111100101101011001011000100011100000'
+ '1000101010101001111011101010111001011111110011110001000110000000'
+ '1100101010101000010011101000110010111110110011110000000000000001' ).
+ "65 bits or less"
+ suite := suite , (suite collect: [:e | '1' , e reversed ]).
+ "129 bits or less"
+ suite := suite , (suite collect: [:e | e ,e ]).
+ suite do: [:bits | | num ls rs |
+ num := Integer readFrom: bits readStream base: 2.
+ 0 to: bits size-1 do: [:shift |
+ ls := (num bitShift: shift) printStringBase: 2.
+ rs := (num bitShift: 0-shift) printStringBase: 2.
+ self assert: ls = (bits , (String new: shift withAll: $0)).
+ self assert: rs = (bits copyFrom: 1 to: bits size - shift).
+ ]].!
Item was added:
+ ----- Method: IntegerDigitLogicTest>>testMixedSignDigitLogic (in category 'tests') -----
+ testMixedSignDigitLogic
+ "Verify that mixed sign logic with large integers works."
+ self assert: (-2 bitAnd: 16rFFFFFFFF) = 16rFFFFFFFE!
Item was added:
+ ----- Method: IntegerDigitLogicTest>>testNBitAndNNegatedEqualsN (in category 'tests') -----
+ testNBitAndNNegatedEqualsN
+ "Verify that (n bitAnd: n negated) = n for single bits"
+ | n |
+ 1 to: 100 do: [:i | n := 1 bitShift: i.
+ self assert: (n bitAnd: n negated) = n]!
Item was added:
+ ----- Method: IntegerDigitLogicTest>>testNNegatedEqualsNComplementedPlusOne (in category 'tests') -----
+ testNNegatedEqualsNComplementedPlusOne
+ "Verify that n negated = (n complemented + 1) for single bits"
+ | n |
+ 1 to: 100 do: [:i | n := 1 bitShift: i.
+ self assert: n negated = ((n bitXor: -1) + 1)]!
Item was added:
+ ----- Method: IntegerDigitLogicTest>>testShiftMinusOne1LeftThenRight (in category 'tests') -----
+ testShiftMinusOne1LeftThenRight
+ "Shift -1 left then right and test for 1"
+ 1 to: 100 do: [:i | self assert: ((-1 bitShift: i) bitShift: i negated) = -1].
+ !
Item was added:
+ ----- Method: IntegerDigitLogicTest>>testShiftOneLeftThenRight (in category 'tests') -----
+ testShiftOneLeftThenRight
+ "Shift 1 bit left then right and test for 1"
+ 1 to: 100 do: [:i | self assert: ((1 bitShift: i) bitShift: i negated) = 1].
+ !
Item was added:
+ TestCase subclass: #IntegerTest
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'KernelTests-Numbers'!
Item was added:
+ ----- Method: IntegerTest>>assert:classAndValueEquals: (in category 'private') -----
+ assert: a classAndValueEquals: b
+ self assert: a class = b class.
+ self assert: a = b!
Item was added:
+ ----- Method: IntegerTest>>testBenchFib (in category 'tests - benchmarks') -----
+ testBenchFib
+
+ self assert: (0 benchFib = 1).
+ self assert: (1 benchFib = 1).
+ self assert: (2 benchFib = 3).
+ !
Item was added:
+ ----- Method: IntegerTest>>testBigReceiverInexactNthRoot (in category 'tests - mathematical functions') -----
+ testBigReceiverInexactNthRoot
+ "
+ IntegerTest new testBigReceiverInexactNthRoot
+ "
+
+ "Inexact 3rd root (not a whole cube number), so a Float must be answered.
+ However, receiver is too big for Float arithmethic."
+ | bigNum result |
+ bigNum := (100 factorial raisedTo: 3) + 1. "Add 1 so it is not a whole cube"
+ self assert: bigNum asFloat isInfinite. "Otherwise, we chose a bad sample"
+ result := bigNum nthRoot: 3.
+ self assert: result isFloat.
+ self deny: result isInfinite.
+ self assert: result = 100 factorial asFloat. "No other float is closer. See following line"
+ self assert: 100 factorial asFloat = (100 factorial+1) asFloat!
Item was added:
+ ----- Method: IntegerTest>>testBigReceiverInexactSqrt (in category 'tests - mathematical functions') -----
+ testBigReceiverInexactSqrt
+ "
+ IntegerTest new testBigReceiverInexactSqrt
+ "
+
+ "Inexact 3rd root (not a whole cube number), so a Float must be answered.
+ However, receiver is too big for Float arithmethic."
+ | bigNum result |
+ bigNum := 100 factorial squared + 1. "Add 1 so it is not a whole square"
+ self assert: bigNum asFloat isInfinite. "Otherwise, we chose a bad sample"
+ result := bigNum sqrt.
+ self assert: result isFloat.
+ self deny: result isInfinite.
+ self assert: result = 100 factorial asFloat. "No other float is closer. See following lines"
+ self assert: (result successor asFraction squared - bigNum) abs >= (result asFraction squared - bigNum) abs.
+ self assert: (result predecessor asFraction squared - bigNum) abs >= (result asFraction squared - bigNum) abs!
Item was added:
+ ----- Method: IntegerTest>>testBitAt (in category 'tests - bitLogic') -----
+ testBitAt
+ | trials bitSequence2 |
+
+ self
+ assert: ((1 to: 100) allSatisfy: [:i | (0 bitAt: i) = 0])
+ description: 'all bits of zero are set to zero'.
+
+ self
+ assert: ((1 to: 100) allSatisfy: [:i | (-1 bitAt: i) = 1])
+ description: 'In two complements, all bits of -1 are set to 1'.
+
+
+ trials := #(
+ '2r10010011'
+ '2r11100100'
+ '2r10000000'
+ '2r0000101011011001'
+ '2r1000101011011001'
+ '2r0101010101011000'
+ '2r0010011110110010'
+ '2r0010011000000000'
+ '2r00100111101100101000101011011001'
+ '2r01110010011110110010100110101101'
+ '2r10101011101011001010000010110110'
+ '2r10101000000000000000000000000000'
+ '2r0010101110101001110010100000101101100010011110110010100010101100'
+ '2r1010101110101100101000001011011000100111101100101000101011011001'
+ '2r1010101110101000000000000000000000000000000000000000000000000000').
+ trials do: [:bitSequence | | aNumber |
+ aNumber := Number readFrom: bitSequence.
+ bitSequence2 := (bitSequence size - 2 to: 1 by: -1) inject: '2r' into: [:string :i | string copyWith: (Character digitValue: (aNumber bitAt: i))].
+ self assert: bitSequence2 = bitSequence].
+
+ trials do: [:bitSequence | | bitInvert |
+ bitInvert := -1 - (Number readFrom: bitSequence).
+ bitSequence2 := (bitSequence size - 2 to: 1 by: -1) inject: '2r' into: [:string :i | string copyWith: (Character digitValue: 1 - (bitInvert bitAt: i))].
+ self assert: bitSequence2 = bitSequence description: '-1-x is similar to a bitInvert operation in two complement']!
Item was added:
+ ----- Method: IntegerTest>>testBitCount (in category 'tests - bitLogic') -----
+ testBitCount
+ self assert: 2r0 bitCount equals: 0.
+ self assert: 2r1 bitCount equals: 1.
+ self assert: 2r101 bitCount equals: 2.
+ self assert: 2r1010000000000000000100000000000000000000000010000000000001001 bitCount equals: 6.
+
+ 1 to: 100 do: [:i |
+ self assert: (2r1 << i) bitCount equals: 1.
+ self assert: (2r101 << i) bitCount equals: 2].
+
+ self should: [-2 bitCount] raise: Error description: 'Negative integers have an infinite number of leading 1 in two complement representation'.!
Item was added:
+ ----- Method: IntegerTest>>testBitLogic (in category 'tests - bitLogic') -----
+ testBitLogic
+ "This little suite of tests is designed to verify correct operation of most
+ of Squeak's bit manipulation code, including two's complement
+ representation of negative values. It was written in a hurry and
+ is probably lacking several important checks."
+
+ "Shift 1 bit left then right and test for 1"
+ "self run: #testBitLogic"
+ | n |
+ 1 to: 100 do: [:i | self assert: ((1 bitShift: i) bitShift: i negated) = 1].
+
+ "Shift -1 left then right and test for 1"
+ 1 to: 100 do: [:i | self assert: ((-1 bitShift: i) bitShift: i negated) = -1].
+
+ "And a single bit with -1 and test for same value"
+ 1 to: 100 do: [:i | self assert: ((1 bitShift: i) bitAnd: -1) = (1 bitShift: i)].
+
+ "Verify that (n bitAnd: n negated) = n for single bits"
+ 1 to: 100 do: [:i | n := 1 bitShift: i. self assert: (n bitAnd: n negated) = n].
+
+ "Verify that n negated = (n complemented + 1) for single bits"
+ 1 to: 100 do: [:i |
+ n := 1 bitShift: i.
+ self assert: n negated = ((n bitXor: -1) + 1)].
+
+ "Verify that (n + n complemented) = -1 for single bits"
+ 1 to: 100 do: [:i |
+ n := 1 bitShift: i.
+ self assert: (n + (n bitXor: -1)) = -1].
+
+ "Verify that n negated = (n complemented +1) for single bits"
+ 1 to: 100 do: [:i |
+ n := 1 bitShift: i.
+ self assert: n negated = ((n bitXor: -1) + 1)].
+
+ self assert: (-2 bitAnd: 16rFFFFFFFF) = 16rFFFFFFFE.!
Item was added:
+ ----- Method: IntegerTest>>testBitReversal (in category 'tests - bitLogic') -----
+ testBitReversal
+ { 0. 1. SmallInteger maxVal-1. SmallInteger maxVal. SmallInteger maxVal+1. (2 raisedTo: 64)-1091. (2 raisedTo: 64)-1090. (2 raisedTo: 64)-1 } do:
+ [ : fixture |
+ | printedThenReversed reversedThenPrinted |
+ printedThenReversed := (fixture printPaddedWith: $0 to: 64 base: 2) reversed.
+ reversedThenPrinted := (fixture bitReverse: 64) printPaddedWith: $0 to: 64 base: 2.
+ self assert: printedThenReversed = reversedThenPrinted ]!
Item was added:
+ ----- Method: IntegerTest>>testCreationFromBytes1 (in category 'tests - instance creation') -----
+ testCreationFromBytes1
+ "self run: #testCreationFromBytes1"
+ "it is illegal for a LargeInteger to be less than SmallInteger maxVal."
+ "here we test that Integer>>byte!!byte2:byte3:byte4: resconstructs SmallInteger maxVal as an instance of SmallInteger. "
+
+ | maxSmallInt hexString
+ builtInteger bytes |
+ maxSmallInt := SmallInteger maxVal.
+ hexString := maxSmallInt printStringHex.
+ hexString size odd ifTrue:
+ [hexString := '0', hexString].
+ self assert: hexString size / 2 = maxSmallInt digitLength.
+ bytes := ((1 to: hexString size by: 2) collect:
+ [:i| Number readFrom: (hexString copyFrom: i to: i + 1) base: 16]) reversed.
+ builtInteger := bytes size > 4
+ ifTrue:
+ [Integer
+ byte1: (bytes at: 1) byte2: (bytes at: 2) byte3: (bytes at: 3) byte4: (bytes at: 4)
+ byte5: (bytes at: 5) byte6: (bytes at: 6) byte7: (bytes at: 7) byte8: (bytes at: 8)]
+ ifFalse:
+ [Integer
+ byte1: (bytes at: 1) byte2: (bytes at: 2) byte3: (bytes at: 3) byte4: (bytes at: 4)].
+ self assert: builtInteger = maxSmallInt.
+ self assert: builtInteger class = SmallInteger
+ !
Item was added:
+ ----- Method: IntegerTest>>testCreationFromBytes2 (in category 'tests - instance creation') -----
+ testCreationFromBytes2
+ "self run: #testCreationFromBytes2"
+
+ "it is illegal for a LargeInteger to be less than SmallInteger maxVal."
+ "here we test that Integer>>byte!!byte2:byte3:byte4: resconstructs (SmallInteger maxVal + 1) as an instance of LargePositiveInteger. "
+ | maxSmallInt hexString builtInteger bytes |
+ maxSmallInt := SmallInteger maxVal.
+ hexString := (maxSmallInt + 1) printStringHex.
+ hexString size odd ifTrue:
+ [hexString := '0', hexString].
+ self assert: hexString size / 2 = maxSmallInt digitLength.
+ bytes := ((1 to: hexString size by: 2) collect:
+ [:i| Number readFrom: (hexString copyFrom: i to: i + 1) base: 16]) reversed.
+ builtInteger := bytes size > 4
+ ifTrue:
+ [Integer
+ byte1: (bytes at: 1) byte2: (bytes at: 2) byte3: (bytes at: 3) byte4: (bytes at: 4)
+ byte5: (bytes at: 5) byte6: (bytes at: 6) byte7: (bytes at: 7) byte8: (bytes at: 8)]
+ ifFalse:
+ [Integer
+ byte1: (bytes at: 1) byte2: (bytes at: 2) byte3: (bytes at: 3) byte4: (bytes at: 4)].
+ self assert: builtInteger = (maxSmallInt + 1).
+ self deny: builtInteger class = SmallInteger
+ !
Item was added:
+ ----- Method: IntegerTest>>testCreationFromBytes3 (in category 'tests - instance creation') -----
+ testCreationFromBytes3
+ "self run: #testCreationFromBytes3"
+
+ "it is illegal for a LargeInteger to be less than SmallInteger maxVal."
+ "here we test that Integer>>byte!!byte2:byte3:byte4: resconstructs (SmallInteger maxVal - 1) as an instance of SmallInteger. "
+ | maxSmallInt hexString
+ builtInteger bytes |
+ maxSmallInt := SmallInteger maxVal.
+ hexString := (maxSmallInt - 1) printStringHex.
+ hexString size odd ifTrue:
+ [hexString := '0', hexString].
+ self assert: hexString size / 2 = maxSmallInt digitLength.
+ bytes := ((1 to: hexString size by: 2) collect:
+ [:i| Number readFrom: (hexString copyFrom: i to: i + 1) base: 16]) reversed.
+ builtInteger := bytes size > 4
+ ifTrue:
+ [Integer
+ byte1: (bytes at: 1) byte2: (bytes at: 2) byte3: (bytes at: 3) byte4: (bytes at: 4)
+ byte5: (bytes at: 5) byte6: (bytes at: 6) byte7: (bytes at: 7) byte8: (bytes at: 8)]
+ ifFalse:
+ [Integer
+ byte1: (bytes at: 1) byte2: (bytes at: 2) byte3: (bytes at: 3) byte4: (bytes at: 4)].
+ self assert: builtInteger = (maxSmallInt - 1).
+ self assert: builtInteger class = SmallInteger
+ !
Item was added:
+ ----- Method: IntegerTest>>testCrossSumBase (in category 'tests - arithmetic') -----
+ testCrossSumBase
+ "self run: #testCrossSumBase"
+
+ self assert: (
+ ((-20 to: 20) collect: [:each | each crossSumBase: 10]) asArray =
+ #(2 10 9 8 7 6 5 4 3 2 1 9 8 7 6 5 4 3 2 1 0 1 2 3 4 5 6 7 8 9 1 2 3 4 5 6 7 8 9 10 2)).
+ self assert: (
+ ((-20 to: 20) collect: [:each | each crossSumBase: 2]) asArray =
+ #(2 3 2 2 1 4 3 3 2 3 2 2 1 3 2 2 1 2 1 1 0 1 1 2 1 2 2 3 1 2 2 3 2 3 3 4 1 2 2 3 2)).
+ self should: [10 crossSumBase: 1] raise: AssertionFailure!
Item was added:
+ ----- Method: IntegerTest>>testDegreeCos (in category 'tests - mathematical functions') -----
+ testDegreeCos
+ "self run: #testDegreeCos"
+
+ "Following tests use approximate equality, because cosine are generally evaluated using inexact Floating point arithmetic"
+ self assert: (45 degreeCos squared - (1/2)) abs <= Float epsilon.
+ self assert: (60 degreeCos - (1/2)) abs <= Float epsilon.
+ self assert: (120 degreeCos + (1/2)) abs <= Float epsilon.
+ -360 to: 360 do: [:i |
+ self assert: (i degreeCos closeTo: i degreesToRadians cos)].
+
+ "Following tests use strict equality which is a requested property of degreeCos"
+ -10 to: 10 do: [:k |
+ self assert: (k*360 + 90) degreeCos = 0.
+ self assert: (k*360 - 90) degreeCos = 0.
+ self assert: (k*360 + 180) degreeCos + 1 = 0.
+ self assert: (k*360) degreeCos - 1 = 0.].!
Item was added:
+ ----- Method: IntegerTest>>testDegreeSin (in category 'tests - mathematical functions') -----
+ testDegreeSin
+ "self run: #testDegreeSin"
+
+ "Following tests use approximate equality, because sine are generally evaluated using inexact Floating point arithmetic"
+ self assert: (45 degreeSin squared - (1/2)) abs <= Float epsilon.
+ self assert: (30 degreeSin - (1/2)) abs <= Float epsilon.
+ self assert: (-30 degreeSin + (1/2)) abs <= Float epsilon.
+ -360 to: 360 do: [:i |
+ self assert: (i degreeSin closeTo: i degreesToRadians sin)].
+
+ "Following tests use strict equality which is a requested property of degreeSin"
+ -10 to: 10 do: [:k |
+ self assert: (k*360 + 90) degreeSin - 1 = 0.
+ self assert: (k*360 - 90) degreeSin + 1= 0.
+ self assert: (k*360 + 180) degreeSin = 0.
+ self assert: (k*360) degreeSin = 0].!
Item was added:
+ ----- Method: IntegerTest>>testDifferentBases (in category 'tests - instance creation') -----
+ testDifferentBases
+ "self run: #testDifferentBases"
+ "| value |
+ 2 to: 36 do: [:each|
+ value := 0.
+ 1 to: each-1 do: [:n| value := value + (n * (each raisedToInteger: n))].
+ value := value negated.
+ Transcript tab; show: 'self assert: (', value printString, ' printStringBase: ', each printString, ') = ''', (value printStringBase: each), '''.'; cr.
+ Transcript tab; show: 'self assert: (', value printString, ' radix: ', each printString, ') = ''', (value radix: each), '''.'; cr.
+ Transcript tab; show: 'self assert: ', value printString, ' printStringHex = ''', (value printStringBase: 16), '''.'; cr.
+ Transcript tab; show: 'self assert: (', value printString, ' storeStringBase: ', each printString, ') = ''', (value storeStringBase: each), '''.'; cr.
+ Transcript tab; show: 'self assert: ', value printString, ' storeStringHex = ''', (value storeStringBase: 16), '''.'; cr.
+
+
+ ].
+ "
+
+ self assert: 2r10 = 2.
+ self assert: 3r210 = 21.
+ self assert: 4r3210 = 228.
+ self assert: 5r43210 = 2930.
+ self assert: 6r543210 = 44790.
+ self assert: 7r6543210 = 800667.
+ self assert: 8r76543210 = 16434824.
+ self assert: 9r876543210 = 381367044.
+ self assert: 10r9876543210 = 9876543210.
+ self assert: 11rA9876543210 = 282458553905.
+ self assert: 12rBA9876543210 = 8842413667692.
+ self assert: 13rCBA9876543210 = 300771807240918.
+ self assert: 14rDCBA9876543210 = 11046255305880158.
+ self assert: 15rEDCBA9876543210 = 435659737878916215.
+ self assert: 16rFEDCBA9876543210 = 18364758544493064720.
+ self assert: 17rGFEDCBA9876543210 = 824008854613343261192.
+ self assert: 18rHGFEDCBA9876543210 = 39210261334551566857170.
+ self assert: 19rIHGFEDCBA9876543210 = 1972313422155189164466189.
+ self assert: 20rJIHGFEDCBA9876543210 = 104567135734072022160664820.
+ self assert: 21rKJIHGFEDCBA9876543210 = 5827980550840017565077671610.
+ self assert: 22rLKJIHGFEDCBA9876543210 = 340653664490377789692799452102.
+ self assert: 23rMLKJIHGFEDCBA9876543210 = 20837326537038308910317109288851.
+ self assert: 24rNMLKJIHGFEDCBA9876543210 = 1331214537196502869015340298036888.
+ self assert: 25rONMLKJIHGFEDCBA9876543210 = 88663644327703473714387251271141900.
+ self assert: 26rPONMLKJIHGFEDCBA9876543210 = 6146269788878825859099399609538763450.
+ self assert: 27rQPONMLKJIHGFEDCBA9876543210 = 442770531899482980347734468443677777577.
+ self assert: 28rRQPONMLKJIHGFEDCBA9876543210 = 33100056003358651440264672384704297711484.
+ self assert: 29rSRQPONMLKJIHGFEDCBA9876543210 = 2564411043271974895869785066497940850811934.
+ self assert: 30rTSRQPONMLKJIHGFEDCBA9876543210 = 205646315052919334126040428061831153388822830.
+ self assert: 31rUTSRQPONMLKJIHGFEDCBA9876543210 = 17050208381689099029767742314582582184093573615.
+ self assert: 32rVUTSRQPONMLKJIHGFEDCBA9876543210 = 1459980823972598128486511383358617792788444579872.
+ self assert: 33rWVUTSRQPONMLKJIHGFEDCBA9876543210 = 128983956064237823710866404905431464703849549412368.
+ self assert: 34rXWVUTSRQPONMLKJIHGFEDCBA9876543210 = 11745843093701610854378775891116314824081102660800418.
+ self assert: 35rYXWVUTSRQPONMLKJIHGFEDCBA9876543210 = 1101553773143634726491620528194292510495517905608180485.
+ self assert: 36rZYXWVUTSRQPONMLKJIHGFEDCBA9876543210 = 106300512100105327644605138221229898724869759421181854980.
+
+ self assert: -2r10 = -2.
+ self assert: -3r210 = -21.
+ self assert: -4r3210 = -228.
+ self assert: -5r43210 = -2930.
+ self assert: -6r543210 = -44790.
+ self assert: -7r6543210 = -800667.
+ self assert: -8r76543210 = -16434824.
+ self assert: -9r876543210 = -381367044.
+ self assert: -10r9876543210 = -9876543210.
+ self assert: -11rA9876543210 = -282458553905.
+ self assert: -12rBA9876543210 = -8842413667692.
+ self assert: -13rCBA9876543210 = -300771807240918.
+ self assert: -14rDCBA9876543210 = -11046255305880158.
+ self assert: -15rEDCBA9876543210 = -435659737878916215.
+ self assert: -16rFEDCBA9876543210 = -18364758544493064720.
+ self assert: -17rGFEDCBA9876543210 = -824008854613343261192.
+ self assert: -18rHGFEDCBA9876543210 = -39210261334551566857170.
+ self assert: -19rIHGFEDCBA9876543210 = -1972313422155189164466189.
+ self assert: -20rJIHGFEDCBA9876543210 = -104567135734072022160664820.
+ self assert: -21rKJIHGFEDCBA9876543210 = -5827980550840017565077671610.
+ self assert: -22rLKJIHGFEDCBA9876543210 = -340653664490377789692799452102.
+ self assert: -23rMLKJIHGFEDCBA9876543210 = -20837326537038308910317109288851.
+ self assert: -24rNMLKJIHGFEDCBA9876543210 = -1331214537196502869015340298036888.
+ self assert: -25rONMLKJIHGFEDCBA9876543210 = -88663644327703473714387251271141900.
+ self assert: -26rPONMLKJIHGFEDCBA9876543210 = -6146269788878825859099399609538763450.
+ self assert: -27rQPONMLKJIHGFEDCBA9876543210 = -442770531899482980347734468443677777577.
+ self assert: -28rRQPONMLKJIHGFEDCBA9876543210 = -33100056003358651440264672384704297711484.
+ self assert: -29rSRQPONMLKJIHGFEDCBA9876543210 = -2564411043271974895869785066497940850811934.
+ self assert: -30rTSRQPONMLKJIHGFEDCBA9876543210 = -205646315052919334126040428061831153388822830.
+ self assert: -31rUTSRQPONMLKJIHGFEDCBA9876543210 = -17050208381689099029767742314582582184093573615.
+ self assert: -32rVUTSRQPONMLKJIHGFEDCBA9876543210 = -1459980823972598128486511383358617792788444579872.
+ self assert: -33rWVUTSRQPONMLKJIHGFEDCBA9876543210 = -128983956064237823710866404905431464703849549412368.
+ self assert: -34rXWVUTSRQPONMLKJIHGFEDCBA9876543210 = -11745843093701610854378775891116314824081102660800418.
+ self assert: -35rYXWVUTSRQPONMLKJIHGFEDCBA9876543210 = -1101553773143634726491620528194292510495517905608180485.
+ self assert: -36rZYXWVUTSRQPONMLKJIHGFEDCBA9876543210 = -106300512100105327644605138221229898724869759421181854980.!
Item was added:
+ ----- Method: IntegerTest>>testEven (in category 'tests - basic') -----
+ testEven
+
+ self deny: (1073741825 even).
+ self assert: (1073741824 even).
+ !
Item was added:
+ ----- Method: IntegerTest>>testExactRaisedTo (in category 'tests - mathematical functions') -----
+ testExactRaisedTo
+ "
+ IntegerTest new testExactRaisedTo
+ "
+ self assert: (4 raisedTo: 1/2) classAndValueEquals: 2.
+ self assert: (9 raisedTo: 1/2) classAndValueEquals: 3.
+ self assert: (9 raisedTo: -1/2) classAndValueEquals: 1/3.
+ self assert: (-1 raisedTo: 1/3) classAndValueEquals: -1.
+ #( 1 5 29 135 1234 567890 123123123 456456456456 98765432109876543210987654321 987123987123987123987123987123987123987123987123) do: [ :i |
+ self assert: (i squared raisedTo: 1/2) classAndValueEquals: i.
+ self assert: (i negated squared raisedTo: 1/2) classAndValueEquals: i ].
+
+ self assert: (8 raisedTo: 1/3) classAndValueEquals: 2.
+ self assert: (27 raisedTo: 1/3) classAndValueEquals: 3.
+ #( 1 5 29 135 1234 567890 123123123 456456456456 98765432109876543210987654321 987123987123987123987123987123987123987123987123) do: [ :i |
+ self assert: ((i raisedTo: 3) raisedTo: 1/3) classAndValueEquals: i.
+ self assert: ((i negated raisedTo: 3) raisedTo: 1/3) classAndValueEquals: i negated ].
+
+ self assert: (4 raisedTo: 3/2) classAndValueEquals: 8.
+ self assert: (8 raisedTo: 2/3) classAndValueEquals: 4.
+ self assert: (8 raisedTo: -2/3) classAndValueEquals: 1/4.
+ #( 1 5 29 135 1234 567890 123123123 456456456456 98765432109876543210987654321 987123987123987123987123987123987123987123987123) do: [ :i |
+ self assert: ((i raisedTo: 3) raisedTo: 2/3) classAndValueEquals: i*i.
+ self assert: ((i raisedTo: 2) raisedTo: 3/2) classAndValueEquals: i*i*i.
+ self assert: ((i negated raisedTo: 3) raisedTo: 2/3) classAndValueEquals: i*i.
+ self assert: ((i negated raisedTo: 2) raisedTo: 3/2) classAndValueEquals: i*i*i ].
+
+ self assert: (32 raisedTo: 3/5) classAndValueEquals: 8.
+ self assert: (8 raisedTo: 5/3) classAndValueEquals: 32.
+ #( 1 5 29 135 1234 567890 123123123 456456456456 98765432109876543210987654321 987123987123987123987123987123987123987123987123) do: [ :i |
+ self assert: ((i raisedTo: 5) raisedTo: 3/5) classAndValueEquals: i*i*i.
+ self assert: ((i raisedTo: 3) raisedTo: 5/3) classAndValueEquals: i*i*i*i*i.
+ self assert: ((i negated raisedTo: 5) raisedTo: 3/5) classAndValueEquals: (i*i*i) negated.
+ self assert: ((i negated raisedTo: 3) raisedTo: 5/3) classAndValueEquals: (i*i*i*i*i) negated.
+
+ self assert: ((i raisedTo: -5) raisedTo: 3/5) classAndValueEquals: 1/(i*i*i).
+ self assert: ((i raisedTo: -3) raisedTo: 5/3) classAndValueEquals: 1/(i*i*i*i*i).
+ self assert: ((i negated raisedTo: -5) raisedTo: 3/5) classAndValueEquals: -1/(i*i*i).
+ self assert: ((i negated raisedTo: -3) raisedTo: 5/3) classAndValueEquals: -1/(i*i*i*i*i).
+
+ self assert: ((i raisedTo: 5) raisedTo: -3/5) classAndValueEquals: 1/(i*i*i).
+ self assert: ((i raisedTo: 3) raisedTo: -5/3) classAndValueEquals: 1/(i*i*i*i*i).
+ self assert: ((i negated raisedTo: 5) raisedTo: -3/5) classAndValueEquals: -1/(i*i*i).
+ self assert: ((i negated raisedTo: 3) raisedTo: -5/3) classAndValueEquals: -1/(i*i*i*i*i).
+
+ "No exact result => Float result"
+ self assert: ((i raisedTo: 3) +1 raisedTo: 5/3) isFloat.
+ self assert: ((i negated raisedTo: 3) -1 raisedTo: 5/3) isFloat ].!
Item was added:
+ ----- Method: IntegerTest>>testExactSqrt (in category 'tests - mathematical functions') -----
+ testExactSqrt
+ "
+ IntegerTest new testExactSqrt
+ "
+ self assert: 4 sqrt classAndValueEquals: 2.
+ self assert: 9 sqrt classAndValueEquals: 3.
+ self assert: Float maxExactInteger squared sqrt classAndValueEquals: Float maxExactInteger.
+ self assert: (Float maxExactInteger+1) squared sqrt classAndValueEquals: Float maxExactInteger+1.
+ #( 1 5 29 135 1234 567890 123123123 456456456456 98765432109876543210987654321 987123987123987123987123987123987123987123987123) do: [ :i |
+ self assert: i squared sqrt classAndValueEquals: i ]!
Item was added:
+ ----- Method: IntegerTest>>testFloorLog (in category 'tests - mathematical functions') -----
+ testFloorLog
+ self assert: (100 floorLog: 10) = 2.
+ self assert: (((2 raisedTo: Float emax + 3) floorLog: 10) = (2 log*(Float emax + 3)) floor) description: 'Integer>>floorLog: should not overflow'!
Item was added:
+ ----- Method: IntegerTest>>testFloorLogExactness (in category 'tests - mathematical functions') -----
+ testFloorLogExactness
+
+ 1 to: (Float fmax floorLog: 10) do: [:n |
+ self assert: ((10 raisedTo: n) floorLog: 10) = n].
+
+ "Float version is not exact for at least 2 reasons:
+ (10 raisedTo: n) asFloat is not exact for n > 22
+ (aFloat log: radix) is not exact
+
+ (1 to: (Float fmax floorLog: 10)) count: [:n |
+ ((10 raisedTo: n) asFloat floorLog: 10) ~= n]."!
Item was added:
+ ----- Method: IntegerTest>>testHighBit (in category 'tests - bitLogic') -----
+ testHighBit
+ | suite |
+
+ suite := (0 to: 1024) asArray , #(16rFDFD 16rFFFF 16r1000 16r1000000 16r1000001 16r70000000 16r7AFAFAFA ) , {SmallInteger maxVal . SmallInteger maxVal+1}.
+ suite := suite , (suite collect: [:e | e raisedTo: 20]).
+
+ suite do: [:anInteger |
+ | highBit shifted |
+ highBit := 0.
+ shifted := 1.
+ [shifted > anInteger] whileFalse: [highBit := highBit+1. shifted := shifted bitShift: 1].
+ self assert: anInteger highBit = highBit].!
Item was added:
+ ----- Method: IntegerTest>>testHighBitOfMagnitude (in category 'tests - bitLogic') -----
+ testHighBitOfMagnitude
+ | suite |
+
+ suite := (0 to: 1024) asArray , #(16rFDFD 16rFFFF 16r1000 16r1000000 16r1000001 16r70000000 16r7AFAFAFA ) , {SmallInteger maxVal . SmallInteger maxVal+1}.
+ suite := suite , (suite collect: [:e | e raisedTo: 20]).
+
+ suite do: [:anInteger |
+ | highBit shifted |
+ highBit := 0.
+ shifted := 1.
+ [shifted > anInteger] whileFalse: [highBit := highBit+1. shifted := shifted bitShift: 1].
+ self assert: anInteger highBitOfMagnitude = highBit.
+ self assert: anInteger negated highBitOfMagnitude = highBit].!
Item was added:
+ ----- Method: IntegerTest>>testIntegerDivision (in category 'tests - arithmetic') -----
+ testIntegerDivision
+ | suite |
+ suite := #( 1 2 5 1000 123456798 111222333444555 987654321098765432109876 ).
+ suite := suite , (suite collect: [:e | e negated]).
+ suite do: [:a |
+ suite do: [:b |
+ | q r |
+ q := a // b.
+ r := a \\ b.
+ self assert: b * q + r = a.
+ self assert: r abs < b abs.
+ self assert: (r isZero or: [b negative = r negative])]].!
Item was added:
+ ----- Method: IntegerTest>>testIntegerPadding (in category 'tests - printing') -----
+ testIntegerPadding
+ "self run: #testIntegerPadding"
+
+ self assert: (1 printStringBase: 10 length: 0 padded: false) = '1'.
+ self assert: (1 printStringBase: 10 length: 1 padded: false) = '1'.
+ self assert: (1 printStringBase: 10 length: 2 padded: false) = ' 1'.
+ self assert: (1024 printStringBase: 10 length: 19 padded: false) = ' 1024'.
+ self assert: (1024 printStringBase: 10 length: -1 padded: false) = '1024'.
+ self assert: (1024 printStringBase: 10 length: 5 padded: false) = ' 1024'.
+ self assert: (-1024 printStringBase: 10 length: 5 padded: false) = '-1024'.
+ self assert: (-1024 printStringBase: 10 length: 19 padded: false) = ' -1024'.
+
+ self assert: (1 printStringBase: 10 length: 0 padded: true) = '1'.
+ self assert: (1 printStringBase: 10 length: 1 padded: true) = '1'.
+ self assert: (1 printStringBase: 10 length: 2 padded: true) = '01'.
+ self assert: (1024 printStringBase: 10 length: 19 padded: true) = '0000000000000001024'.
+ self assert: (1024 printStringBase: 10 length: -1 padded: true) = '1024'.
+ self assert: (1024 printStringBase: 10 length: 5 padded: true) = '01024'.
+ self assert: (-1024 printStringBase: 10 length: 5 padded: true) = '-1024'.
+ self assert: (-1024 printStringBase: 10 length: 19 padded: true) = '-000000000000001024'.
+
+ self assert: (1 printStringBase: 16 length: 0 padded: false) = '1'.
+ self assert: (1 printStringBase: 16 length: 1 padded: false) = '1'.
+ self assert: (1 printStringBase: 16 length: 2 padded: false) = ' 1'.
+ self assert: (2047 printStringBase: 16 length: 19 padded: false) = ' 7FF'.
+ self assert: (2047 printStringBase: 16 length: -1 padded: false) = '7FF'.
+ self assert: (2047 printStringBase: 16 length: 4 padded: false) = ' 7FF'.
+ self assert: (-2047 printStringBase: 16 length: 4 padded: false) = '-7FF'.
+ self assert: (-2047 printStringBase: 16 length: 19 padded: false) = ' -7FF'.
+
+ self assert: (1 printStringBase: 16 length: 0 padded: true) = '1'.
+ self assert: (1 printStringBase: 16 length: 1 padded: true) = '1'.
+ self assert: (1 printStringBase: 16 length: 2 padded: true) = '01'.
+ self assert: (2047 printStringBase: 16 length: 19 padded: true) = '00000000000000007FF'.
+ self assert: (2047 printStringBase: 16 length: -1 padded: true) = '7FF'.
+ self assert: (2047 printStringBase: 16 length: 4 padded: true) = '07FF'.
+ self assert: (-2047 printStringBase: 16 length: 4 padded: true) = '-7FF'.
+ self assert: (-2047 printStringBase: 16 length: 19 padded: true) = '-0000000000000007FF'.
+
+ self assert: (1 storeStringBase: 10 length: 0 padded: false) = '1'.
+ self assert: (1 storeStringBase: 10 length: 1 padded: false) = '1'.
+ self assert: (1 storeStringBase: 10 length: 2 padded: false) = ' 1'.
+ self assert: (1024 storeStringBase: 10 length: 19 padded: false) = ' 1024'.
+ self assert: (1024 storeStringBase: 10 length: -1 padded: false) = '1024'.
+ self assert: (1024 storeStringBase: 10 length: 5 padded: false) = ' 1024'.
+ self assert: (-1024 storeStringBase: 10 length: 5 padded: false) = '-1024'.
+ self assert: (-1024 storeStringBase: 10 length: 19 padded: false) = ' -1024'.
+
+ self assert: (1 storeStringBase: 10 length: 0 padded: true) = '1'.
+ self assert: (1 storeStringBase: 10 length: 1 padded: true) = '1'.
+ self assert: (1 storeStringBase: 10 length: 2 padded: true) = '01'.
+ self assert: (1024 storeStringBase: 10 length: 19 padded: true) = '0000000000000001024'.
+ self assert: (1024 storeStringBase: 10 length: -1 padded: true) = '1024'.
+ self assert: (1024 storeStringBase: 10 length: 5 padded: true) = '01024'.
+ self assert: (-1024 storeStringBase: 10 length: 5 padded: true) = '-1024'.
+ self assert: (-1024 storeStringBase: 10 length: 19 padded: true) = '-000000000000001024'.
+
+ self assert: (1 storeStringBase: 16 length: 0 padded: false) = '16r1'.
+ self assert: (1 storeStringBase: 16 length: 4 padded: false) = '16r1'.
+ self assert: (1 storeStringBase: 16 length: 5 padded: false) = ' 16r1'.
+ self assert: (2047 storeStringBase: 16 length: 19 padded: false) = ' 16r7FF'.
+ self assert: (2047 storeStringBase: 16 length: -1 padded: false) = '16r7FF'.
+ self assert: (2047 storeStringBase: 16 length: 7 padded: false) = ' 16r7FF'.
+ self assert: (-2047 storeStringBase: 16 length: 7 padded: false) = '-16r7FF'.
+ self assert: (-2047 storeStringBase: 16 length: 19 padded: false) = ' -16r7FF'.
+
+ self assert: (1 storeStringBase: 16 length: 0 padded: true) = '16r1'.
+ self assert: (1 storeStringBase: 16 length: 4 padded: true) = '16r1'.
+ self assert: (1 storeStringBase: 16 length: 5 padded: true) = '16r01'.
+ self assert: (2047 storeStringBase: 16 length: 19 padded: true) = '16r00000000000007FF'.
+ self assert: (2047 storeStringBase: 16 length: -1 padded: true) = '16r7FF'.
+ self assert: (2047 storeStringBase: 16 length: 7 padded: true) = '16r07FF'.
+ self assert: (-2047 storeStringBase: 16 length: 7 padded: true) = '-16r7FF'.
+ self assert: (-2047 storeStringBase: 16 length: 19 padded: true) = '-16r0000000000007FF'.
+ !
Item was added:
+ ----- Method: IntegerTest>>testIntegerReadFrom (in category 'tests - instance creation') -----
+ testIntegerReadFrom
+ self assert: (Integer readFrom: '123' readStream base: 10) = 123.
+ self assert: (Integer readFrom: '-123' readStream base: 10) = -123.
+ self should: [Integer readFrom: 'abc' readStream base: 10] raise: Error.
+ self should: [Integer readFrom: 'D12' readStream base: 10] raise: Error.
+ self assert: (Integer readFrom: 'abc' readStream ifFail: [0]) = 0.
+ self assert: (Integer readFrom: 'D12' readStream ifFail: [0]) = 0.
+ self assert: (Integer readFrom: '1two3' readStream base: 10) = 1.
+ !
Item was added:
+ ----- Method: IntegerTest>>testIsInteger (in category 'tests - basic') -----
+ testIsInteger
+
+ self assert: (0 isInteger).
+ !
Item was added:
+ ----- Method: IntegerTest>>testIsPowerOfTwo (in category 'tests - basic') -----
+ testIsPowerOfTwo
+
+ | powersOfTwo nonPowersOfTwo |
+ powersOfTwo := (0 to: 100) collect: [ :each |
+ 2 raisedTo: each ].
+ nonPowersOfTwo := (powersOfTwo collect: [ :each | each negated ]),
+ #(0 3 -3 5 -5 6 -6 7 -7 9 -9 10 -10 100 -100 1000 -1000 12345678 -12345678 1234567890 -1234567890 12345678901234567890 -12345678901234567890).
+ powersOfTwo do: [ :each |
+ self assert: each isPowerOfTwo ].
+ nonPowersOfTwo do: [ :each |
+ self deny: each isPowerOfTwo ]!
Item was added:
+ ----- Method: IntegerTest>>testIsPrime (in category 'tests - basic') -----
+ testIsPrime
+
+ | i |
+ "Not primes:"
+ #(-1000000000000000 -100 -5 -3 -2 -1 0 1) do: [ :each |
+ self deny: each isPrime ].
+
+ "Check all non-negative integers up to one million."
+ i := 0.
+ Integer primesUpTo: 1000000 do: [ :prime |
+ [ i < prime ] whileTrue: [
+ self deny: i isPrime.
+ i := i + 1 ].
+ self assert: i isPrime.
+ i := i + 1 ].
+ [ i <= 1000000 ] whileTrue: [
+ self deny: i isPrime.
+ i := i + 1 ].
+
+ "The following tests should return 'true'"
+ #(17 78901 104729 15485863 2038074743) do: [ :each |
+ self assert: each isPrime ].
+
+ "The following tests should return 'false' (first 5 are Carmichael numbers)"
+ #(561 2821 6601 10585 15841 256 29996224275831) do: [ :each |
+ self deny: each isPrime ].
+ !
Item was added:
+ ----- Method: IntegerTest>>testIsProbablyPrime (in category 'tests - basic') -----
+ testIsProbablyPrime
+
+ "Not primes:"
+ #(-100 -5 -3 -2 -1 0 1) do: [ :each |
+ self deny: each isProbablyPrime ].
+
+ "The following tests should return 'true'"
+ #(17 78901 104729 15485863 2038074743 29996224275833) do: [ :each |
+ self assert: each isProbablyPrime ].
+
+ "The following tests should return 'false' (first 5 are Carmichael integers)"
+ #(561 2821 6601 10585 15841 256 29996224275831) do: [ :each |
+ self deny: each isProbablyPrime ].!
Item was added:
+ ----- Method: IntegerTest>>testLargePrimesUpTo (in category 'tests - basic') -----
+ testLargePrimesUpTo
+
+ | nn |
+ nn := (2 raisedTo: 17) - 1.
+ self deny: (Integer primesUpTo: nn) last = nn.
+ self assert: (Integer primesUpTo: nn + 1) last = nn.
+
+
+ !
Item was added:
+ ----- Method: IntegerTest>>testLn (in category 'tests - mathematical functions') -----
+ testLn
+ self assert: (100 ln closeTo: 10 ln*2).
+ self assert: ((2 raisedTo: Float emax + 3) ln closeTo: 2 ln*(Float emax + 3)) description: 'Integer>>ln should not overflow'!
Item was added:
+ ----- Method: IntegerTest>>testLog (in category 'tests - mathematical functions') -----
+ testLog
+ self assert: (100 log closeTo: 2).
+ self assert: ((2 raisedTo: Float emax + 3) log closeTo: 2 log*(Float emax + 3)) description: 'Integer>>log should not overflow'!
Item was added:
+ ----- Method: IntegerTest>>testLowBit (in category 'tests - bitLogic') -----
+ testLowBit
+ | suite |
+
+ suite := (0 to: 1024) asArray , #(16rFDFD 16rFFFF 16r1000 16r1000000 16r1000001 16r70000000 16r7AFAFAFA ) , {SmallInteger maxVal . SmallInteger maxVal+1}.
+ suite := suite , (suite collect: [:e | e raisedTo: 20]).
+
+ suite do: [:anInteger |
+ | lowBit |
+ lowBit := (anInteger respondsTo: #bitAt:)
+ ifTrue: [(1 to: anInteger highBit) detect: [:bitIndex | (anInteger bitAt: bitIndex) ~= 0] ifNone: [0]]
+ ifFalse: [(1 to: anInteger highBit) detect: [:bitIndex | (anInteger bitAnd: (1 bitShift: bitIndex-1)) ~= 0] ifNone: [0]].
+ self assert: anInteger lowBit = lowBit.
+ self assert: anInteger negated lowBit = lowBit].!
Item was added:
+ ----- Method: IntegerTest>>testMontgomeryMultiplication (in category 'tests - arithmetic') -----
+ testMontgomeryMultiplication
+ | a m mInv |
+ m := 15485863.
+ mInv := m montgomeryDigitBase - ((m bitAnd: m montgomeryDigitMax) reciprocalModulo: m montgomeryDigitBase).
+ a := (m montgomeryDigitBase raisedTo: m montgomeryNumberOfDigits) \\ m.
+ #(483933 3871465 8951195) do: [:s |
+ (s montgomeryTimes: a modulo: m mInvModB: mInv) ifNotNil: [:s1 |
+ | s2 sa ssa |
+ self assert: s = s1.
+ sa := s montgomeryTimes: (a * a \\ m) modulo: m mInvModB: mInv.
+ self assert: sa = (s * a \\ m).
+ ssa := sa montgomeryTimes: sa modulo: m mInvModB: mInv.
+ self assert: ssa = (s * s * a \\ m).
+ s2 := ssa montgomeryTimes: 1 modulo: m mInvModB: mInv.
+ self assert: s2 = (s * s \\ m)]].!
Item was added:
+ ----- Method: IntegerTest>>testNegativeIntegerPrinting (in category 'tests - printing') -----
+ testNegativeIntegerPrinting
+ "self run: #testnegativeIntegerPrinting"
+
+ self assert: (-2 printStringBase: 2) = '-10'.
+ self assert: (-2 radix: 2) = '-10'.
+ self assert: -2 printStringHex = '-2'.
+ self assert: (-2 storeStringBase: 2) = '-2r10'.
+ self assert: -2 storeStringHex = '-16r2'.
+ self assert: (-21 printStringBase: 3) = '-210'.
+ self assert: (-21 radix: 3) = '-210'.
+ self assert: -21 printStringHex = '-15'.
+ self assert: (-21 storeStringBase: 3) = '-3r210'.
+ self assert: -21 storeStringHex = '-16r15'.
+ self assert: (-228 printStringBase: 4) = '-3210'.
+ self assert: (-228 radix: 4) = '-3210'.
+ self assert: -228 printStringHex = '-E4'.
+ self assert: (-228 storeStringBase: 4) = '-4r3210'.
+ self assert: -228 storeStringHex = '-16rE4'.
+ self assert: (-2930 printStringBase: 5) = '-43210'.
+ self assert: (-2930 radix: 5) = '-43210'.
+ self assert: -2930 printStringHex = '-B72'.
+ self assert: (-2930 storeStringBase: 5) = '-5r43210'.
+ self assert: -2930 storeStringHex = '-16rB72'.
+ self assert: (-44790 printStringBase: 6) = '-543210'.
+ self assert: (-44790 radix: 6) = '-543210'.
+ self assert: -44790 printStringHex = '-AEF6'.
+ self assert: (-44790 storeStringBase: 6) = '-6r543210'.
+ self assert: -44790 storeStringHex = '-16rAEF6'.
+ self assert: (-800667 printStringBase: 7) = '-6543210'.
+ self assert: (-800667 radix: 7) = '-6543210'.
+ self assert: -800667 printStringHex = '-C379B'.
+ self assert: (-800667 storeStringBase: 7) = '-7r6543210'.
+ self assert: -800667 storeStringHex = '-16rC379B'.
+ self assert: (-16434824 printStringBase: 8) = '-76543210'.
+ self assert: (-16434824 radix: 8) = '-76543210'.
+ self assert: -16434824 printStringHex = '-FAC688'.
+ self assert: (-16434824 storeStringBase: 8) = '-8r76543210'.
+ self assert: -16434824 storeStringHex = '-16rFAC688'.
+ self assert: (-381367044 printStringBase: 9) = '-876543210'.
+ self assert: (-381367044 radix: 9) = '-876543210'.
+ self assert: -381367044 printStringHex = '-16BB3304'.
+ self assert: (-381367044 storeStringBase: 9) = '-9r876543210'.
+ self assert: -381367044 storeStringHex = '-16r16BB3304'.
+ self assert: (-9876543210 printStringBase: 10) = '-9876543210'.
+ self assert: (-9876543210 radix: 10) = '-9876543210'.
+ self assert: -9876543210 printStringHex = '-24CB016EA'.
+ self assert: (-9876543210 storeStringBase: 10) = '-9876543210'.
+ self assert: -9876543210 storeStringHex = '-16r24CB016EA'.
+ self assert: (-282458553905 printStringBase: 11) = '-A9876543210'.
+ self assert: (-282458553905 radix: 11) = '-A9876543210'.
+ self assert: -282458553905 printStringHex = '-41C3D77E31'.
+ self assert: (-282458553905 storeStringBase: 11) = '-11rA9876543210'.
+ self assert: -282458553905 storeStringHex = '-16r41C3D77E31'.
+ self assert: (-8842413667692 printStringBase: 12) = '-BA9876543210'.
+ self assert: (-8842413667692 radix: 12) = '-BA9876543210'.
+ self assert: -8842413667692 printStringHex = '-80AC8ECF56C'.
+ self assert: (-8842413667692 storeStringBase: 12) = '-12rBA9876543210'.
+ self assert: -8842413667692 storeStringHex = '-16r80AC8ECF56C'.
+ self assert: (-300771807240918 printStringBase: 13) = '-CBA9876543210'.
+ self assert: (-300771807240918 radix: 13) = '-CBA9876543210'.
+ self assert: -300771807240918 printStringHex = '-1118CE4BAA2D6'.
+ self assert: (-300771807240918 storeStringBase: 13) = '-13rCBA9876543210'.
+ self assert: -300771807240918 storeStringHex = '-16r1118CE4BAA2D6'.
+ self assert: (-11046255305880158 printStringBase: 14) = '-DCBA9876543210'.
+ self assert: (-11046255305880158 radix: 14) = '-DCBA9876543210'.
+ self assert: -11046255305880158 printStringHex = '-273E82BB9AF25E'.
+ self assert: (-11046255305880158 storeStringBase: 14) = '-14rDCBA9876543210'.
+ self assert: -11046255305880158 storeStringHex = '-16r273E82BB9AF25E'.
+ self assert: (-435659737878916215 printStringBase: 15) = '-EDCBA9876543210'.
+ self assert: (-435659737878916215 radix: 15) = '-EDCBA9876543210'.
+ self assert: -435659737878916215 printStringHex = '-60BC6392F366C77'.
+ self assert: (-435659737878916215 storeStringBase: 15) = '-15rEDCBA9876543210'.
+ self assert: -435659737878916215 storeStringHex = '-16r60BC6392F366C77'.
+ self assert: (-18364758544493064720 printStringBase: 16) = '-FEDCBA9876543210'.
+ self assert: (-18364758544493064720 radix: 16) = '-FEDCBA9876543210'.
+ self assert: -18364758544493064720 printStringHex = '-FEDCBA9876543210'.
+ self assert: (-18364758544493064720 storeStringBase: 16) = '-16rFEDCBA9876543210'.
+ self assert: -18364758544493064720 storeStringHex = '-16rFEDCBA9876543210'.
+ self assert: (-824008854613343261192 printStringBase: 17) = '-GFEDCBA9876543210'.
+ self assert: (-824008854613343261192 radix: 17) = '-GFEDCBA9876543210'.
+ self assert: -824008854613343261192 printStringHex = '-2CAB6B877C1CD2D208'.
+ self assert: (-824008854613343261192 storeStringBase: 17) = '-17rGFEDCBA9876543210'.
+ self assert: -824008854613343261192 storeStringHex = '-16r2CAB6B877C1CD2D208'.
+ self assert: (-39210261334551566857170 printStringBase: 18) = '-HGFEDCBA9876543210'.
+ self assert: (-39210261334551566857170 radix: 18) = '-HGFEDCBA9876543210'.
+ self assert: -39210261334551566857170 printStringHex = '-84D97AFCAE81415B3D2'.
+ self assert: (-39210261334551566857170 storeStringBase: 18) = '-18rHGFEDCBA9876543210'.
+ self assert: -39210261334551566857170 storeStringHex = '-16r84D97AFCAE81415B3D2'.
+ self assert: (-1972313422155189164466189 printStringBase: 19) = '-IHGFEDCBA9876543210'.
+ self assert: (-1972313422155189164466189 radix: 19) = '-IHGFEDCBA9876543210'.
+ self assert: -1972313422155189164466189 printStringHex = '-1A1A75329C5C6FC00600D'.
+ self assert: (-1972313422155189164466189 storeStringBase: 19) = '-19rIHGFEDCBA9876543210'.
+ self assert: -1972313422155189164466189 storeStringHex = '-16r1A1A75329C5C6FC00600D'.
+ self assert: (-104567135734072022160664820 printStringBase: 20) = '-JIHGFEDCBA9876543210'.
+ self assert: (-104567135734072022160664820 radix: 20) = '-JIHGFEDCBA9876543210'.
+ self assert: -104567135734072022160664820 printStringHex = '-567EF3C9636D242A8C68F4'.
+ self assert: (-104567135734072022160664820 storeStringBase: 20) = '-20rJIHGFEDCBA9876543210'.
+ self assert: -104567135734072022160664820 storeStringHex = '-16r567EF3C9636D242A8C68F4'.
+ self assert: (-5827980550840017565077671610 printStringBase: 21) = '-KJIHGFEDCBA9876543210'.
+ self assert: (-5827980550840017565077671610 radix: 21) = '-KJIHGFEDCBA9876543210'.
+ self assert: -5827980550840017565077671610 printStringHex = '-12D4CAE2B8A09BCFDBE30EBA'.
+ self assert: (-5827980550840017565077671610 storeStringBase: 21) = '-21rKJIHGFEDCBA9876543210'.
+ self assert: -5827980550840017565077671610 storeStringHex = '-16r12D4CAE2B8A09BCFDBE30EBA'.
+ self assert: (-340653664490377789692799452102 printStringBase: 22) = '-LKJIHGFEDCBA9876543210'.
+ self assert: (-340653664490377789692799452102 radix: 22) = '-LKJIHGFEDCBA9876543210'.
+ self assert: -340653664490377789692799452102 printStringHex = '-44CB61B5B47E1A5D8F88583C6'.
+ self assert: (-340653664490377789692799452102 storeStringBase: 22) = '-22rLKJIHGFEDCBA9876543210'.
+ self assert: -340653664490377789692799452102 storeStringHex = '-16r44CB61B5B47E1A5D8F88583C6'.
+ self assert: (-20837326537038308910317109288851 printStringBase: 23) = '-MLKJIHGFEDCBA9876543210'.
+ self assert: (-20837326537038308910317109288851 radix: 23) = '-MLKJIHGFEDCBA9876543210'.
+ self assert: -20837326537038308910317109288851 printStringHex = '-1070108876456E0EF115B389F93'.
+ self assert: (-20837326537038308910317109288851 storeStringBase: 23) = '-23rMLKJIHGFEDCBA9876543210'.
+ self assert: -20837326537038308910317109288851 storeStringHex = '-16r1070108876456E0EF115B389F93'.
+ self assert: (-1331214537196502869015340298036888 printStringBase: 24) = '-NMLKJIHGFEDCBA9876543210'.
+ self assert: (-1331214537196502869015340298036888 radix: 24) = '-NMLKJIHGFEDCBA9876543210'.
+ self assert: -1331214537196502869015340298036888 printStringHex = '-41A24A285154B026B6ED206C6698'.
+ self assert: (-1331214537196502869015340298036888 storeStringBase: 24) = '-24rNMLKJIHGFEDCBA9876543210'.
+ self assert: -1331214537196502869015340298036888 storeStringHex = '-16r41A24A285154B026B6ED206C6698'.
+ self assert: (-88663644327703473714387251271141900 printStringBase: 25) = '-ONMLKJIHGFEDCBA9876543210'.
+ self assert: (-88663644327703473714387251271141900 radix: 25) = '-ONMLKJIHGFEDCBA9876543210'.
+ self assert: -88663644327703473714387251271141900 printStringHex = '-111374860A2C6CEBE5999630398A0C'.
+ self assert: (-88663644327703473714387251271141900 storeStringBase: 25) = '-25rONMLKJIHGFEDCBA9876543210'.
+ self assert: -88663644327703473714387251271141900 storeStringHex = '-16r111374860A2C6CEBE5999630398A0C'.
+ self assert: (-6146269788878825859099399609538763450 printStringBase: 26) = '-PONMLKJIHGFEDCBA9876543210'.
+ self assert: (-6146269788878825859099399609538763450 radix: 26) = '-PONMLKJIHGFEDCBA9876543210'.
+ self assert: -6146269788878825859099399609538763450 printStringHex = '-49FBA7F30B0F48BD14E6A99BD8ADABA'.
+ self assert: (-6146269788878825859099399609538763450 storeStringBase: 26) = '-26rPONMLKJIHGFEDCBA9876543210'.
+ self assert: -6146269788878825859099399609538763450 storeStringHex = '-16r49FBA7F30B0F48BD14E6A99BD8ADABA'.
+ self assert: (-442770531899482980347734468443677777577 printStringBase: 27) = '-QPONMLKJIHGFEDCBA9876543210'.
+ self assert: (-442770531899482980347734468443677777577 radix: 27) = '-QPONMLKJIHGFEDCBA9876543210'.
+ self assert: -442770531899482980347734468443677777577 printStringHex = '-14D1A80A997343640C1145A073731DEA9'.
+ self assert: (-442770531899482980347734468443677777577 storeStringBase: 27) = '-27rQPONMLKJIHGFEDCBA9876543210'.
+ self assert: -442770531899482980347734468443677777577 storeStringHex = '-16r14D1A80A997343640C1145A073731DEA9'.
+ self assert: (-33100056003358651440264672384704297711484 printStringBase: 28) = '-RQPONMLKJIHGFEDCBA9876543210'.
+ self assert: (-33100056003358651440264672384704297711484 radix: 28) = '-RQPONMLKJIHGFEDCBA9876543210'.
+ self assert: -33100056003358651440264672384704297711484 printStringHex = '-6145B6E6DACFA25D0E936F51D25932377C'.
+ self assert: (-33100056003358651440264672384704297711484 storeStringBase: 28) = '-28rRQPONMLKJIHGFEDCBA9876543210'.
+ self assert: -33100056003358651440264672384704297711484 storeStringHex = '-16r6145B6E6DACFA25D0E936F51D25932377C'.
+ self assert: (-2564411043271974895869785066497940850811934 printStringBase: 29) = '-SRQPONMLKJIHGFEDCBA9876543210'.
+ self assert: (-2564411043271974895869785066497940850811934 radix: 29) = '-SRQPONMLKJIHGFEDCBA9876543210'.
+ self assert: -2564411043271974895869785066497940850811934 printStringHex = '-1D702071CBA4A1597D4DD37E95EFAC79241E'.
+ self assert: (-2564411043271974895869785066497940850811934 storeStringBase: 29) = '-29rSRQPONMLKJIHGFEDCBA9876543210'.
+ self assert: -2564411043271974895869785066497940850811934 storeStringHex = '-16r1D702071CBA4A1597D4DD37E95EFAC79241E'.
+ self assert: (-205646315052919334126040428061831153388822830 printStringBase: 30) = '-TSRQPONMLKJIHGFEDCBA9876543210'.
+ self assert: (-205646315052919334126040428061831153388822830 radix: 30) = '-TSRQPONMLKJIHGFEDCBA9876543210'.
+ self assert: -205646315052919334126040428061831153388822830 printStringHex = '-938B4343B54B550989989D02998718FFB212E'.
+ self assert: (-205646315052919334126040428061831153388822830 storeStringBase: 30) = '-30rTSRQPONMLKJIHGFEDCBA9876543210'.
+ self assert: -205646315052919334126040428061831153388822830 storeStringHex = '-16r938B4343B54B550989989D02998718FFB212E'.
+ self assert: (-17050208381689099029767742314582582184093573615 printStringBase: 31) = '-UTSRQPONMLKJIHGFEDCBA9876543210'.
+ self assert: (-17050208381689099029767742314582582184093573615 radix: 31) = '-UTSRQPONMLKJIHGFEDCBA9876543210'.
+ self assert: -17050208381689099029767742314582582184093573615 printStringHex = '-2FC8ECB1521BA16D24A69E976D53873E2C661EF'.
+ self assert: (-17050208381689099029767742314582582184093573615 storeStringBase: 31) = '-31rUTSRQPONMLKJIHGFEDCBA9876543210'.
+ self assert: -17050208381689099029767742314582582184093573615 storeStringHex = '-16r2FC8ECB1521BA16D24A69E976D53873E2C661EF'.
+ self assert: (-1459980823972598128486511383358617792788444579872 printStringBase: 32) = '-VUTSRQPONMLKJIHGFEDCBA9876543210'.
+ self assert: (-1459980823972598128486511383358617792788444579872 radix: 32) = '-VUTSRQPONMLKJIHGFEDCBA9876543210'.
+ self assert: -1459980823972598128486511383358617792788444579872 printStringHex = '-FFBBCDEB38BDAB49CA307B9AC5A928398A418820'.
+ self assert: (-1459980823972598128486511383358617792788444579872 storeStringBase: 32) = '-32rVUTSRQPONMLKJIHGFEDCBA9876543210'.
+ self assert: -1459980823972598128486511383358617792788444579872 storeStringHex = '-16rFFBBCDEB38BDAB49CA307B9AC5A928398A418820'.
+ self assert: (-128983956064237823710866404905431464703849549412368 printStringBase: 33) = '-WVUTSRQPONMLKJIHGFEDCBA9876543210'.
+ self assert: (-128983956064237823710866404905431464703849549412368 radix: 33) = '-WVUTSRQPONMLKJIHGFEDCBA9876543210'.
+ self assert: -128983956064237823710866404905431464703849549412368 printStringHex = '-584120A0328DE272AB055A8AA003CE4A559F223810'.
+ self assert: (-128983956064237823710866404905431464703849549412368 storeStringBase: 33) = '-33rWVUTSRQPONMLKJIHGFEDCBA9876543210'.
+ self assert: -128983956064237823710866404905431464703849549412368 storeStringHex = '-16r584120A0328DE272AB055A8AA003CE4A559F223810'.
+ self assert: (-11745843093701610854378775891116314824081102660800418 printStringBase: 34) = '-XWVUTSRQPONMLKJIHGFEDCBA9876543210'.
+ self assert: (-11745843093701610854378775891116314824081102660800418 radix: 34) = '-XWVUTSRQPONMLKJIHGFEDCBA9876543210'.
+ self assert: -11745843093701610854378775891116314824081102660800418 printStringHex = '-1F64D4FC76000F7B92CF0CD5D0F350139AB9F25D8FA2'.
+ self assert: (-11745843093701610854378775891116314824081102660800418 storeStringBase: 34) = '-34rXWVUTSRQPONMLKJIHGFEDCBA9876543210'.
+ self assert: -11745843093701610854378775891116314824081102660800418 storeStringHex = '-16r1F64D4FC76000F7B92CF0CD5D0F350139AB9F25D8FA2'.
+ self assert: (-1101553773143634726491620528194292510495517905608180485 printStringBase: 35) = '-YXWVUTSRQPONMLKJIHGFEDCBA9876543210'.
+ self assert: (-1101553773143634726491620528194292510495517905608180485 radix: 35) = '-YXWVUTSRQPONMLKJIHGFEDCBA9876543210'.
+ self assert: -1101553773143634726491620528194292510495517905608180485 printStringHex = '-B8031AD55AD1FAA89E07A271CA1ED2F420415D1570305'.
+ self assert: (-1101553773143634726491620528194292510495517905608180485 storeStringBase: 35) = '-35rYXWVUTSRQPONMLKJIHGFEDCBA9876543210'.
+ self assert: -1101553773143634726491620528194292510495517905608180485 storeStringHex = '-16rB8031AD55AD1FAA89E07A271CA1ED2F420415D1570305'.
+ self assert: (-106300512100105327644605138221229898724869759421181854980 printStringBase: 36) = '-ZYXWVUTSRQPONMLKJIHGFEDCBA9876543210'.
+ self assert: (-106300512100105327644605138221229898724869759421181854980 radix: 36) = '-ZYXWVUTSRQPONMLKJIHGFEDCBA9876543210'.
+ self assert: -106300512100105327644605138221229898724869759421181854980 printStringHex = '-455D441E55A37239AB4C303189576071AF5578FFCA80504'.
+ self assert: (-106300512100105327644605138221229898724869759421181854980 storeStringBase: 36) = '-36rZYXWVUTSRQPONMLKJIHGFEDCBA9876543210'.
+ self assert: -106300512100105327644605138221229898724869759421181854980 storeStringHex = '-16r455D441E55A37239AB4C303189576071AF5578FFCA80504'.!
Item was added:
+ ----- Method: IntegerTest>>testNew (in category 'tests - instance creation') -----
+ testNew
+ self shouldRaiseError: [Integer new].!
Item was added:
+ ----- Method: IntegerTest>>testNthRoot (in category 'tests - mathematical functions') -----
+ testNthRoot
+ self assert: (1 << 2000 nthRoot: 100) equals: 1 << 20!
Item was added:
+ ----- Method: IntegerTest>>testNthRootErrorConditions (in category 'tests - mathematical functions') -----
+ testNthRootErrorConditions
+ "
+ IntegerTest new testExactRaisedToErrorConditions
+ "
+
+ self should: [ -2 nthRoot: 1/4 ] raise: ArithmeticError.
+ self should: [ -2 nthRoot: 1.24 ] raise: ArithmeticError.!
Item was added:
+ ----- Method: IntegerTest>>testNthRootExactness (in category 'tests - mathematical functions') -----
+ testNthRootExactness
+ | inexactRoots largeRaisedTo6 |
+ largeRaisedTo6 := (2 to: 100) collect: [:k | (k raisedTo: 11) raisedTo: 6].
+ inexactRoots := largeRaisedTo6 reject: [:e | (e nthRoot: 6) isInteger].
+ self assert: inexactRoots isEmpty description: 'Failed to find the exact 6th root of these numbers'!
Item was added:
+ ----- Method: IntegerTest>>testNthRootExactnessForHugeValue (in category 'tests - mathematical functions') -----
+ testNthRootExactnessForHugeValue
+ self assert: ((10 raisedTo: 600) nthRoot: 300) classAndValueEquals: 100.
+ self assert: ((10 raisedTo: 600) + 1 nthRoot: 300) classAndValueEquals: 100.0!
Item was added:
+ ----- Method: IntegerTest>>testNthRootImmuneToDoubleRounding (in category 'tests - mathematical functions') -----
+ testNthRootImmuneToDoubleRounding
+ "Use a specially crafted number for causing double rounding.
+ Solution is 10...01.1 - verySmallQuantity.
+ Where verySmallQuantity is approximately 1/53/(1<<53).
+ If the verySmallQuantity is not taken into account, then solution is rounded to 10....010"
+ | exponent crafted root highPrecisionRoot |
+ exponent := 4.
+ crafted := (1 << Float precision + 3 raisedTo: exponent) - 1.
+ root := crafted nthRoot: exponent.
+ highPrecisionRoot := (crafted << (exponent squared * Float precision * 4) nthRootRounded: exponent) / (1 << (exponent * Float precision * 4)).
+ self assert: (root asFraction - highPrecisionRoot) abs < (root predecessor asFraction - highPrecisionRoot) abs.
+
+ "Same with the other sign.
+ Solution is 10...00.1 + verySmallQuantity."
+ crafted := (1 << Float precision + 1 raisedTo: exponent) + 1.
+ root := crafted nthRoot: exponent.
+ highPrecisionRoot := (crafted << (exponent squared * Float precision * 4) nthRootRounded: exponent) / (1 << (exponent * Float precision * 4)).
+ self assert: (root asFraction - highPrecisionRoot) abs < (root successor asFraction - highPrecisionRoot) abs.!
Item was added:
+ ----- Method: IntegerTest>>testNthRootRounded (in category 'tests - mathematical functions') -----
+ testNthRootRounded
+ <timeout: 5 "seconds">
+ | d x |
+ d := ((1 + 2 reciprocal - (1<<30) reciprocal) raisedTo: 1000) floor. "close to 1.5 by default"
+ x := ((1 + 2 reciprocal + (1<<30) reciprocal) raisedTo: 1000) ceiling. "close to 1.5 by excess"
+ self assert: (d nthRootTruncated: 1000) equals: 1.
+ self assert: (x nthRootTruncated: 1000) equals: 1.
+ self assert: (d nthRootRounded: 1000) equals: 1.
+ self assert: (x nthRootRounded: 1000) equals: 2.!
Item was added:
+ ----- Method: IntegerTest>>testNthRootTruncated (in category 'tests - mathematical functions') -----
+ testNthRootTruncated
+ <timeout: 5 "seconds">
+ | tooBigToBeAFloat large |
+ tooBigToBeAFloat := 1 << 2000.
+ self assert: (tooBigToBeAFloat nthRootTruncated: 100) equals: 1 << 20.
+ self assert: (tooBigToBeAFloat + 1 nthRootTruncated: 100) equals: 1 << 20.
+ self assert: (tooBigToBeAFloat - 1 nthRootTruncated: 100) equals: 1 << 20 - 1.
+
+ large := -3 raisedTo: 255.
+ self assert: (large nthRootTruncated: 17) equals: (-3 raisedTo: 15).
+ self assert: (large + 11 nthRootTruncated: 17) equals: (-3 raisedTo: 15) + 1.
+ self assert: (large - 11 nthRootTruncated: 17) equals: (-3 raisedTo: 15).
+
+ 2 to: 10 do: [:thePower |
+ 1 to: 10000 do: [:n |
+ | theTruncatedRoot |
+ theTruncatedRoot := n nthRootTruncated: thePower.
+ self assert: (theTruncatedRoot raisedTo: thePower) <= n.
+ self assert: (theTruncatedRoot + 1 raisedTo: thePower) > n]]!
Item was added:
+ ----- Method: IntegerTest>>testNumberOfDigits (in category 'tests - printing') -----
+ testNumberOfDigits
+
+ 2 to: 32 do: [:b |
+ 1 to: 1000//b do: [:n |
+ | bRaisedToN |
+ bRaisedToN := b raisedTo: n.
+ self assert: (bRaisedToN - 1 numberOfDigitsInBase: b) = n.
+ self assert: (bRaisedToN numberOfDigitsInBase: b) = (n+1).
+ self assert: (bRaisedToN + 1 numberOfDigitsInBase: b) = (n+1).
+
+ self assert: (bRaisedToN negated + 1 numberOfDigitsInBase: b) = n.
+ self assert: (bRaisedToN negated numberOfDigitsInBase: b) = (n+1).
+ self assert: (bRaisedToN negated - 1 numberOfDigitsInBase: b) = (n+1).]].
+ !
Item was added:
+ ----- Method: IntegerTest>>testPositiveIntegerPrinting (in category 'tests - printing') -----
+ testPositiveIntegerPrinting
+ "self run: #testPositiveIntegerPrinting"
+
+ self assert: 0 printString = '0'.
+ self assert: 0 printStringHex = '0'.
+ self assert: 0 storeStringHex = '16r0'.
+
+ self assert: (2 printStringBase: 2) = '10'.
+ self assert: (2 radix: 2) = '10'.
+ self assert: 2 printStringHex = '2'.
+ self assert: (2 storeStringBase: 2) = '2r10'.
+ self assert: 2 storeStringHex = '16r2'.
+ self assert: (21 printStringBase: 3) = '210'.
+ self assert: (21 radix: 3) = '210'.
+ self assert: 21 printStringHex = '15'.
+ self assert: (21 storeStringBase: 3) = '3r210'.
+ self assert: 21 storeStringHex = '16r15'.
+ self assert: (228 printStringBase: 4) = '3210'.
+ self assert: (228 radix: 4) = '3210'.
+ self assert: 228 printStringHex = 'E4'.
+ self assert: (228 storeStringBase: 4) = '4r3210'.
+ self assert: 228 storeStringHex = '16rE4'.
+ self assert: (2930 printStringBase: 5) = '43210'.
+ self assert: (2930 radix: 5) = '43210'.
+ self assert: 2930 printStringHex = 'B72'.
+ self assert: (2930 storeStringBase: 5) = '5r43210'.
+ self assert: 2930 storeStringHex = '16rB72'.
+ self assert: (44790 printStringBase: 6) = '543210'.
+ self assert: (44790 radix: 6) = '543210'.
+ self assert: 44790 printStringHex = 'AEF6'.
+ self assert: (44790 storeStringBase: 6) = '6r543210'.
+ self assert: 44790 storeStringHex = '16rAEF6'.
+ self assert: (800667 printStringBase: 7) = '6543210'.
+ self assert: (800667 radix: 7) = '6543210'.
+ self assert: 800667 printStringHex = 'C379B'.
+ self assert: (800667 storeStringBase: 7) = '7r6543210'.
+ self assert: 800667 storeStringHex = '16rC379B'.
+ self assert: (16434824 printStringBase: 8) = '76543210'.
+ self assert: (16434824 radix: 8) = '76543210'.
+ self assert: 16434824 printStringHex = 'FAC688'.
+ self assert: (16434824 storeStringBase: 8) = '8r76543210'.
+ self assert: 16434824 storeStringHex = '16rFAC688'.
+ self assert: (381367044 printStringBase: 9) = '876543210'.
+ self assert: (381367044 radix: 9) = '876543210'.
+ self assert: 381367044 printStringHex = '16BB3304'.
+ self assert: (381367044 storeStringBase: 9) = '9r876543210'.
+ self assert: 381367044 storeStringHex = '16r16BB3304'.
+ self assert: (9876543210 printStringBase: 10) = '9876543210'.
+ self assert: (9876543210 radix: 10) = '9876543210'.
+ self assert: 9876543210 printStringHex = '24CB016EA'.
+ self assert: (9876543210 storeStringBase: 10) = '9876543210'.
+ self assert: 9876543210 storeStringHex = '16r24CB016EA'.
+ self assert: (282458553905 printStringBase: 11) = 'A9876543210'.
+ self assert: (282458553905 radix: 11) = 'A9876543210'.
+ self assert: 282458553905 printStringHex = '41C3D77E31'.
+ self assert: (282458553905 storeStringBase: 11) = '11rA9876543210'.
+ self assert: 282458553905 storeStringHex = '16r41C3D77E31'.
+ self assert: (8842413667692 printStringBase: 12) = 'BA9876543210'.
+ self assert: (8842413667692 radix: 12) = 'BA9876543210'.
+ self assert: 8842413667692 printStringHex = '80AC8ECF56C'.
+ self assert: (8842413667692 storeStringBase: 12) = '12rBA9876543210'.
+ self assert: 8842413667692 storeStringHex = '16r80AC8ECF56C'.
+ self assert: (300771807240918 printStringBase: 13) = 'CBA9876543210'.
+ self assert: (300771807240918 radix: 13) = 'CBA9876543210'.
+ self assert: 300771807240918 printStringHex = '1118CE4BAA2D6'.
+ self assert: (300771807240918 storeStringBase: 13) = '13rCBA9876543210'.
+ self assert: 300771807240918 storeStringHex = '16r1118CE4BAA2D6'.
+ self assert: (11046255305880158 printStringBase: 14) = 'DCBA9876543210'.
+ self assert: (11046255305880158 radix: 14) = 'DCBA9876543210'.
+ self assert: 11046255305880158 printStringHex = '273E82BB9AF25E'.
+ self assert: (11046255305880158 storeStringBase: 14) = '14rDCBA9876543210'.
+ self assert: 11046255305880158 storeStringHex = '16r273E82BB9AF25E'.
+ self assert: (435659737878916215 printStringBase: 15) = 'EDCBA9876543210'.
+ self assert: (435659737878916215 radix: 15) = 'EDCBA9876543210'.
+ self assert: 435659737878916215 printStringHex = '60BC6392F366C77'.
+ self assert: (435659737878916215 storeStringBase: 15) = '15rEDCBA9876543210'.
+ self assert: 435659737878916215 storeStringHex = '16r60BC6392F366C77'.
+ self assert: (18364758544493064720 printStringBase: 16) = 'FEDCBA9876543210'.
+ self assert: (18364758544493064720 radix: 16) = 'FEDCBA9876543210'.
+ self assert: 18364758544493064720 printStringHex = 'FEDCBA9876543210'.
+ self assert: (18364758544493064720 storeStringBase: 16) = '16rFEDCBA9876543210'.
+ self assert: 18364758544493064720 storeStringHex = '16rFEDCBA9876543210'.
+ self assert: (824008854613343261192 printStringBase: 17) = 'GFEDCBA9876543210'.
+ self assert: (824008854613343261192 radix: 17) = 'GFEDCBA9876543210'.
+ self assert: 824008854613343261192 printStringHex = '2CAB6B877C1CD2D208'.
+ self assert: (824008854613343261192 storeStringBase: 17) = '17rGFEDCBA9876543210'.
+ self assert: 824008854613343261192 storeStringHex = '16r2CAB6B877C1CD2D208'.
+ self assert: (39210261334551566857170 printStringBase: 18) = 'HGFEDCBA9876543210'.
+ self assert: (39210261334551566857170 radix: 18) = 'HGFEDCBA9876543210'.
+ self assert: 39210261334551566857170 printStringHex = '84D97AFCAE81415B3D2'.
+ self assert: (39210261334551566857170 storeStringBase: 18) = '18rHGFEDCBA9876543210'.
+ self assert: 39210261334551566857170 storeStringHex = '16r84D97AFCAE81415B3D2'.
+ self assert: (1972313422155189164466189 printStringBase: 19) = 'IHGFEDCBA9876543210'.
+ self assert: (1972313422155189164466189 radix: 19) = 'IHGFEDCBA9876543210'.
+ self assert: 1972313422155189164466189 printStringHex = '1A1A75329C5C6FC00600D'.
+ self assert: (1972313422155189164466189 storeStringBase: 19) = '19rIHGFEDCBA9876543210'.
+ self assert: 1972313422155189164466189 storeStringHex = '16r1A1A75329C5C6FC00600D'.
+ self assert: (104567135734072022160664820 printStringBase: 20) = 'JIHGFEDCBA9876543210'.
+ self assert: (104567135734072022160664820 radix: 20) = 'JIHGFEDCBA9876543210'.
+ self assert: 104567135734072022160664820 printStringHex = '567EF3C9636D242A8C68F4'.
+ self assert: (104567135734072022160664820 storeStringBase: 20) = '20rJIHGFEDCBA9876543210'.
+ self assert: 104567135734072022160664820 storeStringHex = '16r567EF3C9636D242A8C68F4'.
+ self assert: (5827980550840017565077671610 printStringBase: 21) = 'KJIHGFEDCBA9876543210'.
+ self assert: (5827980550840017565077671610 radix: 21) = 'KJIHGFEDCBA9876543210'.
+ self assert: 5827980550840017565077671610 printStringHex = '12D4CAE2B8A09BCFDBE30EBA'.
+ self assert: (5827980550840017565077671610 storeStringBase: 21) = '21rKJIHGFEDCBA9876543210'.
+ self assert: 5827980550840017565077671610 storeStringHex = '16r12D4CAE2B8A09BCFDBE30EBA'.
+ self assert: (340653664490377789692799452102 printStringBase: 22) = 'LKJIHGFEDCBA9876543210'.
+ self assert: (340653664490377789692799452102 radix: 22) = 'LKJIHGFEDCBA9876543210'.
+ self assert: 340653664490377789692799452102 printStringHex = '44CB61B5B47E1A5D8F88583C6'.
+ self assert: (340653664490377789692799452102 storeStringBase: 22) = '22rLKJIHGFEDCBA9876543210'.
+ self assert: 340653664490377789692799452102 storeStringHex = '16r44CB61B5B47E1A5D8F88583C6'.
+ self assert: (20837326537038308910317109288851 printStringBase: 23) = 'MLKJIHGFEDCBA9876543210'.
+ self assert: (20837326537038308910317109288851 radix: 23) = 'MLKJIHGFEDCBA9876543210'.
+ self assert: 20837326537038308910317109288851 printStringHex = '1070108876456E0EF115B389F93'.
+ self assert: (20837326537038308910317109288851 storeStringBase: 23) = '23rMLKJIHGFEDCBA9876543210'.
+ self assert: 20837326537038308910317109288851 storeStringHex = '16r1070108876456E0EF115B389F93'.
+ self assert: (1331214537196502869015340298036888 printStringBase: 24) = 'NMLKJIHGFEDCBA9876543210'.
+ self assert: (1331214537196502869015340298036888 radix: 24) = 'NMLKJIHGFEDCBA9876543210'.
+ self assert: 1331214537196502869015340298036888 printStringHex = '41A24A285154B026B6ED206C6698'.
+ self assert: (1331214537196502869015340298036888 storeStringBase: 24) = '24rNMLKJIHGFEDCBA9876543210'.
+ self assert: 1331214537196502869015340298036888 storeStringHex = '16r41A24A285154B026B6ED206C6698'.
+ self assert: (88663644327703473714387251271141900 printStringBase: 25) = 'ONMLKJIHGFEDCBA9876543210'.
+ self assert: (88663644327703473714387251271141900 radix: 25) = 'ONMLKJIHGFEDCBA9876543210'.
+ self assert: 88663644327703473714387251271141900 printStringHex = '111374860A2C6CEBE5999630398A0C'.
+ self assert: (88663644327703473714387251271141900 storeStringBase: 25) = '25rONMLKJIHGFEDCBA9876543210'.
+ self assert: 88663644327703473714387251271141900 storeStringHex = '16r111374860A2C6CEBE5999630398A0C'.
+ self assert: (6146269788878825859099399609538763450 printStringBase: 26) = 'PONMLKJIHGFEDCBA9876543210'.
+ self assert: (6146269788878825859099399609538763450 radix: 26) = 'PONMLKJIHGFEDCBA9876543210'.
+ self assert: 6146269788878825859099399609538763450 printStringHex = '49FBA7F30B0F48BD14E6A99BD8ADABA'.
+ self assert: (6146269788878825859099399609538763450 storeStringBase: 26) = '26rPONMLKJIHGFEDCBA9876543210'.
+ self assert: 6146269788878825859099399609538763450 storeStringHex = '16r49FBA7F30B0F48BD14E6A99BD8ADABA'.
+ self assert: (442770531899482980347734468443677777577 printStringBase: 27) = 'QPONMLKJIHGFEDCBA9876543210'.
+ self assert: (442770531899482980347734468443677777577 radix: 27) = 'QPONMLKJIHGFEDCBA9876543210'.
+ self assert: 442770531899482980347734468443677777577 printStringHex = '14D1A80A997343640C1145A073731DEA9'.
+ self assert: (442770531899482980347734468443677777577 storeStringBase: 27) = '27rQPONMLKJIHGFEDCBA9876543210'.
+ self assert: 442770531899482980347734468443677777577 storeStringHex = '16r14D1A80A997343640C1145A073731DEA9'.
+ self assert: (33100056003358651440264672384704297711484 printStringBase: 28) = 'RQPONMLKJIHGFEDCBA9876543210'.
+ self assert: (33100056003358651440264672384704297711484 radix: 28) = 'RQPONMLKJIHGFEDCBA9876543210'.
+ self assert: 33100056003358651440264672384704297711484 printStringHex = '6145B6E6DACFA25D0E936F51D25932377C'.
+ self assert: (33100056003358651440264672384704297711484 storeStringBase: 28) = '28rRQPONMLKJIHGFEDCBA9876543210'.
+ self assert: 33100056003358651440264672384704297711484 storeStringHex = '16r6145B6E6DACFA25D0E936F51D25932377C'.
+ self assert: (2564411043271974895869785066497940850811934 printStringBase: 29) = 'SRQPONMLKJIHGFEDCBA9876543210'.
+ self assert: (2564411043271974895869785066497940850811934 radix: 29) = 'SRQPONMLKJIHGFEDCBA9876543210'.
+ self assert: 2564411043271974895869785066497940850811934 printStringHex = '1D702071CBA4A1597D4DD37E95EFAC79241E'.
+ self assert: (2564411043271974895869785066497940850811934 storeStringBase: 29) = '29rSRQPONMLKJIHGFEDCBA9876543210'.
+ self assert: 2564411043271974895869785066497940850811934 storeStringHex = '16r1D702071CBA4A1597D4DD37E95EFAC79241E'.
+ self assert: (205646315052919334126040428061831153388822830 printStringBase: 30) = 'TSRQPONMLKJIHGFEDCBA9876543210'.
+ self assert: (205646315052919334126040428061831153388822830 radix: 30) = 'TSRQPONMLKJIHGFEDCBA9876543210'.
+ self assert: 205646315052919334126040428061831153388822830 printStringHex = '938B4343B54B550989989D02998718FFB212E'.
+ self assert: (205646315052919334126040428061831153388822830 storeStringBase: 30) = '30rTSRQPONMLKJIHGFEDCBA9876543210'.
+ self assert: 205646315052919334126040428061831153388822830 storeStringHex = '16r938B4343B54B550989989D02998718FFB212E'.
+ self assert: (17050208381689099029767742314582582184093573615 printStringBase: 31) = 'UTSRQPONMLKJIHGFEDCBA9876543210'.
+ self assert: (17050208381689099029767742314582582184093573615 radix: 31) = 'UTSRQPONMLKJIHGFEDCBA9876543210'.
+ self assert: 17050208381689099029767742314582582184093573615 printStringHex = '2FC8ECB1521BA16D24A69E976D53873E2C661EF'.
+ self assert: (17050208381689099029767742314582582184093573615 storeStringBase: 31) = '31rUTSRQPONMLKJIHGFEDCBA9876543210'.
+ self assert: 17050208381689099029767742314582582184093573615 storeStringHex = '16r2FC8ECB1521BA16D24A69E976D53873E2C661EF'.
+ self assert: (1459980823972598128486511383358617792788444579872 printStringBase: 32) = 'VUTSRQPONMLKJIHGFEDCBA9876543210'.
+ self assert: (1459980823972598128486511383358617792788444579872 radix: 32) = 'VUTSRQPONMLKJIHGFEDCBA9876543210'.
+ self assert: 1459980823972598128486511383358617792788444579872 printStringHex = 'FFBBCDEB38BDAB49CA307B9AC5A928398A418820'.
+ self assert: (1459980823972598128486511383358617792788444579872 storeStringBase: 32) = '32rVUTSRQPONMLKJIHGFEDCBA9876543210'.
+ self assert: 1459980823972598128486511383358617792788444579872 storeStringHex = '16rFFBBCDEB38BDAB49CA307B9AC5A928398A418820'.
+ self assert: (128983956064237823710866404905431464703849549412368 printStringBase: 33) = 'WVUTSRQPONMLKJIHGFEDCBA9876543210'.
+ self assert: (128983956064237823710866404905431464703849549412368 radix: 33) = 'WVUTSRQPONMLKJIHGFEDCBA9876543210'.
+ self assert: 128983956064237823710866404905431464703849549412368 printStringHex = '584120A0328DE272AB055A8AA003CE4A559F223810'.
+ self assert: (128983956064237823710866404905431464703849549412368 storeStringBase: 33) = '33rWVUTSRQPONMLKJIHGFEDCBA9876543210'.
+ self assert: 128983956064237823710866404905431464703849549412368 storeStringHex = '16r584120A0328DE272AB055A8AA003CE4A559F223810'.
+ self assert: (11745843093701610854378775891116314824081102660800418 printStringBase: 34) = 'XWVUTSRQPONMLKJIHGFEDCBA9876543210'.
+ self assert: (11745843093701610854378775891116314824081102660800418 radix: 34) = 'XWVUTSRQPONMLKJIHGFEDCBA9876543210'.
+ self assert: 11745843093701610854378775891116314824081102660800418 printStringHex = '1F64D4FC76000F7B92CF0CD5D0F350139AB9F25D8FA2'.
+ self assert: (11745843093701610854378775891116314824081102660800418 storeStringBase: 34) = '34rXWVUTSRQPONMLKJIHGFEDCBA9876543210'.
+ self assert: 11745843093701610854378775891116314824081102660800418 storeStringHex = '16r1F64D4FC76000F7B92CF0CD5D0F350139AB9F25D8FA2'.
+ self assert: (1101553773143634726491620528194292510495517905608180485 printStringBase: 35) = 'YXWVUTSRQPONMLKJIHGFEDCBA9876543210'.
+ self assert: (1101553773143634726491620528194292510495517905608180485 radix: 35) = 'YXWVUTSRQPONMLKJIHGFEDCBA9876543210'.
+ self assert: 1101553773143634726491620528194292510495517905608180485 printStringHex = 'B8031AD55AD1FAA89E07A271CA1ED2F420415D1570305'.
+ self assert: (1101553773143634726491620528194292510495517905608180485 storeStringBase: 35) = '35rYXWVUTSRQPONMLKJIHGFEDCBA9876543210'.
+ self assert: 1101553773143634726491620528194292510495517905608180485 storeStringHex = '16rB8031AD55AD1FAA89E07A271CA1ED2F420415D1570305'.
+ self assert: (106300512100105327644605138221229898724869759421181854980 printStringBase: 36) = 'ZYXWVUTSRQPONMLKJIHGFEDCBA9876543210'.
+ self assert: (106300512100105327644605138221229898724869759421181854980 radix: 36) = 'ZYXWVUTSRQPONMLKJIHGFEDCBA9876543210'.
+ self assert: 106300512100105327644605138221229898724869759421181854980 printStringHex = '455D441E55A37239AB4C303189576071AF5578FFCA80504'.
+ self assert: (106300512100105327644605138221229898724869759421181854980 storeStringBase: 36) = '36rZYXWVUTSRQPONMLKJIHGFEDCBA9876543210'.
+ self assert: 106300512100105327644605138221229898724869759421181854980 storeStringHex = '16r455D441E55A37239AB4C303189576071AF5578FFCA80504'.!
Item was added:
+ ----- Method: IntegerTest>>testPrimesUpTo (in category 'tests - basic') -----
+ testPrimesUpTo
+
+ | primes nn|
+ primes := Integer primesUpTo: 100.
+ self assert: primes = #(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71 73 79 83 89 97).
+
+ "upTo: semantics means 'non-inclusive'"
+ primes := Integer primesUpTo: 5.
+ self assert: primes = #(2 3).
+
+ "this test is green for nn>25000, see #testLargePrimesUpTo"
+ nn := 5.
+ self deny: (Integer primesUpTo: nn) last = nn.
+ self assert: (Integer primesUpTo: nn + 1) last = nn.!
Item was added:
+ ----- Method: IntegerTest>>testPrintOnBaseShowRadix (in category 'tests - printing') -----
+ testPrintOnBaseShowRadix
+ | s |
+ s := '' writeStream.
+ 123 printOn: s base: 10 showRadix: false.
+ self assert: (s contents = '123').
+
+ s := '' writeStream.
+ 123 printOn: s base: 10 showRadix: true.
+ self assert: (s contents = '10r123').
+
+ s := '' writeStream.
+ 123 printOn: s base: 8 showRadix: false.
+ self assert: (s contents = '173').
+
+ s := '' writeStream.
+ 123 printOn: s base: 8 showRadix: true.
+ self assert: (s contents = '8r173').!
Item was added:
+ ----- Method: IntegerTest>>testPrintStringBase (in category 'tests - printing') -----
+ testPrintStringBase
+
+ 2 to: 32 do: [:b |
+ 1 to: 1000//b do: [:n |
+ | bRaisedToN |
+ bRaisedToN := b raisedTo: n.
+ self assert: (bRaisedToN - 1 printStringBase: b) = (String new: n withAll: (Character digitValue: b-1)).
+ self assert: (bRaisedToN printStringBase: b) = ('1' , (String new: n withAll: $0)).
+
+ self assert: (bRaisedToN negated + 1 printStringBase: b) = ('-' , (String new: n withAll: (Character digitValue: b-1))).
+ self assert: (bRaisedToN negated printStringBase: b) = ('-1' , (String new: n withAll: $0))]].
+ !
Item was added:
+ ----- Method: IntegerTest>>testQuoRem (in category 'tests - arithmetic') -----
+ testQuoRem
+ | suite |
+ suite := #( 1 2 5 1000 123456798 111222333444555 987654321098765432109876 ).
+ suite := suite , (suite collect: [:e | e negated]).
+ suite do: [:a |
+ suite do: [:b |
+ | q r |
+ q := a quo: b.
+ r := a rem: b.
+ self assert: b * q + r = a.
+ self assert: r abs < b abs.
+ self assert: (r isZero or: [a negative = r negative])]].!
Item was added:
+ ----- Method: IntegerTest>>testRaisedToErrorConditions (in category 'tests - mathematical functions') -----
+ testRaisedToErrorConditions
+ "
+ IntegerTest new testRaisedToErrorConditions
+ "
+
+ self should: [ -2 raisedTo: 1/4 ] raise: ArithmeticError.
+ self should: [ -2 raisedTo: 1.24 ] raise: ArithmeticError.!
Item was added:
+ ----- Method: IntegerTest>>testRaisedToModulo (in category 'tests - arithmetic') -----
+ testRaisedToModulo
+ #(301 2047) do: [:m |
+ 1 to: m - 1 by: (m // 30) do: [:x |
+ 11 to: m - 1 by: (m // 40) do: [:y |
+ self assert: (x raisedTo: y) \\ m = (x raisedTo: y modulo: m)]]].
+ self assert: (8951195 raisedTo: 7742931 modulo: 15485863) = 15485862.!
Item was added:
+ ----- Method: IntegerTest>>testRange (in category 'tests - basic') -----
+ testRange
+ self assert: SmallInteger maxVal class equals: SmallInteger.
+ self assert: (SmallInteger maxVal + 1) class equals: LargePositiveInteger.
+ self assert: SmallInteger minVal class equals: SmallInteger.
+ self assert: (SmallInteger minVal - 1) class equals: LargeNegativeInteger!
Item was added:
+ ----- Method: IntegerTest>>testReadFrom (in category 'tests - instance creation') -----
+ testReadFrom
+ "Ensure remaining characters in a stream are not lost when parsing an integer."
+
+ #(
+ ('12' 12 '')
+ ('-350' -350 '')
+ ('+27' 27 '')
+ ('2r101 embedded radix are not allowed' 2 'r101 embedded radix are not allowed')
+ ('25e3 exponent is ignored' 25 'e3 exponent is ignored')
+ ('25s2 scale is ignored' 25 's2 scale is ignored')
+ ('25. decimal separator is ignored' 25 '. decimal separator is ignored')
+ ('25.30 fraction part is ignored' 25 '.30 fraction part is ignored')
+ ('123r is not a radix specification' 123 'r is not a radix specification')
+ ) do: [:each |
+ [:string :numericValue :expectedRest |
+ | readStream result rest |
+ readStream := string readStream.
+ result := Integer readFrom: readStream.
+ rest := readStream upToEnd.
+ self assert: result isInteger.
+ self assert: result = numericValue.
+ self assert: rest = expectedRest.
+ ] valueWithArguments: each]!
Item was added:
+ ----- Method: IntegerTest>>testReciprocalModulo (in category 'tests - arithmetic') -----
+ testReciprocalModulo
+ 1 to: 512 do: [:a |
+ a + 1 to: 512 do: [:b |
+ | c |
+ (a gcd: b) = 1
+ ifTrue:
+ [c := a reciprocalModulo: b.
+ self assert: (a * c) \\ b = 1]
+ ifFalse: [self should: [ a reciprocalModulo: b ] raise: Error]]].!
Item was added:
+ ----- Method: IntegerTest>>testRomanPrinting (in category 'tests - printing') -----
+ testRomanPrinting
+ self assert: 0 printStringRoman = ''. "No symbol for zero"
+ self assert: 1 printStringRoman = 'I'.
+ self assert: 2 printStringRoman = 'II'.
+ self assert: 3 printStringRoman = 'III'.
+ self assert: 4 printStringRoman = 'IV'.
+ self assert: 5 printStringRoman = 'V'.
+ self assert: 6 printStringRoman = 'VI'.
+ self assert: 7 printStringRoman = 'VII'.
+ self assert: 8 printStringRoman = 'VIII'.
+ self assert: 9 printStringRoman = 'IX'.
+ self assert: 10 printStringRoman = 'X'.
+ self assert: 23 printStringRoman = 'XXIII'.
+ self assert: 36 printStringRoman = 'XXXVI'.
+ self assert: 49 printStringRoman = 'XLIX'.
+ self assert: 62 printStringRoman = 'LXII'.
+ self assert: 75 printStringRoman = 'LXXV'.
+ self assert: 88 printStringRoman = 'LXXXVIII'.
+ self assert: 99 printStringRoman = 'XCIX'.
+ self assert: 100 printStringRoman = 'C'.
+ self assert: 101 printStringRoman = 'CI'.
+ self assert: 196 printStringRoman = 'CXCVI'.
+ self assert: 197 printStringRoman = 'CXCVII'.
+ self assert: 198 printStringRoman = 'CXCVIII'.
+ self assert: 293 printStringRoman = 'CCXCIII'.
+ self assert: 294 printStringRoman = 'CCXCIV'.
+ self assert: 295 printStringRoman = 'CCXCV'.
+ self assert: 390 printStringRoman = 'CCCXC'.
+ self assert: 391 printStringRoman = 'CCCXCI'.
+ self assert: 392 printStringRoman = 'CCCXCII'.
+ self assert: 487 printStringRoman = 'CDLXXXVII'.
+ self assert: 488 printStringRoman = 'CDLXXXVIII'.
+ self assert: 489 printStringRoman = 'CDLXXXIX'.
+ self assert: 584 printStringRoman = 'DLXXXIV'.
+ self assert: 585 printStringRoman = 'DLXXXV'.
+ self assert: 586 printStringRoman = 'DLXXXVI'.
+ self assert: 681 printStringRoman = 'DCLXXXI'.
+ self assert: 682 printStringRoman = 'DCLXXXII'.
+ self assert: 683 printStringRoman = 'DCLXXXIII'.
+ self assert: 778 printStringRoman = 'DCCLXXVIII'.
+ self assert: 779 printStringRoman = 'DCCLXXIX'.
+ self assert: 780 printStringRoman = 'DCCLXXX'.
+ self assert: 875 printStringRoman = 'DCCCLXXV'.
+ self assert: 876 printStringRoman = 'DCCCLXXVI'.
+ self assert: 877 printStringRoman = 'DCCCLXXVII'.
+ self assert: 972 printStringRoman = 'CMLXXII'.
+ self assert: 973 printStringRoman = 'CMLXXIII'.
+ self assert: 974 printStringRoman = 'CMLXXIV'.
+ self assert: 1069 printStringRoman = 'MLXIX'.
+ self assert: 1070 printStringRoman = 'MLXX'.
+ self assert: 1071 printStringRoman = 'MLXXI'.
+ self assert: 1166 printStringRoman = 'MCLXVI'.
+ self assert: 1167 printStringRoman = 'MCLXVII'.
+ self assert: 1168 printStringRoman = 'MCLXVIII'.
+ self assert: 1263 printStringRoman = 'MCCLXIII'.
+ self assert: 1264 printStringRoman = 'MCCLXIV'.
+ self assert: 1265 printStringRoman = 'MCCLXV'.
+ self assert: 1360 printStringRoman = 'MCCCLX'.
+ self assert: 1361 printStringRoman = 'MCCCLXI'.
+ self assert: 1362 printStringRoman = 'MCCCLXII'.
+ self assert: 1457 printStringRoman = 'MCDLVII'.
+ self assert: 1458 printStringRoman = 'MCDLVIII'.
+ self assert: 1459 printStringRoman = 'MCDLIX'.
+ self assert: 1554 printStringRoman = 'MDLIV'.
+ self assert: 1555 printStringRoman = 'MDLV'.
+ self assert: 1556 printStringRoman = 'MDLVI'.
+ self assert: 1651 printStringRoman = 'MDCLI'.
+ self assert: 1652 printStringRoman = 'MDCLII'.
+ self assert: 1653 printStringRoman = 'MDCLIII'.
+ self assert: 1748 printStringRoman = 'MDCCXLVIII'.
+ self assert: 1749 printStringRoman = 'MDCCXLIX'.
+ self assert: 1750 printStringRoman = 'MDCCL'.
+ self assert: 1845 printStringRoman = 'MDCCCXLV'.
+ self assert: 1846 printStringRoman = 'MDCCCXLVI'.
+ self assert: 1847 printStringRoman = 'MDCCCXLVII'.
+ self assert: 1942 printStringRoman = 'MCMXLII'.
+ self assert: 1943 printStringRoman = 'MCMXLIII'.
+ self assert: 1944 printStringRoman = 'MCMXLIV'.
+ self assert: 2004 printStringRoman = 'MMIV'.
+
+ self assert: -1 printStringRoman = '-I'.
+ self assert: -2 printStringRoman = '-II'.
+ self assert: -3 printStringRoman = '-III'.
+ self assert: -4 printStringRoman = '-IV'.
+ self assert: -5 printStringRoman = '-V'.
+ self assert: -6 printStringRoman = '-VI'.
+ self assert: -7 printStringRoman = '-VII'.
+ self assert: -8 printStringRoman = '-VIII'.
+ self assert: -9 printStringRoman = '-IX'.
+ self assert: -10 printStringRoman = '-X'.
+ !
Item was added:
+ ----- Method: IntegerTest>>testRoundDownTo (in category 'tests - truncation and round off') -----
+ testRoundDownTo
+
+ self
+ assert: #( -40 -40 -40 -20 -20 -20 0 0 0 20 20 20 40 )
+ equals: (#( -40 -30 -29 -20 -10 -9 0 9 10 20 29 30 40 )
+ collect: [:num | num roundDownTo: 20]).!
Item was added:
+ ----- Method: IntegerTest>>testRoundTo (in category 'tests - truncation and round off') -----
+ testRoundTo
+
+ self
+ assert: #( -40 -40 -20 -20 -20 0 0 0 20 20 20 40 40 )
+ equals: (#( -40 -30 -29 -20 -10 -9 0 9 10 20 29 30 40 )
+ collect: [:num | num roundTo: 20]).!
Item was added:
+ ----- Method: IntegerTest>>testRoundUpTo (in category 'tests - truncation and round off') -----
+ testRoundUpTo
+
+ self
+ assert: #( -40 -20 -20 -20 0 0 0 20 20 20 40 40 40 )
+ equals: (#( -40 -30 -29 -20 -10 -9 0 9 10 20 29 30 40 )
+ collect: [:num | num roundUpTo: 20]).!
Item was added:
+ ----- Method: IntegerTest>>testSqrtErrorConditions (in category 'tests - mathematical functions') -----
+ testSqrtErrorConditions
+ "
+ IntegerTest new testSqrtErrorConditions
+ "
+
+ self should: [ -1 sqrt ] raise: ArithmeticError!
Item was added:
+ ----- Method: IntegerTest>>testSqrtFloor (in category 'tests - mathematical functions') -----
+ testSqrtFloor
+
+ #(-1234567890123 -10 -5 -1) do: [ :each |
+ self should: [ each sqrtFloor ] raise: Error ].
+ #(
+ 0 1 2 3 4 5 10 16 30 160479924 386234481 501619156 524723498 580855366 766098594 834165249 1020363860 1042083924 1049218924
+ 1459774772895569 3050005981408238 4856589481837079 5650488387708463 7831037396100244) do: [ :each |
+ self assert: each asFloat sqrt floor = each sqrtFloor ]
+ !
Item was added:
+ ----- Method: IntegerTest>>testSqrtRem (in category 'tests - mathematical functions') -----
+ testSqrtRem
+
+ #(
+ 0 1 2 3 4 5 10 16 30 160479924 386234481 501619156 524723498 580855366 766098594 834165249 1020363860 1042083924 1049218924
+ 1459774772895569 3050005981408238 4856589481837079 5650488387708463 7831037396100244) do: [ :each |
+ | sr |
+ sr := each sqrtRem.
+ self assert: sr first squared <= each.
+ self assert: (sr first+1) squared > each.
+ self assert: sr first squared + sr last = each]
+ !
Item was added:
+ ----- Method: IntegerTest>>testTwoComplementBitLogicWithCarry (in category 'tests - bitLogic') -----
+ testTwoComplementBitLogicWithCarry
+ "This is non regression test for http://bugs.squeak.org/view.php?id=6874"
+
+ "By property of two complement, following operation is:
+ ...111110000 this is -16
+ ...111101111 this is -16-1
+ ...111100000 this is -32, the result of bitAnd: on two complement
+
+ This test used to fail with n=31 39 47.... because of bug 6874"
+
+ self assert: ((2 to: 80) allSatisfy: [:n | ((2 raisedTo: n) negated bitAnd: (2 raisedTo: n) negated - 1) = (2 raisedTo: n + 1) negated]).!
Item was added:
+ ----- Method: IntegerTest>>testTwoComplementRightShift (in category 'tests - bitLogic') -----
+ testTwoComplementRightShift
+ "self run: #testTwoComplementRightShift"
+
+ | large small |
+ small := 2 << 16.
+ large := 2 << 32.
+ self assert: ((small negated bitShift: -1) ~= ((small + 1) negated bitShift: -1)
+ == ((large negated bitShift: -1) ~= ((large + 1) negated bitShift: -1))).
+
+ self assert: ((small bitShift: -1) ~= (small + 1 bitShift: -1)
+ == ((large bitShift: -1) ~= (large + 1 bitShift: -1))).!
Item was added:
+ ClassTestCase subclass: #LargeNegativeIntegerTest
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'KernelTests-Numbers'!
Item was added:
+ ----- Method: LargeNegativeIntegerTest>>testDenormalizedPrintString (in category 'tests') -----
+ testDenormalizedPrintString
+ "Check that an un-normalized instance behaves reasonably."
+
+ | i i0 |
+ i := LargeNegativeInteger new: 4.
+ i basicAt: 2 put: 255.
+ self assert: i size = 4.
+ self assert: i printString = '-65280'. "-256*255"
+ self assert: i normalize = -65280.
+ self assert: (i normalize isMemberOf: SmallInteger).
+
+ i0 := LargeNegativeInteger new: 0.
+ self assert: i0 size = 0.
+ self assert: i0 printString = '-0'.
+ self assert: i0 normalize = 0.
+ self assert: (i0 normalize isMemberOf: SmallInteger)!
Item was added:
+ ----- Method: LargeNegativeIntegerTest>>testDigitAt (in category 'tests') -----
+ testDigitAt
+
+ | lni |
+ lni := -114605103402541699037609980192546360895434064385.
+ 1 to: 20 do: [:i | | digit |
+ digit := lni digitAt: i.
+ self assert: i equals: digit]
+ !
Item was added:
+ ----- Method: LargeNegativeIntegerTest>>testDigitAtPut (in category 'tests') -----
+ testDigitAtPut
+
+ | lni |
+ lni := LargeNegativeInteger new: 20.
+ 1 to: 20 do: [:i | lni digitAt: i put: i].
+ self assert: -114605103402541699037609980192546360895434064385equals: lni
+ !
Item was added:
+ ----- Method: LargeNegativeIntegerTest>>testDigitLength (in category 'tests') -----
+ testDigitLength
+
+ | lni |
+ lni := -114605103402541699037609980192546360895434064385.
+ self assert: 20 equals: lni digitLength
+ !
Item was added:
+ ----- Method: LargeNegativeIntegerTest>>testEmptyTemplate (in category 'tests') -----
+ testEmptyTemplate
+ "Check that an uninitialized instance behaves reasonably."
+
+ | i |
+ i := LargeNegativeInteger new: 4.
+ self assert: i size = 4.
+ self assert: i printString = '-0'.
+ self assert: i normalize = 0.
+ self assert: (i normalize isMemberOf: SmallInteger)!
Item was added:
+ ----- Method: LargeNegativeIntegerTest>>testMinimumNegativeIntegerArithmetic (in category 'tests') -----
+ testMinimumNegativeIntegerArithmetic
+ "We are speaking of minimum integer in underlying hardware here.
+ In 2-complement, abs(INT_MIN) = (INT-MAX+1) and thus overflows hardware register.
+ Since some old VM forgot this edge case they may fail and it's better to be aware of it.
+ http://code.google.com/p/cog/issues/detail?id=92
+ http://bugs.squeak.org/view.php?id=7705
+ We only test the cases of 32 and 64 bit signed integers."
+
+ #(32 64) do: [:nBits |
+ | largePositiveInt largeNegativeInt |
+ largePositiveInt := (1 << (nBits - 1)).
+ largeNegativeInt := largePositiveInt negated.
+ self assert: (largeNegativeInt >> 3) equals: (largeNegativeInt bitInvert >> 3) bitInvert.
+ self assert: (largeNegativeInt + 1) equals: (largePositiveInt - 1) negated.
+ self assert: (largeNegativeInt - -1) equals: (largePositiveInt - 1) negated.
+ self assert: (largeNegativeInt // -1) equals: largePositiveInt.
+ self assert: (largeNegativeInt \\ -1) equals: 0.
+ self assert: (largeNegativeInt rem: -1) equals: 0.
+ self assert: (largeNegativeInt quo: -1) equals: largePositiveInt.
+ self assert: (largeNegativeInt * -1) equals: largePositiveInt.
+ self assert: (largeNegativeInt / -1) equals: largePositiveInt]!
Item was added:
+ ----- Method: LargeNegativeIntegerTest>>testReplaceFromToWithStartingAt (in category 'tests') -----
+ testReplaceFromToWithStartingAt
+
+ | lni20 lni7 |
+ lni20 := LargeNegativeInteger new: 20.
+ 1 to: 20 do: [:i | lni20 digitAt: i put: i].
+ lni7 := LargeNegativeInteger new: 7.
+ 1 to: 7 do: [:i | lni7 digitAt: i put: 11 - i].
+ lni20 replaceFrom: 6 to: 10 with: lni7 startingAt: 2.
+ "unmodified digits"
+ (1 to: 5) , (11 to: 20) do: [:e | | digit |
+ digit := lni20 digitAt: e.
+ self assert: e equals: digit].
+ "replaced digits"
+ 6 to: 10 do: [:e | | digit replacementDigit |
+ digit := lni20 digitAt: e.
+ replacementDigit := lni7 digitAt: e - 4.
+ self assert: replacementDigit equals: digit]
+ !
Item was added:
+ ----- Method: LargeNegativeIntegerTest>>testSqrt (in category 'tests - mathematical functions') -----
+ testSqrt
+ self should: [(SmallInteger minVal - 1) sqrt] raise: DomainError!
Item was added:
+ ClassTestCase subclass: #LargePositiveIntegerTest
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'KernelTests-Numbers'!
Item was added:
+ ----- Method: LargePositiveIntegerTest>>assert:classAndValueEquals: (in category 'asserting') -----
+ assert: expected classAndValueEquals: actual
+ self
+ assert: expected equals: actual;
+ assert: expected class equals: actual class.!
Item was added:
+ ----- Method: LargePositiveIntegerTest>>assertSqrtCorrectlyRoundedForExponent: (in category 'asserting') -----
+ assertSqrtCorrectlyRoundedForExponent: exp
+ "Requires exp > Float precision, so that f ulp/2 is integer"
+ {1.5. 1.25 squared. 2.0 predecessor} do: [:sf |
+ | f xe xp xm |
+
+ f := sf timesTwoPower: exp.
+
+ "make two integers around the pivot"
+ xe := f asInteger + (f ulp asInteger / 2).
+ xm := xe squared - 1.
+ xp := xe squared + 1.
+ self assert: xe squared sqrt equals: xe.
+ self assert: xe squared sqrt isInteger.
+
+ "check rounding when result is near f squared"
+ self assert: xm sqrt equals: f.
+ self assert: xm sqrt isFloat.
+ self assert: xp sqrt equals: f successor.
+ self assert: xp sqrt isFloat.
+
+ "same in the other direction"
+ xe := f asInteger - (f ulp asInteger / 2).
+ xm := xe squared - 1.
+ xp := xe squared + 1.
+ self assert: xe squared sqrt equals: xe.
+ self assert: xe squared sqrt isInteger.
+
+ "check rounding when result is near f squared"
+ self assert: xm sqrt equals: f predecessor.
+ self assert: xm sqrt isFloat.
+ self assert: xp sqrt equals: f.
+ self assert: xp sqrt isFloat].!
Item was added:
+ ----- Method: LargePositiveIntegerTest>>testBitShift (in category 'tests') -----
+ testBitShift
+
+ "Check bitShift from and back to SmallInts"
+
+ 1 to: 257 do: [:i | self should: [((i bitShift: i) bitShift: 0-i) == i]].!
Item was added:
+ ----- Method: LargePositiveIntegerTest>>testDenormalizedPrintString (in category 'tests') -----
+ testDenormalizedPrintString
+ "Check that an un-normalized instance behaves reasonably."
+
+ | i i0 |
+ i := LargePositiveInteger new: 4.
+ i basicAt: 2 put: 255.
+ self assert: i size = 4.
+ self assert: i printString = '65280'. "256*255"
+ self assert: i normalize = 65280.
+ self assert: (i normalize isMemberOf: SmallInteger).
+
+ i0 := LargePositiveInteger new: 0.
+ self assert: i0 size = 0.
+ self assert: i0 printString = '0'.
+ self assert: i0 normalize = 0.
+ self assert: (i0 normalize isMemberOf: SmallInteger)!
Item was added:
+ ----- Method: LargePositiveIntegerTest>>testDigitAt (in category 'tests') -----
+ testDigitAt
+
+ | lpi |
+ lpi := 114605103402541699037609980192546360895434064385.
+ 1 to: 20 do: [:i | | digit |
+ digit := lpi digitAt: i.
+ self assert: i equals: digit]
+ !
Item was added:
+ ----- Method: LargePositiveIntegerTest>>testDigitAtPut (in category 'tests') -----
+ testDigitAtPut
+
+ | lpi |
+ lpi := LargePositiveInteger new: 20.
+ 1 to: 20 do: [:i | lpi digitAt: i put: i].
+ self assert: 114605103402541699037609980192546360895434064385equals: lpi
+ !
Item was added:
+ ----- Method: LargePositiveIntegerTest>>testDigitDiv (in category 'tests') -----
+ testDigitDiv
+ | a b q r qr ap bp |
+ ap := self x23kbits.
+ bp := self x13kbits.
+ self assert: (ap digitDivSplit: bp) = ((ap digitDiv: bp neg: false) collect: #normalize).
+ #(#yourself #negated) do: [:opa |
+ #(#yourself #negated) do: [:opb |
+ a := ap perform: opa.
+ b := bp perform: opb.
+ qr := a digitDiv: b neg: opa ~~ opb.
+ q := qr first normalize.
+ r := qr last normalize.
+ self assert: q * b + r = a.
+ self assert: r abs < b abs.
+ self assert: a positive ==> r positive.
+ self assert: a negative ==> (r negative | r isZero)]]
+ !
Item was added:
+ ----- Method: LargePositiveIntegerTest>>testDigitLength (in category 'tests') -----
+ testDigitLength
+
+ | lpi |
+ lpi := 114605103402541699037609980192546360895434064385.
+ self assert: 20 equals: lpi digitLength
+ !
Item was added:
+ ----- Method: LargePositiveIntegerTest>>testEmptyTemplate (in category 'tests') -----
+ testEmptyTemplate
+
+ "Check that an uninitialized instance behaves reasonably."
+
+ | i |
+ i := LargePositiveInteger new: 4.
+ self assert: i size = 4.
+ self assert: i printString = '0'.
+ self assert: i normalize = 0.
+ self assert: (i normalize isMemberOf: SmallInteger)!
Item was added:
+ ----- Method: LargePositiveIntegerTest>>testFastMultiply (in category 'tests') -----
+ testFastMultiply
+ | a b ab ap bp |
+ ap := self x92kbits.
+ bp := self x106kbits.
+ #(#yourself #negated) do: [:opa |
+ #(#yourself #negated) do: [:opb |
+ a := ap perform: opa.
+ b := bp perform: opb.
+ ab := a * b.
+ self assert: (a multiplyByInteger: b) = ab.
+ self assert: (a digitMultiply: b neg: a negative ~~ b negative) = ab.
+ self assert: (a digitMul22: b) = ab.
+ self assert: (a digitMul23: b) = ab.
+ self assert: (a digitMul33: b) = ab]]!
Item was added:
+ ----- Method: LargePositiveIntegerTest>>testLargeSqrtFloor (in category 'tests') -----
+ testLargeSqrtFloor
+ "This test fails if a careless implementation naivly factors out the power of two (remove the trailing zeroes up to lowBit).
+ This was the case in a previous Squeak 4.x implementation."
+
+ | large root |
+ large := (SmallInteger maxVal << 100 + 1) << 100.
+ root := large sqrtFloor.
+ self assert: root squared <= large.
+ self assert: (root+1) squared > large.!
Item was added:
+ ----- Method: LargePositiveIntegerTest>>testMultDicAddSub (in category 'tests') -----
+ testMultDicAddSub
+ "self run: #testMultDicAddSub"
+
+ | n f f1 |
+ n := 100.
+ f := 100 factorial.
+ f1 := f*(n+1).
+ n timesRepeat: [f1 := f1 - f].
+ self assert: (f1 = f).
+
+ n timesRepeat: [f1 := f1 + f].
+ self assert: (f1 // f = (n+1)).
+ self assert: (f1 negated = (Number readFrom: '-' , f1 printString)).!
Item was added:
+ ----- Method: LargePositiveIntegerTest>>testNormalize (in category 'tests') -----
+ testNormalize
+ "self run: #testNormalize"
+ "Check normalization and conversion to/from SmallInts"
+
+ self assert: ((SmallInteger maxVal + 1 - 1) == SmallInteger maxVal).
+ self assert: (SmallInteger maxVal + 3 - 6) == (SmallInteger maxVal-3).
+ self should: ((SmallInteger minVal - 1 + 1) == SmallInteger minVal).
+ self assert: (SmallInteger minVal - 3 + 6) == (SmallInteger minVal+3).!
Item was added:
+ ----- Method: LargePositiveIntegerTest>>testReciprocalModulo (in category 'tests') -----
+ testReciprocalModulo
+ | large r |
+ large := 1 bitShift: 48.
+ r := Random seed: 46912151.
+ 4691 timesRepeat:
+ [| a b c t |
+ a := (r nextInt: large) + 1.
+ b := (r nextInt: large) + 1.
+ a > b ifTrue: [t := a. a:= b. b := t].
+ (a gcd: b) = 1
+ ifTrue:
+ [c := a reciprocalModulo: b.
+ self assert: (a * c) \\ b = 1.]
+ ifFalse: [self should: [ a reciprocalModulo: b ] raise: Error]].!
Item was added:
+ ----- Method: LargePositiveIntegerTest>>testReplaceFromToWithStartingAt (in category 'tests') -----
+ testReplaceFromToWithStartingAt
+
+ | lpi20 lpi7 |
+ lpi20 := LargePositiveInteger new: 20.
+ 1 to: 20 do: [:i | lpi20 digitAt: i put: i].
+ lpi7 := LargePositiveInteger new: 7.
+ 1 to: 7 do: [:i | lpi7 digitAt: i put: 11 - i].
+ lpi20 replaceFrom: 6 to: 10 with: lpi7 startingAt: 2.
+ "unmodified digits"
+ (1 to: 5) , (11 to: 20) do: [:e | | digit |
+ digit := lpi20 digitAt: e.
+ self assert: e equals: digit].
+ "replaced digits"
+ 6 to: 10 do: [:e | | digit replacementDigit |
+ digit := lpi20 digitAt: e.
+ replacementDigit := lpi7 digitAt: e - 4.
+ self assert: replacementDigit equals: digit]
+ !
Item was added:
+ ----- Method: LargePositiveIntegerTest>>testSqrt (in category 'tests - mathematical functions') -----
+ testSqrt
+ self assert: (SmallInteger maxVal + 1) sqrt equals: (SmallInteger maxVal + 1) asFloat sqrt.!
Item was added:
+ ----- Method: LargePositiveIntegerTest>>testSqrtCorrectlyRounded (in category 'tests - mathematical functions') -----
+ testSqrtCorrectlyRounded
+ self assertSqrtCorrectlyRoundedForExponent: Float precision * 2 - 1.
+ self assertSqrtCorrectlyRoundedForExponent: Float precision * 2 + 1.
+ self assertSqrtCorrectlyRoundedForExponent: Float precision * 2 + 3.
+ self assertSqrtCorrectlyRoundedForExponent: Float precision * 3 // 2.
+ self assertSqrtCorrectlyRoundedForExponent: Float emax* 2 // 3. "such that asFloat would overflow"
+ self assertSqrtCorrectlyRoundedForExponent: Float emax.!
Item was added:
+ ----- Method: LargePositiveIntegerTest>>testSqrtNearExactTie (in category 'tests - mathematical functions') -----
+ testSqrtNearExactTie
+ | p q evenTie oddTie perfectSquare inexactSquare |
+ "first construct square root results that lie exactly between 2 consecutive Float"
+ p := Float precision.
+ q := Float precision // 4.
+ evenTie := 1 << q + 1 << q + 1 << (p - q - q) + 1.
+ self assert: p + 1 = evenTie highBit.
+ self assert: evenTie asFloat significandAsInteger even. "evenTie round down to even"
+ self assert: evenTie asFloat ulp asFraction / 2 + evenTie asFloat asFraction = evenTie.
+ oddTie := 1 << q + 1 << q + 1 << (p - q - q) + 2r11.
+ self assert: p + 1 = oddTie highBit.
+ self assert: oddTie asFloat significandAsInteger even. "oddTie round up to even"
+ self assert: oddTie asFloat ulp asFraction / -2 + oddTie asFloat asFraction = oddTie.
+
+ "then assert that we can retrieve the exact root"
+ perfectSquare := evenTie squared.
+ self assert: perfectSquare sqrt classAndValueEquals: evenTie.
+
+ "now take an inexact square by excess : it falls above exact tie, and should round up"
+ inexactSquare := evenTie squared + 1.
+ self deny: inexactSquare mightBeASquare.
+ self assert: inexactSquare sqrt classAndValueEquals: evenTie asFloat successor.
+ "same with one possibly exact square so that we take both paths"
+ inexactSquare := evenTie squared + 3.
+ self assert: inexactSquare mightBeASquare.
+ self assert: inexactSquare sqrt classAndValueEquals: evenTie asFloat successor.
+ "same with less bits and a possibly exact square so that we explore yet another path"
+ inexactSquare := evenTie squared + 3 // 4.
+ self assert: inexactSquare * 4 equals: evenTie squared + 3.
+ self assert: inexactSquare mightBeASquare.
+ self assert: inexactSquare sqrt classAndValueEquals: (evenTie asFloat successor / 2).
+ "same with very very far bit to solve the tie"
+ inexactSquare := evenTie squared << 100 + 2.
+ self deny: inexactSquare mightBeASquare.
+ self assert: inexactSquare sqrt classAndValueEquals: (evenTie asFloat successor timesTwoPower: 50).
+
+ "Redo the same with odd tie, just to be sure"
+ perfectSquare := oddTie squared.
+ self assert: perfectSquare sqrt classAndValueEquals: oddTie.
+
+ "now take an inexact square by default : it falls below exact tie, and should round down"
+ inexactSquare := oddTie squared - 1.
+ self deny: inexactSquare mightBeASquare.
+ self assert: inexactSquare sqrt classAndValueEquals: oddTie asFloat predecessor.
+ "same for not possibly exact case"
+ inexactSquare := oddTie squared - 5.
+ self assert: inexactSquare mightBeASquare.
+ self assert: inexactSquare sqrt classAndValueEquals: oddTie asFloat predecessor.
+ "same with less bits"
+ inexactSquare := oddTie squared - 9 // 4.
+ self assert: inexactSquare * 4 equals: oddTie squared - 9.
+ self assert: inexactSquare mightBeASquare.
+ self assert: inexactSquare sqrt classAndValueEquals: (oddTie asFloat predecessor / 2).
+ "same with very very far bit to solve the tie"
+ inexactSquare := oddTie squared << 100 - 2.
+ self deny: inexactSquare mightBeASquare.
+ self assert: inexactSquare sqrt classAndValueEquals: (oddTie asFloat predecessor timesTwoPower: 50).!
Item was added:
+ ----- Method: LargePositiveIntegerTest>>testSqrtRem (in category 'tests') -----
+ testSqrtRem
+ | x sr |
+ x := self x92kbits.
+ sr := x sqrtRem.
+ self assert: sr first squared <= x.
+ self assert: (sr first+1) squared > x.
+ self assert: sr first squared + sr last = x.!
Item was added:
+ ----- Method: LargePositiveIntegerTest>>testSquared (in category 'tests') -----
+ testSquared
+
+ | large ref |
+ large := self x23kbits.
+ ref := large * large.
+ self assert: ref = large squared.
+ self assert: ref = large squaredByHalf.
+ self assert: ref = large squaredByThird.
+ self assert: ref = large squaredByFourth.!
Item was added:
+ ----- Method: LargePositiveIntegerTest>>x106kbits (in category 'accessing') -----
+ x106kbits
+ "Return a 106 kilo bits integer"
+ ^(15 to: 55 by: 4)
+ inject: 9876543210
+ into: [:big :bits | big * big << bits + bits]!
Item was added:
+ ----- Method: LargePositiveIntegerTest>>x13kbits (in category 'accessing') -----
+ x13kbits
+ "Return a 13 kilo bits integer"
+ ^(15 to: 44 by: 4)
+ inject: 9753102468
+ into: [:big :bits | big * big << bits + bits]!
Item was added:
+ ----- Method: LargePositiveIntegerTest>>x23kbits (in category 'accessing') -----
+ x23kbits
+ "Return a 23 kilo bits integer"
+ ^(11 to: 44 by: 4)
+ inject: 1234567890
+ into: [:big :bits | big * big << bits + bits]!
Item was added:
+ ----- Method: LargePositiveIntegerTest>>x92kbits (in category 'accessing') -----
+ x92kbits
+ "Return a 92 kilo bits integer"
+ ^(11 to: 51 by: 4)
+ inject: 1357924680
+ into: [:big :bits | big * big << bits + bits]!
Item was added:
+ TestCase subclass: #LiteralRefLocatorTest
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'KernelTests-Methods'!
Item was added:
+ ----- Method: LiteralRefLocatorTest>>testFindLiteralsInBytecode (in category 'tests') -----
+ testFindLiteralsInBytecode
+ "Create a method referencing integers, characters, special selectors and nil, true & false.
+ Compile it and check that the objects are found."
+ | source primary secondary binarySpecials integers characters |
+ binarySpecials := Smalltalk specialSelectors select: [:s| s isSymbol and: [s isBinary]].
+ "-65536 to 65535 in powers of two"
+ integers := ((16 to: 1 by: -1) collect: [:power| (2 raisedTo: power) negated]),
+ ((0 to: 16) collect: [:power| (2 raisedTo: power) - 1]).
+ "some printable characters; alas none have code > 255"
+ characters := (0 to: 65535)
+ select: [:n| (n between: 132 and: 160) not "these have no glyph in typical fonts"
+ and: [(Character value: n) shouldBePrintedAsLiteral]]
+ thenCollect: [:n| Character value: n].
+ [characters size > 32] whileTrue:
+ [characters := (1 to: characters size by: 2) collect: [:i| characters at: i]].
+
+ #(('' '') ('^[' ']')) do: "And the locators should work whether in a block or not"
+ [:pFixes|
+ source := ByteString streamContents:
+ [:s| | binaries |
+ binaries := binarySpecials readStream.
+ s nextPutAll: 'exampleMethod'; crtab; nextPutAll: pFixes first.
+ integers
+ do: [:n| s print: n]
+ separatedBy:
+ [binaries atEnd ifTrue: [binaries reset].
+ s space; nextPutAll: binaries next; space].
+ s nextPut: $.; crtab.
+ s nextPut: ${; space.
+ characters
+ do: [:c| s print: c]
+ separatedBy: [s nextPut: $.; space].
+ s space; nextPut: $}; nextPut: $.; crtab.
+ s nextPutAll: 'true ifTrue: [^nil] ifFalse: [^false]'; nextPutAll: pFixes last].
+ primary := CompiledCode classPool at: #PrimaryBytecodeSetEncoderClass.
+ secondary := CompiledCode classPool at: #SecondaryBytecodeSetEncoderClass.
+ { primary. secondary } do:
+ [:encoderClass| | method |
+ method := (Parser new
+ encoderClass: encoderClass;
+ parse: source class: self class)
+ generate: CompiledMethodTrailer empty.
+ binarySpecials, integers, characters, #(nil false true) do:
+ [:literal | self assert: (method hasLiteral: literal)].
+
+ "Now test for false positives..."
+ integers, characters, #(nil false true) do:
+ [:literal| | simpleSource simpleMethod |
+ simpleSource := ByteString streamContents:
+ [:s| s nextPutAll: 'exampleMethod'; crtab; nextPutAll: pFixes first; print: literal; nextPutAll: ' class'; nextPutAll: pFixes last].
+ simpleMethod := (Parser new
+ encoderClass: encoderClass;
+ parse: simpleSource class: self class)
+ generate: CompiledMethodTrailer empty.
+ binarySpecials, integers, characters, #(nil false true) do: [:anyLiteral |
+ anyLiteral == literal
+ ifTrue: [self assert: (simpleMethod hasLiteral: anyLiteral)]
+ ifFalse: [self deny: (simpleMethod hasLiteral: anyLiteral)]]]]]!
Item was added:
+ ----- Method: LiteralRefLocatorTest>>testThoroughFindLiteralsInBytecode (in category 'tests') -----
+ testThoroughFindLiteralsInBytecode
+ "Create a method referencing integers, characters, special selectors and nil, true & false.
+ Compile it and check that the objects are found."
+ | literals problem primary secondary |
+ literals := #(-1 0 1 $0 $1 1.0 #[1 2 3 4] 'one' #one nil true false NaN).
+ problem := Float bindingOf: #NaN.
+ primary := CompiledCode classPool at: #PrimaryBytecodeSetEncoderClass.
+ secondary := CompiledCode classPool at: #SecondaryBytecodeSetEncoderClass.
+ { primary. secondary } do:
+ [:encoderClass| | method |
+ #(('' '') ('^[' ']')) do: "And the locators should work whether in a block or not"
+ [:pFixes|
+ "NaN's binding should still be found even though (Float bindingOf: #NaN) ~= (Float bindingOf: #NaN)"
+ method := (Parser new
+ encoderClass: encoderClass;
+ parse: 'foo ', pFixes first, '^NaN', pFixes last class: Float)
+ generate: CompiledMethodTrailer empty.
+
+ "Check our problematic case first."
+ self assert: (method hasLiteral: problem).
+ "The selector of a method should never be found (unless it occurs as a literal or in a pragma)"
+ self deny: (method hasLiteral: method selector).
+
+ "All the literals should be found in a thorough search, but not otherwise"
+ method := (Parser new
+ encoderClass: encoderClass;
+ parse: 'foo ', pFixes first, '^', literals storeString, pFixes last class: Float)
+ generate: CompiledMethodTrailer empty.
+ literals, {problem key} do:
+ [:literal | self assert: (method hasLiteral: literal)]].
+
+ "Likewise if in a pragma"
+ method := (Parser new
+ encoderClass: encoderClass;
+ parse: 'foo <pragma: ', literals storeString, ' with: ', problem key storeString, '>' class: Float)
+ generate: CompiledMethodTrailer empty.
+ literals, {problem key} do:
+ [:literal | self assert: (method hasLiteral: literal)]]!
Item was added:
+ TestCase subclass: #MessageSendTest
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'KernelTests-Methods'!
Item was added:
+ ----- Method: MessageSendTest>>testNumArgs (in category 'tests') -----
+ testNumArgs
+ self
+ assert:
+ (MessageSend
+ receiver: Dictionary new
+ selector: #at:put:) numArgs = 2 ;
+ assert:
+ (MessageSend
+ receiver: 3
+ selector: #sqrt) numArgs = 0!
Item was added:
+ TestCase subclass: #MessageTest
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'KernelTests-Methods'!
Item was added:
+ ----- Method: MessageTest>>testMessageEquality (in category 'tests') -----
+ testMessageEquality
+
+ self assert: (Message selector: #= argument: 1) equals: (Message selector: #= argument: 1).
+ self assert: (Message selector: #= argument: 1) hash equals: (Message selector: #= argument: 1) hash.
+ self deny: (Message selector: #= argument: 1) equals: (Message selector: #= argument: 1.0)!
Item was added:
+ TestCase subclass: #MethodPragmaTest
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'KernelTests-Methods'!
Item was added:
+ ----- Method: MethodPragmaTest>>assertPragma:givesKeyword:arguments: (in category 'utilities') -----
+ assertPragma: aString givesKeyword: aSymbol arguments: anArray
+ | pragma decompiled pragmaString index |
+ pragma := self pragma: aString selector: #zork.
+ self assert: aSymbol equals: pragma keyword.
+ self assert: anArray equals: pragma arguments.
+ decompiled := (self class>>#zork) decompile.
+ self assert: (decompiled properties pragmas includes: pragma).
+ pragmaString := pragma printString.
+ "Pragma printString may contain a comment; if so, delete it"
+ (index := pragmaString indexOfSubCollection: '> "in ') > 0 ifTrue:
+ [pragmaString := pragmaString copyFrom: 1 to: index].
+ self assert: (decompiled printString includesSubstring: pragmaString)!
Item was added:
+ ----- Method: MethodPragmaTest>>compile:selector: (in category 'utilities') -----
+ compile: aString selector: aSelector
+ self class
+ compileSilently: aSelector , String lf , aString
+ classified: self methodCategory.
+ ^ self class >> aSelector.!
Item was added:
+ ----- Method: MethodPragmaTest>>methodCategory (in category 'utilities') -----
+ methodCategory
+ ^ #generated!
Item was added:
+ ----- Method: MethodPragmaTest>>pragma:selector: (in category 'utilities') -----
+ pragma: aString selector: aSelector
+ ^ (self compile: '<' , aString , '>' selector: aSelector)
+ pragmas first.!
Item was added:
+ ----- Method: MethodPragmaTest>>pragma:selector:times: (in category 'utilities') -----
+ pragma: aSymbol selector: aSelector times: anInteger
+ ^ (self
+ compile: (String streamContents: [ :stream |
+ (1 to: anInteger) asArray shuffled do: [ :each |
+ stream
+ nextPut: $<; nextPutAll: aSymbol; space;
+ print: each; nextPut: $>; cr ] ])
+ selector: aSelector)
+ pragmas.!
Item was added:
+ ----- Method: MethodPragmaTest>>tearDown (in category 'running') -----
+ tearDown
+ (self class organization listAtCategoryNamed: self methodCategory)
+ do: [ :each | self class removeSelectorSilently: each ].
+ self class organization removeCategory: self methodCategory.!
Item was added:
+ ----- Method: MethodPragmaTest>>testAllNamedFromTo (in category 'tests-finding') -----
+ testAllNamedFromTo
+ | pragmasCompiled pragmasDetected |
+ pragmasCompiled := self pragma: #foo: selector: #bar times: 5.
+ pragmasDetected := Pragma allNamed: #foo: from: self class to: Object.
+ self assert: pragmasDetected = pragmasCompiled.
+
+ pragmasDetected := Pragma allNamed: #foo: from: Object to: Object.
+ self assert: pragmasDetected isEmpty.!
Item was added:
+ ----- Method: MethodPragmaTest>>testAllNamedFromToSortedByArgument (in category 'tests-finding') -----
+ testAllNamedFromToSortedByArgument
+ | pragmasCompiled pragmasDetected |
+ pragmasCompiled := self pragma: #foo: selector: #bar times: 5.
+ pragmasDetected := Pragma allNamed: #foo: from: self class to: Object sortedByArgument: 1.
+ self assert: pragmasDetected = (pragmasCompiled
+ sort: [ :a :b | (a argumentAt: 1) < (b argumentAt: 1) ])!
Item was added:
+ ----- Method: MethodPragmaTest>>testAllNamedFromToSortedUsing (in category 'tests-finding') -----
+ testAllNamedFromToSortedUsing
+ | pragmasCompiled pragmasDetected |
+ pragmasCompiled := self pragma: #foo: selector: #bar times: 5.
+ pragmasDetected := Pragma
+ allNamed: #foo: from: self class to: Object
+ sortedUsing: [ :a :b | (a argumentAt: 1) > (b argumentAt: 1) ].
+ self assert: pragmasDetected = (pragmasCompiled
+ sort: [ :a :b | (a argumentAt: 1) > (b argumentAt: 1) ]).!
Item was added:
+ ----- Method: MethodPragmaTest>>testAllNamedIn (in category 'tests-finding') -----
+ testAllNamedIn
+ | pragmasCompiled pragmasDetected |
+ pragmasCompiled := self pragma: #foo: selector: #bar times: 5.
+ pragmasDetected := Pragma allNamed: #foo: in: self class.
+ self assert: pragmasDetected = pragmasCompiled.
+
+ pragmasDetected := Pragma allNamed: #foo: in: Object.
+ self assert: pragmasDetected isEmpty.!
Item was added:
+ ----- Method: MethodPragmaTest>>testAllNamedInSortedByArgument (in category 'tests-finding') -----
+ testAllNamedInSortedByArgument
+ | pragmasCompiled pragmasDetected |
+ pragmasCompiled := self pragma: #foo: selector: #bar times: 5.
+ pragmasDetected := Pragma allNamed: #foo: in: self class sortedByArgument: 1.
+ self assert: pragmasDetected = (pragmasCompiled
+ sort: [ :a :b | (a argumentAt: 1) < (b argumentAt: 1) ])!
Item was added:
+ ----- Method: MethodPragmaTest>>testAllNamedInSortedUsing (in category 'tests-finding') -----
+ testAllNamedInSortedUsing
+ | pragmasCompiled pragmasDetected |
+ pragmasCompiled := self pragma: #foo: selector: #bar times: 5.
+ pragmasDetected := Pragma
+ allNamed: #foo: in: self class
+ sortedUsing: [ :a :b | (a argumentAt: 1) > (b argumentAt: 1) ].
+ self assert: pragmasDetected = (pragmasCompiled
+ sort: [ :a :b | (a argumentAt: 1) > (b argumentAt: 1) ]).!
Item was added:
+ ----- Method: MethodPragmaTest>>testArguments (in category 'tests-pragma') -----
+ testArguments
+ | pragma |
+ pragma := Pragma keyword: #foo: arguments: #( 123 ).
+ self assert: pragma arguments = #( 123 ).!
Item was added:
+ ----- Method: MethodPragmaTest>>testCompileArray (in category 'tests-compiler') -----
+ testCompileArray
+ self assertPragma: 'foo: #()' givesKeyword: #foo: arguments: #( () ).
+ self assertPragma: 'foo: #( foo )' givesKeyword: #foo: arguments: #( ( foo ) ).
+ self assertPragma: 'foo: #( foo: )' givesKeyword: #foo: arguments: #( ( foo: ) ).
+ self assertPragma: 'foo: #( 12 )' givesKeyword: #foo: arguments: #( ( 12 ) ).
+ self assertPragma: 'foo: #( true )' givesKeyword: #foo: arguments: #( ( true ) ).
+ !
Item was added:
+ ----- Method: MethodPragmaTest>>testCompileBinary (in category 'tests-compiler') -----
+ testCompileBinary
+ self assertPragma: ' = 1' givesKeyword: #= arguments: #( 1 ).
+ self assertPragma: ' , 3' givesKeyword: #, arguments: #( 3 ).
+ self assertPragma: ' > 4' givesKeyword: #> arguments: #( 4 ).
+ self assertPragma: ' < 5' givesKeyword: #< arguments: #( 5 ).
+
+ self assertPragma: ' == 1' givesKeyword: #== arguments: #( 1 ).
+ self assertPragma: ' <> 3' givesKeyword: #<> arguments: #( 3 ).
+ self assertPragma: ' >< 4' givesKeyword: #>< arguments: #( 4 ).
+ self assertPragma: ' ** 5' givesKeyword: #** arguments: #( 5 )!
Item was added:
+ ----- Method: MethodPragmaTest>>testCompileCharacter (in category 'tests-compiler') -----
+ testCompileCharacter
+ self assertPragma: 'foo: $a' givesKeyword: #foo: arguments: #( $a ).
+ self assertPragma: 'foo: $ ' givesKeyword: #foo: arguments: { Character space }.!
Item was added:
+ ----- Method: MethodPragmaTest>>testCompileEmpty (in category 'tests-compiler') -----
+ testCompileEmpty
+ self assertPragma: 'foo' givesKeyword: #foo arguments: #().!
Item was added:
+ ----- Method: MethodPragmaTest>>testCompileFull (in category 'tests-compiler') -----
+ testCompileFull
+ self assertPragma: 'foo: 1' givesKeyword: #foo: arguments: #( 1 ).
+ self assertPragma: 'foo: 1 bar: 2' givesKeyword: #foo:bar: arguments: #( 1 2 ).!
Item was added:
+ ----- Method: MethodPragmaTest>>testCompileInvalid (in category 'tests-compiler') -----
+ testCompileInvalid
+ "Invalid pragmas should properly raise an error."
+
+ self should: [ self compile: '<>' selector: #zork ] raise: SyntaxErrorNotification.
+ self should: [ self compile: '<1>' selector: #zork ] raise: SyntaxErrorNotification.
+ self should: [ self compile: '<#123>' selector: #zork ] raise: SyntaxErrorNotification.
+
+ self should: [ self compile: '<foo bar>' selector: #zork ] raise: SyntaxErrorNotification.
+ self should: [ self compile: '<foo 1>' selector: #zork ] raise: SyntaxErrorNotification.
+ self should: [ self compile: '<foo bar zork>' selector: #zork ] raise: SyntaxErrorNotification.
+ self should: [ self compile: '<foo bar 1>' selector: #zork ] raise: SyntaxErrorNotification.
+
+ self should: [ self compile: '<foo: bar:>' selector: #zork ] raise: SyntaxErrorNotification.
+ self should: [ self compile: '<foo: #bar: zork:>' selector: #zork ] raise: SyntaxErrorNotification.
+
+ self should: [ self compile: '<<1>' selector: #zork ] raise: SyntaxErrorNotification.
+ self should: [ self compile: '<=2>' selector: #zork ] raise: SyntaxErrorNotification.
+
+ self should: [ self compile: '< =1 = >' selector: #zork ] raise: SyntaxErrorNotification.
+ self should: [ self compile: '< =1 =2 >' selector: #zork ] raise: SyntaxErrorNotification.
+
+ self should: [ self compile: '<foo: String>' selector: #zork ] raise: SyntaxErrorNotification.
+ self should: [ self compile: '<foo: Pragma>' selector: #zork ] raise: SyntaxErrorNotification!
Item was added:
+ ----- Method: MethodPragmaTest>>testCompileNumber (in category 'tests-compiler') -----
+ testCompileNumber
+ self assertPragma: 'foo: 123' givesKeyword: #foo: arguments: #( 123 ).
+ self assertPragma: 'foo: -123' givesKeyword: #foo: arguments: #( -123 ).
+ self assertPragma: 'foo: 12.3' givesKeyword: #foo: arguments: #( 12.3 ).
+ self assertPragma: 'foo: -12.3' givesKeyword: #foo: arguments: #( -12.3 ).!
Item was added:
+ ----- Method: MethodPragmaTest>>testCompileString (in category 'tests-compiler') -----
+ testCompileString
+ self assertPragma: 'foo: ''''' givesKeyword: #foo: arguments: #( '' ).
+ self assertPragma: 'foo: ''bar''' givesKeyword: #foo: arguments: #( 'bar' ).!
Item was added:
+ ----- Method: MethodPragmaTest>>testCompileSymbol (in category 'tests-compiler') -----
+ testCompileSymbol
+ self assertPragma: 'foo: #bar' givesKeyword: #foo: arguments: #( bar ).
+ self assertPragma: 'foo: #bar:' givesKeyword: #foo: arguments: #( bar: ).
+ self assertPragma: 'foo: #bar:zork:' givesKeyword: #foo: arguments: #( bar:zork: ).!
Item was added:
+ ----- Method: MethodPragmaTest>>testCompileTemps (in category 'tests-compiler') -----
+ testCompileTemps
+ "Pragmas should be placeable before and after temps."
+
+ self
+ shouldnt: [
+ self assert: (self compile: '| temps | <foo>' selector: #zork)
+ pragmas notEmpty ]
+ raise: SyntaxErrorNotification.
+ self
+ shouldnt: [
+ self assert: (self compile: '<foo> | temps |' selector: #zork)
+ pragmas notEmpty ]
+ raise: SyntaxErrorNotification.!
Item was added:
+ ----- Method: MethodPragmaTest>>testCompileValue (in category 'tests-compiler') -----
+ testCompileValue
+ self assertPragma: 'foo: true' givesKeyword: #foo: arguments: #( true ).
+ self assertPragma: 'foo: false' givesKeyword: #foo: arguments: #( false ).
+ self assertPragma: 'foo: nil' givesKeyword: #foo: arguments: #( nil )!
Item was added:
+ ----- Method: MethodPragmaTest>>testKeyword (in category 'tests-pragma') -----
+ testKeyword
+ | pragma |
+ pragma := Pragma keyword: #foo: arguments: #( 123 ).
+ self assert: pragma keyword = #foo:.!
Item was added:
+ ----- Method: MethodPragmaTest>>testMessage (in category 'tests-pragma') -----
+ testMessage
+ | pragma message |
+ pragma := Pragma keyword: #foo: arguments: #( 123 ).
+ message := pragma message.
+
+ self assert: message selector = #foo:.
+ self assert: message arguments = #( 123 ).!
Item was added:
+ ----- Method: MethodPragmaTest>>testMethod (in category 'tests-method') -----
+ testMethod
+ | pragma |
+ pragma := self pragma: 'foo' selector: #bar.
+ self assert: pragma method == (self class >> #bar).!
Item was added:
+ ----- Method: MethodPragmaTest>>testMethodClass (in category 'tests-method') -----
+ testMethodClass
+ | pragma |
+ pragma := self pragma: 'foo' selector: #bar.
+ self assert: pragma methodClass == self class.!
Item was added:
+ ----- Method: MethodPragmaTest>>testNoPragma (in category 'tests-compiled') -----
+ testNoPragma
+ | method |
+ method := self compile: '' selector: #foo.
+ self assert: method pragmas = #().!
Item was added:
+ ----- Method: MethodPragmaTest>>testPrimitiveIndexed1 (in category 'tests-primitives') -----
+ testPrimitiveIndexed1
+ "This test useses the #instVarAt: primitive."
+
+ self compile: '<primitive: 74> ^ #inst' selector: #inst.
+ self assert: self inst = #inst.!
Item was added:
+ ----- Method: MethodPragmaTest>>testPrimitiveIndexed2 (in category 'tests-primitives') -----
+ testPrimitiveIndexed2
+ "This test useses the #asOop primitive."
+
+ self compile: '<primitive: 75> ^ #oop' selector: #oop.
+ self assert: self oop = self asOop.!
Item was added:
+ ----- Method: MethodPragmaTest>>testPrimitiveNamed1 (in category 'tests-primitives') -----
+ testPrimitiveNamed1
+ "This test useses the #primitiveDirectoryLookup primitive."
+
+ self compile: '<primitive: ''primitiveDirectoryLookup'' module: ''FilePlugin''> ^ #lookup' selector: #lookup.
+ self assert: self lookup = #lookup.
+
+ !
Item was added:
+ ----- Method: MethodPragmaTest>>testPrimitiveNamed2 (in category 'tests-primitives') -----
+ testPrimitiveNamed2
+ "This test useses the #primPathNameDelimiter primitive."
+
+ self compile: '<primitive: ''primitiveDirectoryDelimitor'' module: ''FilePlugin''> ^ #delim' selector: #delim.
+ self assert: self delim = FileDirectory primPathNameDelimiter.
+
+ !
Item was added:
+ ----- Method: MethodPragmaTest>>testReformat (in category 'tests-printing-reformating') -----
+ testReformat
+ self assert: (DisplayScreen class compiledMethodAt: #actualScreenDepth) getSource string = 'actualScreenDepth
+ <primitive: ''primitiveScreenDepth''>
+ ^ Display depth'.
+
+ self assert: (DisplayScreen class compiledMethodAt: #actualScreenDepth) getSource string = 'actualScreenDepth
+ <primitive: ''primitiveScreenDepth''>
+ ^ Display depth'.
+ !
Item was added:
+ ----- Method: MethodPragmaTest>>testSelector (in category 'tests-method') -----
+ testSelector
+ | pragma |
+ pragma := self pragma: 'foo' selector: #bar.
+ self assert: pragma selector == #bar.!
Item was added:
+ TestCase subclass: #MethodPropertiesTest
+ instanceVariableNames: 'method'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'KernelTests-Methods'!
Item was added:
+ ----- Method: MethodPropertiesTest>>propertyDictionaryFor: (in category 'private') -----
+ propertyDictionaryFor: aMethod
+ ^ aMethod properties properties!
Item was added:
+ ----- Method: MethodPropertiesTest>>setUp (in category 'running') -----
+ setUp
+ method := Object >> #halt.!
Item was added:
+ ----- Method: MethodPropertiesTest>>tearDown (in category 'running') -----
+ tearDown
+ Object recompile: #halt from: Object.!
Item was added:
+ ----- Method: MethodPropertiesTest>>testAllMethodsHaveMethodClass (in category 'tests') -----
+ testAllMethodsHaveMethodClass
+ Smalltalk garbageCollect.
+ self assert: (CompiledMethod allInstances
+ reject: [:cm | | lastLiteral |
+ lastLiteral := cm literalAt: cm numLiterals.
+ lastLiteral isVariableBinding
+ and: [lastLiteral value isBehavior
+ or: [lastLiteral value isTrait]]]) isEmpty
+ description: 'CompiledMethods must have methodClass literal'!
Item was added:
+ ----- Method: MethodPropertiesTest>>testAt (in category 'tests') -----
+ testAt
+ self should: [ method properties at: #zork ] raise: Error.
+ self assert: (self propertyDictionaryFor: method) isEmpty.
+ method properties at: #zork put: 'hello'.
+ self assert: (method properties at: #zork) = 'hello'.!
Item was added:
+ ----- Method: MethodPropertiesTest>>testAtIfAbsent (in category 'tests') -----
+ testAtIfAbsent
+ self assert: (method properties at: #zork ifAbsent: [ 'hello' ]) = 'hello'.
+ self assert: (self propertyDictionaryFor: method) isEmpty.
+ method properties at: #zork put: 'hi'.
+ self assert: (method properties at: #zork ifAbsent: [ 'hello' ]) = 'hi'.!
Item was added:
+ ----- Method: MethodPropertiesTest>>testAtIfAbsentPut (in category 'tests') -----
+ testAtIfAbsentPut
+ self assert: (method properties at: #zork ifAbsentPut: [ 'hello' ]) = 'hello'.
+ self assert: (method properties at: #zork ifAbsentPut: [ 'hi' ]) = 'hello'.!
Item was added:
+ ----- Method: MethodPropertiesTest>>testAtPut (in category 'tests') -----
+ testAtPut
+ self assert: (method properties at: #zork put: 'hello') = 'hello'.
+ self assert: (method properties at: #zork) = 'hello'.!
Item was added:
+ ----- Method: MethodPropertiesTest>>testAtPutRepeatedly (in category 'tests') -----
+ testAtPutRepeatedly
+ self assert: (method properties at: #zork put: 'hello') = 'hello'.
+ self assert: (method properties at: #zork put: 'hello') = 'hello'.
+ self assert: (method properties at: #zork) = 'hello'.!
Item was added:
+ ----- Method: MethodPropertiesTest>>testIncludesKey (in category 'tests') -----
+ testIncludesKey
+ self deny: (method properties includesKey: #zork).
+ self assert: (self propertyDictionaryFor: method) isEmpty.
+ method properties at: #zork put: 123.
+ self assert: (method properties includesKey: #zork).!
Item was added:
+ ----- Method: MethodPropertiesTest>>testRemoveKey (in category 'tests') -----
+ testRemoveKey
+ method properties at: #zork put: 'hello'.
+ self should: [ method properties removeKey: #halt ] raise: Error.
+ self assert: (method properties removeKey: #zork) = 'hello'.
+ self assert: (self propertyDictionaryFor: method) isEmpty.
+ self should: [ method properties removeKey: #zork ] raise: Error.
+ self assert: (self propertyDictionaryFor: method) isEmpty.!
Item was added:
+ ----- Method: MethodPropertiesTest>>testRemoveKeyifAbsent (in category 'tests') -----
+ testRemoveKeyifAbsent
+ method properties at: #zork put: 'hello'.
+ self assert: (method properties removeKey: #halt ifAbsent: [ 'hi' ]) = 'hi'.
+ self assert: (method properties removeKey: #zork ifAbsent: [ 'hi' ]) = 'hello'.
+ self assert: (self propertyDictionaryFor: method) isEmpty.
+ self should: (method properties removeKey: #zork ifAbsent: [ 'hi' ]) = 'hi'.
+ self assert: (self propertyDictionaryFor: method) isEmpty.!
Item was added:
+ TestCase subclass: #ModelTest
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'KernelTests-Models'!
Item was added:
+ ----- Method: ModelTest>>testCopyDependents (in category 'tests') -----
+ testCopyDependents
+
+ | bar foo |
+ foo := Model new.
+ foo addDependent: 42.
+ self assert: {42} equals: foo dependents asArray.
+
+ bar := foo copy.
+ self assert: bar dependents isEmpty.!
Item was added:
+ TestCase subclass: #MonitorTest
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'KernelTests-Processes'!
Item was added:
+ ----- Method: MonitorTest>>testCheckOwnerProcess (in category 'tests') -----
+ testCheckOwnerProcess
+ self should: [Monitor new checkOwnerProcess]
+ raise: Error.
+
+ self shouldnt: [| m | m := Monitor new. m critical: [m checkOwnerProcess]]
+ raise: Error.
+
+ self should: [| s m |
+ m := Monitor new.
+ [m critical: [s := #in. Semaphore new wait]] fork.
+ Processor yield.
+ self assert: #in equals: s.
+ m checkOwnerProcess]
+ raise: Error!
Item was added:
+ ----- Method: MonitorTest>>testCriticalIfLocked (in category 'tests') -----
+ testCriticalIfLocked
+ | m s |
+ m := Monitor new.
+ self assert: #unlocked == (m critical: [#unlocked] ifLocked: [#locked]).
+ [m critical: [s := #in. Semaphore new wait]] fork.
+ Processor yield.
+ self assert: #in equals: s.
+ self assert: #locked equals: (m critical: [#unlocked] ifLocked: [#locked])!
Item was added:
+ ----- Method: MonitorTest>>testExample1 (in category 'tests') -----
+ testExample1
+
+ | producer1 producer2 monitor goal work counter goalReached finished |
+ goal := (1 to: 1000) asOrderedCollection.
+ work := OrderedCollection new.
+ counter := 0.
+ goalReached := false.
+ finished := Semaphore new.
+ monitor := Monitor new.
+
+ producer1 := [
+ [monitor critical:
+ [monitor waitUntil: [counter \\5 = 0].
+ goalReached or: [work add: (counter := counter + 1)].
+ goalReached := counter >= goal size.
+ monitor signal
+ ].
+ goalReached
+ ]
+ whileFalse.
+ finished signal.
+ ].
+
+ producer2 := [
+ [monitor critical:
+ [monitor waitWhile: [counter \\5 = 0].
+ goalReached or: [work add: (counter := counter + 1)].
+ goalReached := counter >= goal size.
+ monitor signal].
+ goalReached
+ ] whileFalse.
+ finished signal
+ ].
+
+ producer1 forkAt: Processor userBackgroundPriority.
+ producer2 forkAt: Processor userBackgroundPriority.
+
+ finished wait; wait.
+ self assert: goal = work!
Item was added:
+ ----- Method: MonitorTest>>testExample2 (in category 'tests') -----
+ testExample2
+ "Here is a second version that does not use a semaphore to inform the
+ forking process about termination of both forked processes"
+
+ | producer1 producer2 monitor goal work counter goalReached activeProducers|
+ goal := (1 to: 1000) asOrderedCollection.
+ work := OrderedCollection new.
+ counter := 0.
+ goalReached := false.
+ activeProducers := 0.
+ monitor := Monitor new.
+
+ producer1 :=
+ [ monitor critical: [activeProducers := activeProducers + 1].
+ [monitor critical:
+ [monitor waitUntil: [counter \\5 = 0].
+ goalReached or: [work add: (counter := counter + 1)].
+ " Transcript show: 'P1 '; show: counter printString; show: ' ';
+ show: activeProducers printString; cr."
+ goalReached := counter >= goal size.
+ monitor signal
+ ].
+ goalReached
+ ]
+ whileFalse.
+ monitor critical: [activeProducers := activeProducers - 1.
+ monitor signal: #finish].
+ ] .
+
+ producer2 :=
+ [monitor critical: [activeProducers := activeProducers + 1].
+
+ [monitor critical:
+ [monitor waitWhile: [counter \\5 = 0].
+ goalReached or: [work add: (counter := counter + 1)].
+ goalReached := counter >= goal size.
+ monitor signal].
+ goalReached ] whileFalse.
+ monitor critical: [
+ activeProducers := activeProducers - 1.
+ monitor signal: #finish].
+ ].
+
+ producer1 forkAt: Processor userBackgroundPriority.
+ producer2 forkAt: Processor userBackgroundPriority.
+
+
+ monitor critical: [
+ monitor waitUntil: [activeProducers = 0 & (goalReached)]
+ for: #finish.
+ ].
+
+ self assert: goal = work
+ !
Item was added:
+ ClassTestCase subclass: #MutexTest
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'KernelTests-Processes'!
+
+ !MutexTest commentStamp: 'eem 7/26/2018 20:42' prior: 0!
+ MutexTest provides SUnit tests for Mutex locks. c.f. SemaphoreTest.!
Item was added:
+ ----- Method: MutexTest>>criticalError (in category 'private') -----
+ criticalError
+ Processor activeProcess terminate!
Item was added:
+ ----- Method: MutexTest>>expectedFailures (in category 'failures') -----
+ expectedFailures
+
+ ^ #(testUnwindMutexBlockedInCritical)!
Item was added:
+ ----- Method: MutexTest>>testCritical (in category 'tests') -----
+ testCritical
+ | lock |
+ lock := Mutex new.
+ [lock critical: [self criticalError]] forkAt: Processor userInterruptPriority.
+ self deny: lock isOwned!
Item was added:
+ ----- Method: MutexTest>>testCriticalIfError (in category 'tests') -----
+ testCriticalIfError
+ | lock |
+ lock := Mutex new.
+ [lock critical: [self criticalError ifError: []]] forkAt: Processor userInterruptPriority.
+ self deny: lock isOwned!
Item was added:
+ ----- Method: MutexTest>>testMutexAfterCriticalWait (in category 'tests') -----
+ testMutexAfterCriticalWait "self run: #testMutexAfterCriticalWait"
+ "This tests whether a process that has just left the primitiveEnterCriticalSection in Mutex>>critical:
+ leaves it with the mutex correctly released."
+ | lock p |
+ lock := Mutex new.
+ p := [lock critical: []] newProcess.
+ p priority: Processor activePriority - 1.
+ lock critical: "We now own it; p can't enter properly"
+ [p resume.
+ "wait until p enters the critical section; it doesn't own the Mutex so is blocked..."
+ [p suspendingList == lock] whileFalse: [(Delay forMilliseconds: 10) wait].
+ self deny: lock isEmpty].
+ "p is waiting on lock; on our exiting critical: p is now the notional owner. Terminate before it has a chance to run".
+ p terminate.
+ self deny: lock isOwned.
+ self assert: lock isEmpty!
Item was added:
+ ----- Method: MutexTest>>testMutexCriticalBlockedInEnsure (in category 'tests') -----
+ testMutexCriticalBlockedInEnsure "self run: #testMutexCriticalBlockedInEnsure"
+ "This tests whether a mutex that is in the ensure: in critical: but has yet to evaluate the valueNoContextSwitch
+ leaves it with the mutex unlocked."
+ | lock proc |
+ lock := Mutex new.
+ proc := [lock critical: []] newProcess.
+ proc priority: Processor activePriority - 1.
+ "step until in critical:"
+ [proc suspendedContext selector == #critical:] whileFalse: [proc step].
+ "step until in ensure: (can't do this until in critical: cuz ensure: may be in newProcess etc...)"
+ [proc suspendedContext selector == #ensure:] whileFalse: [proc step].
+ "Now check that the lock is owned."
+ self assert: lock isOwned.
+ "Now that proc is at the right point, resume the process and immediately terminate it."
+ proc resume; terminate.
+ self deny: lock isOwned.
+ self assert: lock isEmpty!
Item was added:
+ ----- Method: MutexTest>>testMutexInCriticalEnsureArgument (in category 'tests') -----
+ testMutexInCriticalEnsureArgument "self run: #testMutexInCriticalEnsureArgument"
+ "This tests whether a process that is in the ensure argument block in critical: but has yet to evaluate the primitiveExitCriticalSection
+ leaves it with the mutex unlocked."
+
+ | terminatee mutex |
+ mutex := Mutex new.
+ terminatee := [mutex critical: []] newProcess.
+ self assert: terminatee isSuspended.
+ terminatee runUntil: [:ctx | ctx selectorToSendOrSelf = #primitiveExitCriticalSection].
+ self assert: terminatee isSuspended.
+ terminatee terminate.
+ self deny: mutex isOwned.
+ self assert: mutex isEmpty!
Item was added:
+ ----- Method: MutexTest>>testMutexInCriticalWait (in category 'tests') -----
+ testMutexInCriticalWait "self run: #testMutexInCriticalWait"
+ "This tests whether a mutex that has got past the primitiveEnterCriticalSection in Mutex>>critical:
+ leaves it unowned."
+ | lock sock proc |
+ lock := Mutex new.
+ sock := Semaphore new.
+ proc := [lock critical: [sock wait]] fork.
+ Processor yield.
+ self assert: proc suspendingList == sock.
+ proc terminate.
+ self deny: lock isOwned.
+ self assert: lock isEmpty!
Item was added:
+ ----- Method: MutexTest>>testSuspendAndResume (in category 'tests') -----
+ testSuspendAndResume "self run: #testSuspendAndResume"
+ "Test the semantics of suspending and resuming a process blocked on a mutex;
+ Note the difference between #suspend and #suspendAndUnblock.
+ Note: this test will fail when run with older VMs without primitive suspend 578."
+
+ | lock sock proc wait |
+ lock := Mutex new.
+ sock := Semaphore new.
+ proc := [lock critical: [sock wait]] fork.
+ wait := [lock critical: []] fork.
+ Processor yield.
+ self assert: proc suspendingList == sock.
+ self assert: wait suspendingList == lock.
+ self deny: lock isEmpty.
+ self assert: lock isOwned.
+ wait suspend; resume.
+ "wait returned back to the mutex"
+ Processor yield.
+ self assert: wait isBlocked.
+ self assert: proc suspendingList == sock.
+ self assert: wait suspendingList == lock.
+ self deny: lock isEmpty.
+ self assert: lock isOwned.
+
+ "now the same with suspendAndUnblock"
+ lock := Mutex new.
+ sock := Semaphore new.
+ proc := [lock critical: [sock wait]] fork.
+ wait := [lock critical: []] fork.
+ Processor yield.
+ self assert: proc suspendingList == sock.
+ self assert: wait suspendingList == lock.
+ self deny: lock isEmpty.
+ self assert: lock isOwned.
+ wait suspendAndUnblock; resume.
+ "wait unblocked from the mutex BUT..."
+ Processor yield.
+ self assert: wait isTerminated.
+ self assert: proc suspendingList == sock.
+ self assert: wait suspendingList == nil.
+ self assert: lock isEmpty.
+ "... left this MESS behind:"
+ self deny: lock isOwned
+ "Indeed, lock should have stayed owned;
+ this is why primitive 88 is so dangerous"!
Item was added:
+ ----- Method: MutexTest>>testTerminationOfLowPriorityProcessDoesNotShutOutHighPriorityProcess (in category 'tests') -----
+ testTerminationOfLowPriorityProcessDoesNotShutOutHighPriorityProcess
+ | m p s |
+ m := Mutex new.
+ p := [m critical: [Semaphore new wait]] forkAt: Processor activePriority - 10.
+ (Delay forMilliseconds: 100) wait. "Allow p to enter critical section, owning m"
+ [m critical: [s := #in]] forkAt: Processor activePriority + 10.
+ "r := { p suspendedContext pc. p suspendedContext copyStack }."
+ p terminate.
+ self deny: m isOwned.
+ self assert: s == #in.
+ "(m isOwned not and: [s == #in]) ifFalse:
+ [Debugger openContext: r last label: 'p' contents: nil]"!
Item was added:
+ ----- Method: MutexTest>>testTerminationOfOneOfTwoLowPriorityProcesses (in category 'tests') -----
+ testTerminationOfOneOfTwoLowPriorityProcesses
+ | mutex p1 p2 entered1 entered2 |
+ mutex := Mutex new.
+ entered1 := entered2 := false.
+ p1 := [mutex critical:[entered1 := true]]
+ forkAt: Processor activePriority - 1.
+ p2 := [mutex critical:[entered2 := true]]
+ forkAt: Processor activePriority - 2.
+ mutex critical:[(Delay forMilliseconds: 100) wait].
+ p1 terminate.
+ (Delay forMilliseconds: 100) wait.
+ self deny: entered1.
+ self assert: entered2!
Item was added:
+ ----- Method: MutexTest>>testUnwindMutexBlockedInCritical (in category 'tests') -----
+ testUnwindMutexBlockedInCritical "self run: #testMutexBlockedInCritical"
+ "This tests whether a mutex that is inside the primitiveEnterCriticalSection in Mutex>>critical:
+ leaves it unchanged."
+ | lock sock proc wait |
+ lock := Mutex new.
+ sock := Semaphore new.
+ proc := [lock critical: [sock wait]] fork.
+ wait := [[] ensure: [lock critical: []]] fork.
+ Processor yield.
+ self assert: proc suspendingList == sock.
+ self assert: wait suspendingList == lock.
+ self deny: lock isEmpty.
+ self assert: lock isOwned.
+ wait terminate.
+ Processor yield.
+ self assert: wait isTerminated.
+ self assert: proc suspendingList == sock.
+ self assert: wait suspendingList == nil.
+ self assert: lock isEmpty.
+ self assert: lock isOwned
+ !
Item was added:
+ Object subclass: #NotImplementedTestData
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'KernelTests-Objects'!
Item was added:
+ ----- Method: NotImplementedTestData>>shouldBeImplementedMsg (in category 'accessing') -----
+ shouldBeImplementedMsg
+ ^ self shouldBeImplemented.!
Item was added:
+ ----- Method: NotImplementedTestData>>shouldNotImplementMsg (in category 'accessing') -----
+ shouldNotImplementMsg
+ ^ self shouldNotImplement.!
Item was added:
+ Object subclass: #NullMutex
+ instanceVariableNames: 'semaphore owner'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'KernelTests-Processes'!
+
+ !NullMutex commentStamp: 'fbs 5/17/2013 20:30' prior: 0!
+ A Mutex is a light-weight MUTual EXclusion object being used when two or more processes need to access a shared resource concurrently. A Mutex grants ownership to a single process and will suspend any other process trying to aquire the mutex while in use. Waiting processes are granted access to the mutex in the order the access was requested.
+
+ This Mutex DOES NOT mutually exclude anything. It just implements the same protocol.!
Item was added:
+ ----- Method: NullMutex>>critical: (in category 'mutual exclusion') -----
+ critical: aBlock
+ ^ aBlock value.!
Item was added:
+ TestCase subclass: #NumberParsingTest
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'KernelTests-Numbers'!
+
+ !NumberParsingTest commentStamp: 'dtl 11/24/2004 15:35' prior: 0!
+ Tests to verify parsing of numbers from streams and strings.
+
+ Note: ScaledDecimalTest contains related tests for parsing ScaledDecimal.!
Item was added:
+ ----- Method: NumberParsingTest>>testFloatFromStreamAsNumber (in category 'tests - Float') -----
+ testFloatFromStreamAsNumber
+ "This covers parsing in Number>>readFrom:"
+
+ | rs aFloat |
+ rs := '10r-12.3456' readStream.
+ aFloat := Number readFrom: rs.
+ self assert: -12.3456 = aFloat.
+ self assert: rs atEnd.
+
+ rs := '10r-12.3456e2' readStream.
+ aFloat := Number readFrom: rs.
+ self assert: -1234.56 = aFloat.
+ self assert: rs atEnd.
+
+ rs := '10r-12.3456e2e2' readStream.
+ aFloat := Number readFrom: rs.
+ self assert: -1234.56 = aFloat.
+ self assert: rs upToEnd = 'e2'.
+
+ rs := '10r-12.3456d2' readStream.
+ aFloat := Number readFrom: rs.
+ self assert: -1234.56 = aFloat.
+ self assert: rs atEnd.
+
+ rs := '10r-12.3456q2' readStream.
+ aFloat := Number readFrom: rs.
+ self assert: -1234.56 = aFloat.
+ self assert: rs atEnd.
+
+ rs := '-12.3456q2' readStream.
+ aFloat := Number readFrom: rs.
+ self assert: -1234.56 = aFloat.
+ self assert: rs atEnd.
+
+ rs := '12.3456q2' readStream.
+ aFloat := Number readFrom: rs.
+ self assert: 1234.56 = aFloat.
+ self assert: rs atEnd.
+
+ rs := '12.3456z2' readStream.
+ aFloat := Number readFrom: rs.
+ self assert: 12.3456 = aFloat.
+ self assert: rs upToEnd = 'z2'.
+ !
Item was added:
+ ----- Method: NumberParsingTest>>testFloatFromStreamWithExponent (in category 'tests - Float') -----
+ testFloatFromStreamWithExponent
+ "This covers parsing in Number>>readFrom:"
+
+ | rs aFloat |
+ rs := '1.0e-14' readStream.
+ aFloat := Number readFrom: rs.
+ self assert: 1.0e-14 = aFloat.
+ self assert: rs atEnd.
+
+ rs := '1.0e-14 1' readStream.
+ aFloat := Number readFrom: rs.
+ self assert: 1.0e-14 = aFloat.
+ self assert: rs upToEnd = ' 1'.
+
+ rs := '1.0e-14eee' readStream.
+ aFloat := Number readFrom: rs.
+ self assert: 1.0e-14 = aFloat.
+ self assert: rs upToEnd = 'eee'.
+
+ rs := '1.0e14e10' readStream.
+ aFloat := Number readFrom: rs.
+ self assert: 1.0e14 = aFloat.
+ self assert: rs upToEnd = 'e10'.
+
+ rs := '1.0e+14e' readStream. "Plus sign is parseable too"
+ aFloat := Number readFrom: rs.
+ self assert: 1.0e14 = aFloat.
+ self assert: rs upToEnd = 'e'.
+
+ rs := '1.0e' readStream.
+ aFloat := Number readFrom: rs.
+ self assert: 1.0 = aFloat.
+ self assert: rs upToEnd = 'e'.!
Item was added:
+ ----- Method: NumberParsingTest>>testFloatFromStringAsNumber (in category 'tests - Float') -----
+ testFloatFromStringAsNumber
+ "This covers parsing in Number>>readFrom:"
+
+ | aFloat |
+ aFloat := '10r-12.3456' asNumber.
+ self assert: -12.3456 = aFloat.
+ aFloat := '10r-12.3456e2' asNumber.
+ self assert: -1234.56 = aFloat.
+ aFloat := '10r-12.3456d2' asNumber.
+ self assert: -1234.56 = aFloat.
+ aFloat := '10r-12.3456q2' asNumber.
+ self assert: -1234.56 = aFloat.
+ aFloat := '-12.3456q2' asNumber.
+ self assert: -1234.56 = aFloat.
+ aFloat := '12.3456q2' asNumber.
+ self assert: 1234.56 = aFloat.
+ !
Item was added:
+ ----- Method: NumberParsingTest>>testFloatFromStringWithExponent (in category 'tests - Float') -----
+ testFloatFromStringWithExponent
+ "This covers parsing in Number>>readFrom:"
+
+ | aFloat |
+ aFloat := '1.0e-14' asNumber.
+ self assert: 1.0e-14 = aFloat.
+ aFloat := '1.0e-14 1' asNumber.
+ self assert: 1.0e-14 = aFloat.
+ aFloat := '1.0e-14e' asNumber.
+ self assert: 1.0e-14 = aFloat.
+ aFloat := '1.0e14e' asNumber.
+ self assert: 1.0e14 = aFloat.
+ aFloat := '1.0e+14e' asNumber. "Plus sign is parseable too"
+ self assert: 1.0e14 = aFloat.
+ !
Item was added:
+ ----- Method: NumberParsingTest>>testFloatReadWithImplicitLeadingZero (in category 'tests - Float') -----
+ testFloatReadWithImplicitLeadingZero
+ "Test support for implicit leading zeroes when reading numbers from Strings."
+ self should: [-0.22 = '-.22' asNumber].
+ self should: [0.22 = '.22' asNumber].
+ !
Item was added:
+ ----- Method: NumberParsingTest>>testFloatReadWithRadix (in category 'tests - Float') -----
+ testFloatReadWithRadix
+ "This covers parsing in Number>>readFrom:
+ Note: In most Smalltalk dialects, the radix notation is not used for numbers
+ with exponents. In Squeak, a string with radix and exponent can be parsed,
+ and the exponent is always treated as base 10 (not the base indicated in the
+ radix prefix). I am not sure if this is a feature, a bug, or both, but the
+ Squeak behavior is documented in this test. -dtl"
+
+ | aNumber rs |
+ aNumber := '2r1.0101e9' asNumber.
+ self assert: 672.0 = aNumber.
+ self assert: (Number readFrom: '2r1.0101e9') = (1.3125 * (2 raisedTo: 9)).
+ rs := ReadStream on: '2r1.0101e9e9'.
+ self assert: (Number readFrom: rs) = 672.0.
+ self assert: rs upToEnd = 'e9'
+ !
Item was added:
+ ----- Method: NumberParsingTest>>testFloatmin (in category 'tests - Float') -----
+ testFloatmin
+ "Note that these are originally tests cases for former bugs of libc dtoa from netlib.
+ ref http://www.exploringbinary.com/gays-strtod-returns-zero-for-inputs-just-abo…
+ ref http://gcc.gnu.org/viewcvs/gcc/trunk/gcc/testsuite/gcc.dg/float-exact-1.c?v…
+ They are also non regression for a bug of NumberParser related to incorrect position of last non zero digit.
+ ref https://pharo.fogbugz.com/f/cases/12642/bug-in-NumberParser-when-reading-a-…"
+ | halfMin moreThanHalfmin |
+ halfMin := SqNumberParser parse: (Float fmin asTrueFraction / 2 printShowingDecimalPlaces: 1 - Float fmin exponent).
+ self assert: halfMin equals: 0.0 description: 'nearest even of 0.5*Float fmin is zero'.
+ moreThanHalfmin := SqNumberParser parse: (Float fmin asTrueFraction / 2 + (10 raisedTo: Float fmin exponent - 4) printShowingDecimalPlaces: 4 - Float fmin exponent).
+ self assert: moreThanHalfmin equals: Float fmin description: 'nearest Float of a Fraction > 0.5*Float fmin is Float fmin'.!
Item was added:
+ ----- Method: NumberParsingTest>>testIntegerFromString (in category 'tests - Integer') -----
+ testIntegerFromString
+ "This covers parsing in Number>>readFrom:"
+
+ #(
+ ('123' 123)
+ ('-123' -123)
+ ('123.' 123.0)
+ ('-123.' -123.0)
+ ('123This is not to be read' 123)
+ ('123s is a ScaledDecimal' 123s0)
+ ('123sin is not a ScaledDecimal, s could be part of message sin' 123)
+ ('123e could be confused with a Float' 123)) do: [ :each |
+ [ :string :numericValue |
+ | result |
+ result := string asNumber.
+ self assert: result = numericValue.
+ self assert: result class = numericValue class] valueWithArguments: each ]
+ !
Item was added:
+ ----- Method: NumberParsingTest>>testIntegerReadFrom (in category 'tests - Integer') -----
+ testIntegerReadFrom
+ "Ensure remaining characters in a stream are not lost when parsing an integer."
+
+ #(
+ ('13r96 has a radix specification' 123 ' has a radix specification')
+ ('123r is not a radix specification here' 123 'r is not a radix specification here')
+ ('-123e has no exponent' -123 'e has no exponent')
+ ('-123.e has no exponent' -123.0 'e has no exponent')
+ ('-123e2 has an exponent' -12300 ' has an exponent')
+ ('123This is not to be read' 123 'This is not to be read')
+ ('123s is a ScaledDecimal' 123s0 ' is a ScaledDecimal')
+ ('-123.s is a ScaledDecimal' -123s0 ' is a ScaledDecimal')
+ ('123sin is not a ScaledDecimal, s could be part of message sin' 123 'sin is not a ScaledDecimal, s could be part of message sin')
+ ('123.sin is not a ScaledDecimal, s could be part of message sin' 123.0 'sin is not a ScaledDecimal, s could be part of message sin')
+ ) do: [ :each |
+ [ :string :numericValue :expectedRest |
+ | readStream result rest |
+ readStream := string readStream.
+ result := Number readFrom: readStream.
+ rest := readStream upToEnd.
+ self assert: result = numericValue.
+ self assert: result class = numericValue class.
+ self assert: rest = expectedRest] valueWithArguments: each ]
+ !
Item was added:
+ ----- Method: NumberParsingTest>>testIntegerReadWithRadix (in category 'tests - Integer') -----
+ testIntegerReadWithRadix
+ "This covers parsing in Number>>readFrom:
+ Note: In most Smalltalk dialects, the radix notation is not used for numbers
+ with exponents. In Squeak, a string with radix and exponent can be parsed,
+ and the exponent is always treated as base 10 (not the base indicated in the
+ radix prefix). I am not sure if this is a feature, a bug, or both, but the
+ Squeak behavior is documented in this test. -dtl"
+
+ | aNumber rs |
+ aNumber := '2r1e26' asNumber.
+ self assert: 67108864 = aNumber.
+ self assert: (Number readFrom: '2r1e26') = (2 raisedTo: 26).
+ rs := '2r1e26eee' readStream.
+ self assert: (Number readFrom: rs) = 67108864.
+ self assert: rs upToEnd = 'eee'
+ !
Item was added:
+ ----- Method: NumberParsingTest>>testNegativeZero (in category 'tests - Integer') -----
+ testNegativeZero
+ "This test ensure that -0.0 will produce a negativeZero"
+
+ | negativeZero |
+ negativeZero := Number readFrom: '-0.0' readStream.
+
+ "If it is a negative zero, it must behave like a negative zero... IEEE 754 tells how it should behave"
+ self deny: (negativeZero at: 1) = 0 description: 'In IEEE 754, a negative zero has its sign bit set to 1'..
+ self assert: negativeZero = 0 description: 'In IEEE 754, a negative zero cannot be distinguished from zero'.!
Item was added:
+ ----- Method: NumberParsingTest>>testScaledDecimalWithTrailingZeroes (in category 'tests - ScaledDecimal') -----
+ testScaledDecimalWithTrailingZeroes
+ "This is a non regression tests for http://bugs.squeak.org/view.php?id=7169"
+
+ self assert: (Number readFrom: '0.50s2') = (1/2).
+ self assert: (Number readFrom: '0.500s3') = (1/2).
+ self assert: (Number readFrom: '0.050s3') = (1/20).!
Item was added:
+ ClassTestCase subclass: #NumberTest
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'KernelTests-Numbers'!
Item was added:
+ ----- Method: NumberTest>>testExactLog2 (in category 'tests') -----
+ testExactLog2
+ -10 to: 10 do: [:i | self assert: i equals: (2 raisedToInteger: i) log2].
+ Float emin - Float precision + 1 to: Float emax do: [:i | self assert: i equals: (1.0 timesTwoPower: i) log2].!
Item was added:
+ ----- Method: NumberTest>>testFractionPart (in category 'tests') -----
+ testFractionPart
+
+ self
+ assert: 2 fractionPart = 0;
+ assert: (1/2) fractionPart = (1/2);
+ assert: (4/3) fractionPart = (1/3);
+ assert: 2.0 fractionPart = 0.0;
+ assert: 0.5 fractionPart = 0.5;
+ assert: 2.5 fractionPart = 0.5
+ !
Item was added:
+ ----- Method: NumberTest>>testIntegerPart (in category 'tests') -----
+ testIntegerPart
+
+ self
+ assert: 2 integerPart = 2;
+ assert: (1/2) integerPart = 0;
+ assert: (4/3) integerPart = 1;
+ assert: 2.0 integerPart = 2.0;
+ assert: 0.5 integerPart = 0.0;
+ assert: 2.5 integerPart = 2.0
+ !
Item was added:
+ ----- Method: NumberTest>>testLog2doesNotOverflow (in category 'tests') -----
+ testLog2doesNotOverflow
+ "Note: though this is not a strict identity, we can use strict Float equality here"
+ self assert: 3000.0 equals: ((1 bitShift: 3000) - 1) log2.
+ self assert: 1500.0 equals: (((1 bitShift: 3000) - 1) / (1 bitShift: 1500)) log2.!
Item was added:
+ ----- Method: NumberTest>>testLog2doesNotUnderflow (in category 'tests') -----
+ testLog2doesNotUnderflow
+ "Note: though this is not a strict identity, we can use strict Float equality here"
+ self assert: -2000.0 equals: ((1 bitShift: 2000) - 1) reciprocal log2!
Item was added:
+ ----- Method: NumberTest>>testOne (in category 'tests') -----
+ testOne
+
+ self
+ assert: Integer one = 1;
+ assert: Float one = 1.0;
+ assert: Fraction one = 1!
Item was added:
+ ----- Method: NumberTest>>testPrintShowingDecimalPlaces (in category 'tests') -----
+ testPrintShowingDecimalPlaces
+ self assert: (111.2 printShowingDecimalPlaces: 2) = '111.20'.
+ self assert: (111.2 printShowingDecimalPlaces: 0) = '111'.
+ self assert: (111 printShowingDecimalPlaces: 0) = '111'.
+ self assert: (111111111111111 printShowingDecimalPlaces: 2) = '111111111111111.00'.
+ self assert: (10 printShowingDecimalPlaces: 20) ='10.00000000000000000000'.
+ self assert: (0.98 printShowingDecimalPlaces: 2) = '0.98'.
+ self assert: (-0.98 printShowingDecimalPlaces: 2) = '-0.98'.
+ self assert: (2.567 printShowingDecimalPlaces: 2) = '2.57'.
+ self assert: (-2.567 printShowingDecimalPlaces: 2) = '-2.57'.
+ self assert: (0.01 printShowingDecimalPlaces: 2) = '0.01'.
+ self assert: (-0.001 printShowingDecimalPlaces: 2) = '-0.00'.!
Item was added:
+ ----- Method: NumberTest>>testPrintShowingDecimalPlaces2 (in category 'tests') -----
+ testPrintShowingDecimalPlaces2
+ "This tests problems related to Float>>rounded and Float>>roundTo::
+ - Float>>#rounded is inexact
+ - Float>>#roundTo: might overflow"
+
+ "5000000000000001.0 asTrueFraction = 5000000000000001.
+ 5000000000000001 highBit = 53.
+ This number is represented exactly asFloat, it should print exactly"
+ self assert: (5000000000000001.0 printShowingDecimalPlaces: 0) = '5000000000000001'.
+
+ "50000000000001.25 asTrueFraction = (200000000000005/4).
+ 200000000000005 highBit = 48, 4 isPowerOfTwo,
+ So this number is also represented exactly as Float, it should print exactly.
+ Beware: (50000000000001.25 / 0.01) rounded exhibit the same problem as above."
+ self assert: (50000000000001.25 printShowingDecimalPlaces: 2) = '50000000000001.25'.
+
+ "This number is close to maximum float value"
+ self assert: '1000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000.000' equals: (1.0e306 printShowingDecimalPlaces: 3).!
Item was added:
+ ----- Method: NumberTest>>testPrintShowingDecimalPlaces3 (in category 'tests') -----
+ testPrintShowingDecimalPlaces3
+ "This problem were reported at http://bugs.squeak.org/view.php?id=7028
+ unfortunate inversion of left / right padding"
+
+ self assert: (1.009 printShowingDecimalPlaces: 3) = '1.009'.
+ self assert: (35.900 printShowingDecimalPlaces: 3) = '35.900'.
+ self assert: (-0.097 printShowingDecimalPlaces: 3) = '-0.097'.!
Item was added:
+ ----- Method: NumberTest>>testRaisedTo (in category 'tests') -----
+ testRaisedTo
+ "this is a test related to http://bugs.squeak.org/view.php?id=6781"
+
+ self should: [0 raisedTo: -1] raise: ZeroDivide.
+ self should: [0 raisedTo: -1.0] raise: ZeroDivide.!
Item was added:
+ ----- Method: NumberTest>>testRaisedToInteger (in category 'tests') -----
+ testRaisedToInteger
+
+ self
+ assert: (2 raisedToInteger: 0) = 1;
+ assert: (2 raisedToInteger: 1) = 2;
+ assert: (2 raisedToInteger: 4) = 16;
+ assert: (0 raisedToInteger: 0) = 1;
+ assert: (0 raisedToInteger: 2) = 0;
+ assert: (2 raisedToInteger: -1) = (1/2);
+ assert: (2 raisedToInteger: -4) = (1/16).
+
+ self
+ assert: (-3 raisedTo: 0) = 1;
+ assert: (-3 raisedTo: 1) = -3;
+ assert: (-3 raisedTo: 2) = 9;
+ assert: (-3 raisedTo: 3) = -27;
+ assert: (-3 raisedTo: -2) = (1/9);
+ assert: (-3 raisedTo: -3) = (-1/27).
+
+ self should: [ 0 raisedTo: -1 ] raise: ZeroDivide!
Item was added:
+ ----- Method: NumberTest>>testRaisedToIntegerWithFloats (in category 'tests') -----
+ testRaisedToIntegerWithFloats
+
+ self
+ assert: (2.0 raisedToInteger: 0) = 1.0;
+ assert: (2.0 raisedToInteger: 1) = 2.0;
+ assert: (2.0 raisedToInteger: 4) = 16.0;
+ assert: (0.0 raisedToInteger: 0) = 1.0;
+ assert: (0.0 raisedToInteger: 2) = 0.0;
+ assert: (2.0 raisedToInteger: -1) = 0.5;
+ assert: (2.0 raisedToInteger: -4) = 0.0625.
+
+ self
+ assert: (-3.0 raisedTo: 0) = 1.0;
+ assert: (-3.0 raisedTo: 1) = -3.0;
+ assert: (-3.0 raisedTo: 2) = 9.0;
+ assert: (-3.0 raisedTo: 3) = -27.0;
+ assert: (-2.0 raisedTo: -2) = 0.25;
+ assert: (-2.0 raisedTo: -3) = -0.125.
+
+ self should: [ 0.0 raisedTo: -1 ] raise: ZeroDivide!
Item was added:
+ ----- Method: NumberTest>>testReadFrom (in category 'tests') -----
+ testReadFrom
+
+ self assert: 1.0e-14 = (Number readFrom: '1.0e-14').
+ self assert: 2r1e26 = (Number readFrom: '2r1e26').!
Item was added:
+ ----- Method: NumberTest>>testReciprocal (in category 'tests') -----
+ testReciprocal
+
+ self
+ assert: 1 reciprocal = 1;
+ assert: 2 reciprocal = (1/2);
+ assert: -1 reciprocal = -1;
+ assert: -3 reciprocal = (-1/3).
+
+ self should: [ 0 reciprocal ] raise: ZeroDivide!
Item was added:
+ ----- Method: NumberTest>>testRoundTo (in category 'tests - trunction and round off') -----
+ testRoundTo
+
+ {
+ 1 . 1.0 . 1.0 .
+ 1.0 . 1 . 1 .
+ 1/3 . 1/4 . 1/4 .
+ 0.9 . 1/3 . 1 .
+ } groupsDo: [:receiver :argument :expected |
+ self assert: expected equals: (receiver roundTo: argument)]!
Item was added:
+ ----- Method: NumberTest>>testZeroDivideHandler (in category 'tests') -----
+ testZeroDivideHandler
+ "Test for user-defined ZeroDivide behavior"
+
+ [
+ self assert: 1 / 0 = Float infinity.
+ self assert: -1 / 0 = Float negativeInfinity.
+ self assert: 1.0 / 0 = Float infinity.
+ self assert: -1.0 / 0 = Float negativeInfinity.
+ self assert: 1 / 0.0 = Float infinity.
+ self assert: -1 / 0.0 = Float negativeInfinity.
+ self assert: 1.0 / 0.0 = Float infinity.
+ self assert: -1.0 / 0.0 = Float negativeInfinity.
+ ] on: ZeroDivide
+ do: [:ex | ex resume: ex dividend sign * Float infinity ]
+ !
Item was added:
+ ClassTestCase subclass: #ObjectTest
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'KernelTests-Objects'!
Item was added:
+ ----- Method: ObjectTest>>a (in category 'private') -----
+ a
+ self b.!
Item was added:
+ ----- Method: ObjectTest>>a1 (in category 'private') -----
+ a1
+ self b1.!
Item was added:
+ ----- Method: ObjectTest>>b (in category 'private') -----
+ b
+ self haltIf: #testHaltIf.!
Item was added:
+ ----- Method: ObjectTest>>b1 (in category 'private') -----
+ b1
+ self haltIf: #testasdasdfHaltIf.!
Item was added:
+ ----- Method: ObjectTest>>testAssert (in category 'tests - debugging') -----
+ testAssert
+ Object assert: [true].
+ Object assert: true.
+ self should: [Object assert: [false]] raise: AssertionFailure.
+ self should: [Object assert: false] raise: AssertionFailure.!
Item was added:
+ ----- Method: ObjectTest>>testBecome (in category 'tests') -----
+ testBecome
+ "self debug: #testBecome"
+ "this test should that all the variables pointing to an object are pointing now to another one, and all
+ object pointing to the other are pointing to the object"
+
+ | pt1 pt2 pt3 |
+ pt1 := 0@0.
+ pt2 := pt1.
+ pt3 := 100@100.
+
+ pt1 become: pt3.
+ self assert: pt2 = (100@100).
+ self assert: pt3 = (0@0).
+ self assert: pt1 = (100@100).!
Item was added:
+ ----- Method: ObjectTest>>testBecomeForward (in category 'tests') -----
+ testBecomeForward
+ "self debug: #testBecomeForward"
+ "this test should that all the variables pointing to an object are pointing now to another one.
+ Not that this inverse is not true. This kind of become is called oneWayBecome in VW"
+
+ | pt1 pt2 pt3 |
+ pt1 := 0@0.
+ pt2 := pt1.
+ pt3 := 100@100.
+ pt1 becomeForward: pt3.
+ self assert: pt2 = (100@100).
+ self assert: pt3 == pt2.
+ self assert: pt1 = (100@100)!
Item was added:
+ ----- Method: ObjectTest>>testCaseOf (in category 'tests') -----
+ testCaseOf
+
+ | a b c dict |
+ a := Object new.
+ b := Object new.
+ c := Object new.
+ dict := {
+ [a] -> [b].
+ [b] -> [c].
+ [c] -> [a] }.
+ self assert: b equals: (a caseOf: dict).
+ self assert: c equals: (b caseOf: dict).
+ self assert: a equals: (c caseOf: dict).
+ self should: [nil caseOf: dict] raise: Error.!
Item was added:
+ ----- Method: ObjectTest>>testCaseOfInlined (in category 'tests') -----
+ testCaseOfInlined
+
+ | a b c |
+ a := Object new.
+ b := Object new.
+ c := Object new.
+ self assert: b equals: (a caseOf: { [a] -> [b]. [b] -> [c]. [c] -> [a] }).
+ self assert: c equals: (b caseOf: { [a] -> [b]. [b] -> [c]. [c] -> [a] }).
+ self assert: a equals: (c caseOf: { [a] -> [b]. [b] -> [c]. [c] -> [a] }).
+ self should: [nil caseOf: { [a] -> [b]. [b] -> [c]. [c] -> [a] }] raise: Error.!
Item was added:
+ ----- Method: ObjectTest>>testCaseOfOtherwise (in category 'tests') -----
+ testCaseOfOtherwise
+
+ | a b c dict |
+ a := Object new.
+ b := Object new.
+ c := Object new.
+ dict := {
+ [a] -> [b].
+ [b] -> [c].
+ [c] -> [a] }.
+
+ self assert: b equals: (a caseOf: dict otherwise: [self fail]).
+ self assert: c equals: (b caseOf: dict otherwise: [self fail]).
+ self assert: a equals: (c caseOf: dict otherwise: [self fail]).
+ self assert: 42 equals: (nil caseOf: dict otherwise: [42]).
+ self assert: 42 equals: (6 caseOf: dict otherwise: [:x | x * 7]).!
Item was added:
+ ----- Method: ObjectTest>>testCaseOfOtherwiseInlined (in category 'tests') -----
+ testCaseOfOtherwiseInlined
+
+ | a b c |
+ a := Object new.
+ b := Object new.
+ c := Object new.
+ self assert: b equals: (a caseOf: { [a] -> [b]. [b] -> [c]. [c] -> [a] } otherwise: [self fail]).
+ self assert: c equals: (b caseOf: { [a] -> [b]. [b] -> [c]. [c] -> [a] } otherwise: [self fail]).
+ self assert: a equals: (c caseOf: { [a] -> [b]. [b] -> [c]. [c] -> [a] } otherwise: [self fail]).
+ self assert: 42 equals: (nil caseOf: { [a] -> [b]. [b] -> [c]. [c] -> [a] } otherwise: [42]).
+ self assert: 42 equals: (6 caseOf: { [a] -> [b]. [b] -> [c]. [c] -> [a] } otherwise: [:x | x * 7]).!
Item was added:
+ ----- Method: ObjectTest>>testCopyDependents (in category 'tests') -----
+ testCopyDependents
+
+ | bar foo |
+ foo := Object new.
+ foo addDependent: 42.
+ self assert: {42} equals: foo dependents asArray.
+
+ bar := foo copy.
+ self assert: bar dependents isEmpty.!
Item was added:
+ ----- Method: ObjectTest>>testEvaluateWheneverChangeIn (in category 'tests - debugging') -----
+ testEvaluateWheneverChangeIn
+
+ | counter instance target |
+ instance := Object new.
+ counter := 0.
+ target := #notExecuted.
+ instance
+ evaluate: [target := #executed]
+ wheneverChangeIn: [counter].
+ counter := counter + 1.
+
+ instance name.
+
+ self assert: #executed equals: target.!
Item was added:
+ ----- Method: ObjectTest>>testEvaluateWheneverChangeInTransparent (in category 'tests - debugging') -----
+ testEvaluateWheneverChangeInTransparent
+
+ | instance |
+ instance := Object new.
+ instance
+ evaluate: []
+ wheneverChangeIn: [].
+ self assert: instance yourself == instance.!
Item was added:
+ ----- Method: ObjectTest>>testHaltIf (in category 'tests - testing') -----
+ testHaltIf
+
+ self should: [self haltIf: true] raise: Halt.
+ self haltIf: false.
+
+ self should: [self haltIf: [true]] raise: Halt.
+ self haltIf: [false].
+
+ self should: [self haltIf: #testHaltIf.] raise: Halt.
+ self haltIf: #teadfasdfltIf.
+
+ self should: [self a] raise: Halt.
+ self a1.
+
+ self should: [self haltIf: [:o | o class = self class]] raise: Halt.
+ self haltIf: [:o | o class ~= self class].
+ !
Item was added:
+ ----- Method: ObjectTest>>testIfNotNilDoDeprecation (in category 'tests') -----
+ testIfNotNilDoDeprecation
+
+ #(ifNotNilDo: #ifNil:ifNotNilDo: #ifNotNilDo:ifNil:) do: [ :selector |
+ | senders |
+ senders := self systemNavigation allCallsOn: selector.
+ self
+ assert: senders size = 1
+ description: (String streamContents: [ :stream |
+ | thisSelector |
+ stream
+ nextPutAll: 'Unexpected senders of ';
+ print: selector;
+ nextPutAll: ': '.
+ thisSelector := thisContext method selector.
+ (senders reject: [ :each |
+ (each actualClass == self class
+ and: [ each selector == thisSelector ]) ])
+ do: [ :each |
+ stream
+ nextPutAll: each actualClass name;
+ nextPutAll: ' >> ';
+ print: each selector ]
+ separatedBy: [ stream nextPutAll: ', ' ] ]) ]!
Item was added:
+ ----- Method: ObjectTest>>testNotNil (in category 'tests - testing') -----
+ testNotNil
+
+ self assert: Object new notNil!
Item was added:
+ ----- Method: ObjectTest>>testPerform (in category 'tests') -----
+ testPerform
+
+ | object |
+ object := Object new.
+ self assert: object equals: (object perform: #yourself).
+ self deny: 1 equals: (object perform: #yourself).
+ self assert: 4 equals: (2 perform: #squared).
+ self deny: 3 equals: (2 perform: #squared)!
Item was added:
+ ----- Method: ObjectTest>>testPerformWith (in category 'tests') -----
+ testPerformWith
+
+ self assert: 7 equals: (3 perform: #+ with: 4)!
Item was added:
+ ----- Method: ObjectTest>>testPerformWithWith (in category 'tests') -----
+ testPerformWithWith
+
+ | receiver |
+ receiver := [ :a :b | { a. b } ].
+ self assert: #(1 2) equals: (receiver perform: #value:value: with: 1 with: 2)!
Item was added:
+ ----- Method: ObjectTest>>testPerformWithWithWith (in category 'tests') -----
+ testPerformWithWithWith
+
+ | receiver |
+ receiver := [ :a :b :c | { a. b. c } ].
+ self assert: #(1 2 3) equals: (receiver perform: #value:value:value: with: 1 with: 2 with: 3)!
Item was added:
+ ----- Method: ObjectTest>>testPerformWithWithWithWith (in category 'tests') -----
+ testPerformWithWithWithWith
+
+ | receiver |
+ receiver := [ :a :b :c :d | { a. b. c. d } ].
+ self assert: #(1 2 3 4) equals: (receiver perform: #value:value:value:value: with: 1 with: 2 with: 3 with: 4)!
Item was added:
+ ----- Method: ObjectTest>>testPerformWithWithWithWithWith (in category 'tests') -----
+ testPerformWithWithWithWithWith
+
+ | receiver |
+ receiver := [ :a :b :c :d :e | { a. b. c. d. e } ].
+ self assert: #(1 2 3 4 5) equals: (receiver perform: #value:value:value:value:value: with: 1 with: 2 with: 3 with: 4 with: 5)!
Item was added:
+ ----- Method: ObjectTest>>testPinning (in category 'tests') -----
+ testPinning
+ "Test pinning state changes for two objects. Iterate over all possible state transitions."
+
+ | objects |
+ objects := { Object new. Object new }.
+ #((false false) (false true) (true false) (true true))
+ combinations: 2
+ atATimeDo: [ :transition |
+ | fromState toState |
+ fromState := transition first.
+ toState := transition second.
+ fromState with: objects do: [ :pinned :object |
+ pinned
+ ifTrue: [ object pin ]
+ ifFalse: [ object unpin ].
+ self assert: pinned equals: object isPinned ].
+ objects withIndexDo: [ :object :index |
+ | from to |
+ from := fromState at: index.
+ to := toState at: index.
+ self assert: from equals: (to
+ ifTrue: [ object pin ]
+ ifFalse: [ object unpin ]).
+ self assert: to equals: object isPinned ] ]!
Item was added:
+ ----- Method: ObjectTest>>testReadCarefullyFrom (in category 'tests') -----
+ testReadCarefullyFrom
+
+ self should: [Object readCarefullyFrom: nil] raise: Error.
+ self should: [Object readCarefullyFrom: Object new] raise: Error.
+ self assert: [(Object readCarefullyFrom: 'Object new') isKindOf: Object].
+ self
+ should: [self
+ should: [Object newSubclass readCarefullyFrom: 'self assert: Object isNil']
+ raise: AssertionFailure. "environment must be installed"]
+ raise: Error. "because we return nil"
+ self should: [(UndefinedObject readCarefullyFrom: 'Object new')] raise: Error.
+ self should: [Object readCarefullyFrom: 'Object new:'] raise: Error.!
Item was added:
+ ----- Method: ObjectTest>>testReadFrom (in category 'tests') -----
+ testReadFrom
+
+ self should: [Object readFrom: nil] raise: Error.
+ self should: [Object readFrom: Object new] raise: Error.
+ self assert: [(Object readFrom: 'Object new') isKindOf: Object].
+ self
+ should: [self
+ should: [Object newSubclass readFrom: 'self assert: Object isNil']
+ raise: AssertionFailure. "environment must be installed"]
+ raise: Error. "because we return nil"
+ self should: [(UndefinedObject readFrom: 'Object new')] raise: Error.
+ self should: [Object readFrom: 'Object new:'] raise: SyntaxErrorNotification.!
Item was added:
+ ----- Method: ObjectTest>>testShouldBeImplemented (in category 'tests') -----
+ testShouldBeImplemented
+ | testClass |
+ testClass := NotImplementedTestData.
+ self should: [testClass new shouldBeImplementedMsg] raise: NotImplemented.
+ [testClass new shouldBeImplementedMsg] ifError: [:errDesc |
+ self assert: (errDesc includesSubstring: testClass name) description: 'Error should include class name'.
+ self assert: (errDesc includesSubstring: #shouldBeImplementedMsg asString) description: 'Error should include selector name'].!
Item was added:
+ ----- Method: ObjectTest>>testShouldNotImplement (in category 'tests') -----
+ testShouldNotImplement
+ | testClass |
+ testClass := NotImplementedTestData.
+ self should: [testClass new shouldNotImplementMsg] raise: NotImplemented.
+ [testClass new shouldNotImplementMsg] ifError: [:errDesc |
+ self assert: (errDesc includesSubstring: testClass name) description: 'Error should include class name'.
+ self assert: (errDesc includesSubstring: #shouldNotImplementMsg asString) description: 'Error should include selector name'].!
Item was added:
+ ----- Method: Process>>suspendPrimitivelyOrFail (in category '*KernelTests-Processes') -----
+ suspendPrimitivelyOrFail
+ "Test support. Execute primitive 578, or fail."
+
+ <primitive: 578>
+ ^self primitiveFailed!
Item was added:
+ TestCase subclass: #ProcessSpecificTest
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'KernelTests-Processes'!
+
+ !ProcessSpecificTest commentStamp: 'mvl 3/13/2007 13:52' prior: 0!
+ A ProcessSpecificTest is a test case for process local and dynamic variables.
+ !
Item was added:
+ ----- Method: ProcessSpecificTest>>checkDynamic: (in category 'private') -----
+ checkDynamic: value
+
+ self assert: value equals: TestDynamicVariable value.!
Item was added:
+ ----- Method: ProcessSpecificTest>>checkLocal: (in category 'private') -----
+ checkLocal: value
+
+ self assert: value equals: TestLocalVariable value.!
Item was added:
+ ----- Method: ProcessSpecificTest>>tearDown (in category 'running') -----
+ tearDown
+ "Make sure we don't pollute the running process' environment with the test variables"
+
+ { TestLocalVariable. TestDynamicVariable } do: [ :each |
+ Processor activeProcess environmentRemoveKey: each ifAbsent: [] ].
+
+ TestDynamicVariable default: nil.!
Item was added:
+ ----- Method: ProcessSpecificTest>>testAssignmentToLocalVariableReturnsTheValue (in category 'tests') -----
+ testAssignmentToLocalVariableReturnsTheValue
+
+ self assert: 1 equals: (TestLocalVariable value: 1)!
Item was added:
+ ----- Method: ProcessSpecificTest>>testDynamicVariable (in category 'tests') -----
+ testDynamicVariable
+
+ | s1 s2 p1stopped p2stopped |
+ s1 := Semaphore new.
+ s2 := Semaphore new.
+ p1stopped := p2stopped := false.
+ [
+ TestDynamicVariable value: 1 during:[
+ self checkDynamic: 1.
+ (Delay forMilliseconds: 30) wait.
+ self checkDynamic: 1.
+ TestDynamicVariable value: 3 during:[
+ (Delay forMilliseconds: 30) wait.
+ self checkDynamic: 3
+ ].
+ self checkDynamic: 1.
+ ].
+ self checkDynamic: nil.
+ p1stopped := true.
+ s1 signal.
+ ] fork.
+
+ [
+ TestDynamicVariable value: 2 during:[
+ self checkDynamic: 2.
+ (Delay forMilliseconds: 30) wait.
+ self checkDynamic: 2.
+ ].
+ self checkDynamic: nil.
+ p2stopped := true.
+ s2 signal.
+ ] fork.
+
+ "Set a maximum wait timeout so that the test case will complete
+ even if the processes fail to signal us."
+ s1 waitTimeoutSeconds: 2.
+ s2 waitTimeoutSeconds: 2.
+ self assert: p1stopped.
+ self assert: p2stopped.!
Item was added:
+ ----- Method: ProcessSpecificTest>>testDynamicVariableDefault (in category 'tests') -----
+ testDynamicVariableDefault
+
+ "Just double-check our fixture."
+ TestDynamicVariable default: #default.
+ self assert: #default equals: TestDynamicVariable default.
+
+ "Now check for default lookup out of any dynamic scope."
+ self checkDynamic: #default..
+
+ "Ignore default value by setting dynamic scope."
+ TestDynamicVariable value: #dynamic during: [
+ self checkDynamic: #dynamic].
+
+ "Out of that scope, we should fall back to the default again."
+ self checkDynamic: #default.
+
+ "...even if that default value changes."
+ TestDynamicVariable default: #anotherDefault.
+ self checkDynamic: #anotherDefault.
+ !
Item was added:
+ ----- Method: ProcessSpecificTest>>testLocalVariable (in category 'tests') -----
+ testLocalVariable
+
+ | s1 s2 p1stopped p2stopped |
+ s1 := Semaphore new.
+ s2 := Semaphore new.
+ p1stopped := p2stopped := false.
+ [
+ self checkLocal: 0.
+ TestLocalVariable value: 1.
+ self checkLocal: 1.
+ (Delay forMilliseconds: 30) wait.
+ self checkLocal: 1.
+ TestLocalVariable value: 2.
+ self checkLocal: 2.
+ p1stopped := true.
+ s1 signal.
+ ] fork.
+
+ [
+ (Delay forMilliseconds: 30) wait.
+ self checkLocal: 0.
+ TestLocalVariable value: 3.
+ self checkLocal: 3.
+ (Delay forMilliseconds: 30) wait.
+ self checkLocal: 3.
+ TestLocalVariable value: 4.
+ self checkLocal: 4.
+ p2stopped := true.
+ s2 signal.
+ ] fork.
+
+ "Set a maximum wait timeout so that the test case will complete
+ even if the processes fail to signal us."
+ s1 waitTimeoutMSecs: 5000.
+ s2 waitTimeoutMSecs: 5000.
+ self assert: p1stopped.
+ self assert: p2stopped.
+ !
Item was added:
+ AbstractProcessTest subclass: #ProcessTerminateBug
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'KernelTests-Processes'!
Item was added:
+ ----- Method: ProcessTerminateBug>>testSchedulerTermination (in category 'tests') -----
+ testSchedulerTermination
+ | process sema gotHere sema2 |
+ gotHere := false.
+ sema := Semaphore new.
+ sema2 := Semaphore new.
+ process := [
+ sema signal.
+ sema2 wait.
+ "will be suspended here"
+ gotHere := true. "e.g., we must *never* get here"
+ ] forkAt: Processor activeProcess priority.
+ sema wait. "until process gets scheduled"
+ process terminate.
+ sema2 signal.
+ Processor yield. "will give process a chance to continue and
+ horribly screw up"
+ self assert: gotHere not.
+ !
Item was added:
+ ----- Method: ProcessTerminateBug>>testTerminationDuringUnwind (in category 'tests') -----
+ testTerminationDuringUnwind
+ "An illustration of the issue of process termination during unwind.
+ This uses a well-behaved unwind block that we should allow to complete
+ if at all possible."
+ | unwindStarted unwindFinished p |
+ unwindStarted := unwindFinished := false.
+ p := [[] ensure:[
+ unwindStarted := true.
+ Processor yield.
+ unwindFinished := true.
+ ]] fork.
+ self deny: unwindStarted.
+ Processor yield.
+ self assert: unwindStarted.
+ self deny: unwindFinished.
+ p terminate.
+ self assert: unwindFinished.!
Item was added:
+ ----- Method: ProcessTerminateBug>>testUnwindFromActiveProcess (in category 'tests') -----
+ testUnwindFromActiveProcess
+ | sema process |
+ sema := Semaphore forMutualExclusion.
+ self assert:(sema isSignaled).
+ process := [
+ sema critical:[
+ self deny: sema isSignaled.
+ Processor activeProcess terminate.
+ ]
+ ] forkAt: Processor userInterruptPriority.
+ self assert: sema isSignaled.!
Item was added:
+ ----- Method: ProcessTerminateBug>>testUnwindFromForeignProcess (in category 'tests') -----
+ testUnwindFromForeignProcess
+ | sema process |
+ sema := Semaphore forMutualExclusion.
+ self assert: sema isSignaled.
+ process := [
+ sema critical:[
+ self deny: sema isSignaled.
+ sema wait. "deadlock"
+ ]
+ ] forkAt: Processor userInterruptPriority.
+ self deny: sema isSignaled.
+ "This is for illustration only - the BlockCannotReturn cannot
+ be handled here (it's truncated already)"
+ self shouldnt: [process terminate] raise: BlockCannotReturn.
+ self assert: sema isSignaled.
+ !
Item was added:
+ AbstractProcessTest subclass: #ProcessTest
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'KernelTests-Processes'!
+
+ !ProcessTest commentStamp: 'ul 8/16/2011 11:35' prior: 0!
+ I hold test cases for generic Process-related behaviour.!
Item was added:
+ ----- Method: ProcessTest>>expectedFailures (in category 'failures') -----
+ expectedFailures
+
+ ^ #(testTerminateTerminatingProcess testResumeTerminatingProcess)!
Item was added:
+ ----- Method: ProcessTest>>terminated (in category 'support') -----
+ terminated
+ "supports testProcessStateTests2"
+
+ ^self suspend.
+ !
Item was added:
+ ----- Method: ProcessTest>>testAtomicSuspend (in category 'tests') -----
+ testAtomicSuspend
+ "Test atomic suspend of foreign processes.
+ Note: this test will fail when run with older VMs without primitive suspend 578."
+
+ | list p |
+ p := [semaphore wait] fork.
+ Processor yield.
+ list := p suspendPrimitivelyOrFail.
+ self assert: list == nil.
+ !
Item was added:
+ ----- Method: ProcessTest>>testComplete (in category 'tests') -----
+ testComplete
+
+ 1 to: 5 do: [:i | | process z expected result |
+ process := [z := 1
+ in: [:x | 2
+ in: [:y |
+ Processor activeProcess suspend.
+ x + y]]] fork.
+ Processor yield.
+
+ expected := process suspendedContext stack at: i + 1.
+ result := process
+ complete: (process suspendedContext stack at: i)
+ ifError: [:error | self fail].
+
+ self assert: expected equals: result.
+ self assert: expected equals: process suspendedContext.
+
+ process runUntil: [:ctx | ctx isDead].
+
+ self should: process isTerminated.
+ self assert: 3 equals: z].!
Item was added:
+ ----- Method: ProcessTest>>testCompleteError (in category 'tests') -----
+ testCompleteError
+
+ 1 to: 5 do: [:i | | process z result error |
+ process := [z := 1
+ in: [:x | 0
+ in: [:y |
+ Processor activeProcess suspend.
+ x / y]]] fork.
+ Processor yield.
+
+ result := process
+ complete: (process suspendedContext stack at: i)
+ ifError: [:ex | error := ex].
+
+ self assert: (error isKindOf: ZeroDivide).
+ self assert: process suspendedContext equals: result.
+
+ process runUntil: [:ctx | ctx isDead].
+
+ self should: process isTerminated.
+ self assert: error equals: z].!
Item was added:
+ ----- Method: ProcessTest>>testEnvironmentAt (in category 'tests') -----
+ testEnvironmentAt
+ Processor activeProcess environmentAt: #processTests put: 42.
+ self assert: (Processor activeProcess environmentAt: #processTests) = 42.
+ self should: [Processor activeProcess environmentAt: #foobar] raise: Error!
Item was added:
+ ----- Method: ProcessTest>>testEnvironmentAtPut (in category 'tests') -----
+ testEnvironmentAtPut
+ self assert: (Processor activeProcess environmentAt: #processTests put: 42) = 42.!
Item was added:
+ ----- Method: ProcessTest>>testEnvironmentRemoveKey (in category 'tests') -----
+ testEnvironmentRemoveKey
+ Processor activeProcess environmentAt: #processTests put: 42.
+ Processor activeProcess environmentRemoveKey: #processTests.
+ self assert: (Processor activeProcess environmentAt: #processTests ifAbsent: []) isNil.
+ self should: [Processor activeProcess environmentAt: #processTests] raise: Error!
Item was added:
+ ----- Method: ProcessTest>>testEvaluateOnBehalfOf (in category 'tests') -----
+ testEvaluateOnBehalfOf
+
+ | p1 p2 sem results |
+ self genuineProcess == Processor activeProcess
+ ifFalse: [self fail: 'Cannot debug this test'].
+
+ sem := Semaphore new.
+ p1 := [] newProcess.
+ p1 environmentAt: #foo put: 1.
+ p2 := [
+ Processor activeProcess environmentAt: #foo put: 2.
+ results := {
+ Processor activeProcess environmentAt: #foo.
+ self genuineProcess environmentAt: #foo.
+ Processor activeProcess
+ evaluate: [Processor activeProcess environmentAt: #foo]
+ onBehalfOf: p1.
+ Processor activeProcess
+ evaluate: [self genuineProcess environmentAt: #foo]
+ onBehalfOf: p1.
+ Processor activeProcess environmentAt: #foo }.
+ sem signal
+ ] newProcess.
+
+ p2 resume.
+ sem wait.
+
+ self assert: {2. 2. 1. 2. 2} equals: results.!
Item was added:
+ ----- Method: ProcessTest>>testPrioritySetBeforeSuspendedContext (in category 'tests') -----
+ testPrioritySetBeforeSuspendedContext
+ "Test whether priority is set before suspendedContext during process creation."
+
+ "Setting priority after causes an endless stream of error windows when debugging e.g.
+ [] newProcess
+ when Process Browser is open with auto-update on.
+
+ Once the suspendedContext is set, the new process is no longer considered terminated
+ and Process Browser will try to place it in its list of processes but encounters a nil error
+ when reading its priority because it has not been set yet."
+
+ | p inside |
+ inside := false.
+ p := [inside := true. [] newProcess] newProcess.
+ p runUntil: [:ctx | inside].
+ p runUntil: [:ctx | ctx selectorToSendOrSelf = #suspendedContext:].
+ "Now p is before assigning suspendedContext in Process class >> forContext:priority:
+ tempAt: 3 is the local variable 'newProcess' representing the newly created process;
+ verify whether the new process's priority has already been set."
+ self assert: (p suspendedContext tempAt: 3) priority notNil!
Item was added:
+ ----- Method: ProcessTest>>testProcessFaithfulRunning (in category 'tests') -----
+ testProcessFaithfulRunning
+ "While simulating a process using #runUntilErrorOrReturnFrom:, process variables should be looked up in the process being simulated. Acceptance test for process-faithful debugging, see #evaluate:onBehalfOf:."
+
+ | process result |
+ process := Process forBlock: [
+ result := Processor activeProcess environmentAt: #foo].
+ process environmentAt: #foo put: 42.
+
+ process complete: process suspendedContext.
+
+ self assert: 42 equals: result.!
Item was added:
+ ----- Method: ProcessTest>>testProcessFaithfulSimulation (in category 'tests') -----
+ testProcessFaithfulSimulation
+ "While simulating a process using the bytecode simulation machinery, process variables should be looked up in the process being simulated. Acceptance test for process-faithful debugging, see #evaluate:onBehalfOf:."
+
+ | process result |
+ process := Process forBlock: [
+ result := Processor activeProcess environmentAt: #foo].
+ process environmentAt: #foo put: 42.
+
+ process runUntil: [:context | context isDead].
+
+ self assert: 42 equals: result.!
Item was added:
+ ----- Method: ProcessTest>>testProcessFaithfulTerminate (in category 'tests') -----
+ testProcessFaithfulTerminate
+
+ ^ self testProcessFaithfulTermination: #terminate!
Item was added:
+ ----- Method: ProcessTest>>testProcessFaithfulTerminateAggressively (in category 'tests') -----
+ testProcessFaithfulTerminateAggressively
+
+ ^ self testProcessFaithfulTermination: #terminateAggressively!
Item was added:
+ ----- Method: ProcessTest>>testProcessFaithfulTermination: (in category 'support') -----
+ testProcessFaithfulTermination: terminator
+ "When terminating a process, unwind blocks should be evaluated as if they were executed by the process being terminated."
+
+ | process result |
+ process := [
+ [Processor activeProcess suspend]
+ ensure: [result := Processor activeProcess environmentAt: #foo]]
+ fork.
+ Processor yield.
+ process environmentAt: #foo put: 42.
+
+ terminator value: process.
+
+ self should: process isTerminated.
+ self assert: 42 equals: result.!
Item was added:
+ ----- Method: ProcessTest>>testProcessStateTestDestroy (in category 'tests') -----
+ testProcessStateTestDestroy
+
+ ^ self testProcessStateTestTermination: #destroy!
Item was added:
+ ----- Method: ProcessTest>>testProcessStateTestTerminate (in category 'tests') -----
+ testProcessStateTestTerminate
+
+ ^ self testProcessStateTestTermination: #terminate!
Item was added:
+ ----- Method: ProcessTest>>testProcessStateTestTerminateAggressively (in category 'tests') -----
+ testProcessStateTestTerminateAggressively
+
+ ^ self testProcessStateTestTermination: #terminateAggressively!
Item was added:
+ ----- Method: ProcessTest>>testProcessStateTestTermination: (in category 'support') -----
+ testProcessStateTestTermination: terminator
+ "I test that a process is terminated when it reaches the last instruction
+ of the bottom context for methods other than Process>>#terminate;
+ this test would fail with the version of isTerminated before 3/11/2021."
+
+ | bottomContext newProcess |
+
+ newProcess := Process new.
+ bottomContext := Context
+ sender: nil
+ receiver: newProcess
+ method: (ProcessTest>>#terminated)
+ arguments: {}.
+ newProcess suspendedContext: ([] asContextWithSender: bottomContext).
+ newProcess priority: Processor activePriority.
+
+ self deny: newProcess isTerminated.
+ terminator value: newProcess.
+ self assert: newProcess isTerminated.
+ !
Item was added:
+ ----- Method: ProcessTest>>testProcessStateTests (in category 'tests') -----
+ testProcessStateTests
+ self assert: Processor activeProcess isActiveProcess.
+ self deny: Processor activeProcess isBlocked.
+ self assert: Processor activeProcess isRunnable.
+ self deny: Processor activeProcess isSuspended.
+ self deny: Processor activeProcess isTerminated.
+
+ "These processes are runnable but haven't got to the wait yet because the active process is running."
+ self deny: ([semaphore wait] forkAt: Processor activePriority) isActiveProcess.
+ self deny: ([semaphore wait] forkAt: Processor activePriority) isBlocked.
+ self assert: ([semaphore wait] forkAt: Processor activePriority) isRunnable.
+ self deny: ([semaphore wait] forkAt: Processor activePriority) isSuspended.
+ self deny: ([semaphore wait] forkAt: Processor activePriority) isTerminated.
+ self deny: ([semaphore wait] forkAt: Processor activePriority) suspendingList == semaphore.
+
+ "These processes do get to run because, being higher priority they preempt the active process until they wait on the semaphore."
+ self deny: ([semaphore wait] forkAt: Processor activePriority + 1) isActiveProcess.
+ self assert: ([semaphore wait] forkAt: Processor activePriority + 1) isBlocked.
+ self deny: ([semaphore wait] forkAt: Processor activePriority + 1) isRunnable.
+ self deny: ([semaphore wait] forkAt: Processor activePriority + 1) isSuspended.
+ self deny: ([semaphore wait] forkAt: Processor activePriority + 1) isTerminated.
+ self assert: ([semaphore wait] forkAt: Processor activePriority + 1) suspendingList == semaphore.
+
+ "These processes should be suspended, not terminated."
+ self deny: ([Processor activeProcess suspend] forkAt: Processor activePriority + 1) isActiveProcess.
+ self deny: ([Processor activeProcess suspend] forkAt: Processor activePriority + 1) isBlocked.
+ self deny: ([Processor activeProcess suspend] forkAt: Processor activePriority + 1) isRunnable.
+ self assert: ([Processor activeProcess suspend] forkAt: Processor activePriority + 1) isSuspended.
+ self deny: ([Processor activeProcess suspend] forkAt: Processor activePriority + 1) isTerminated.
+ self assert: ([Processor activeProcess suspend] forkAt: Processor activePriority + 1) suspendingList isNil.
+
+ "These processes should be terminated, not suspended."
+ #(terminate terminateAggressively destroy) do: [:terminator |
+ self deny: ([terminator value: Processor activeProcess] forkAt: Processor activePriority + 1) isActiveProcess.
+ self deny: ([terminator value: Processor activeProcess] forkAt: Processor activePriority + 1) isBlocked.
+ self deny: ([terminator value: Processor activeProcess] forkAt: Processor activePriority + 1) isRunnable.
+ self deny: ([terminator value: Processor activeProcess] forkAt: Processor activePriority + 1) isSuspended.
+ self assert: ([terminator value: Processor activeProcess] forkAt: Processor activePriority + 1) isTerminated.
+ self assert: ([terminator value: Processor activeProcess] forkAt: Processor activePriority + 1) suspendingList isNil].
+
+ "These processes should be suspended."
+ self deny: (([semaphore wait] forkAt: Processor activePriority) suspend; yourself) isActiveProcess.
+ self deny: (([semaphore wait] forkAt: Processor activePriority) suspend; yourself) isBlocked.
+ self deny: (([semaphore wait] forkAt: Processor activePriority) suspend; yourself) isRunnable.
+ self assert: (([semaphore wait] forkAt: Processor activePriority) suspend; yourself) isSuspended.
+ self deny: (([semaphore wait] forkAt: Processor activePriority) suspend; yourself) isTerminated.
+
+ "These processes should be terminated."
+ #(terminate terminateAggressively destroy) do: [:terminator |
+ self deny: (terminator value: ([semaphore wait] forkAt: Processor activePriority)) isActiveProcess.
+ self deny: (terminator value: ([semaphore wait] forkAt: Processor activePriority)) isBlocked.
+ self deny: (terminator value: ([semaphore wait] forkAt: Processor activePriority)) isRunnable.
+ self deny: (terminator value: ([semaphore wait] forkAt: Processor activePriority)) isSuspended.
+ self assert: (terminator value: ([semaphore wait] forkAt: Processor activePriority)) isTerminated].!
Item was added:
+ ----- Method: ProcessTest>>testProcessStateTests2 (in category 'tests') -----
+ testProcessStateTests2
+ "I test that a process is terminated when it reaches the last instruction
+ of the bottom context for methods other than Process>>#terminate;
+ this test would fail with the version of isTerminated before 3/11/2021."
+
+ | bottomContext newProcess |
+
+ newProcess := Process new.
+ bottomContext := Context
+ sender: nil
+ receiver: newProcess
+ method: (ProcessTest>>#terminated)
+ arguments: {}.
+ newProcess suspendedContext: ([] asContextWithSender: bottomContext).
+ newProcess priority: Processor activePriority.
+
+ self deny: newProcess isTerminated.
+ newProcess terminate.
+ self assert: newProcess isTerminated.
+ !
Item was added:
+ ----- Method: ProcessTest>>testResumeTerminatingProcess (in category 'tests') -----
+ testResumeTerminatingProcess
+ "An attempt to resume a terminating process should probably raise an error;
+ leave this test as an expected failure for the moment."
+
+ | terminatee terminator resumed semaphore |
+ semaphore := Semaphore new.
+ terminatee := [semaphore critical:[]. resumed := true] fork.
+ Processor yield.
+ terminator := [terminatee terminate] newProcess.
+ self assert: terminatee suspendingList == semaphore.
+ self assert: terminator isSuspended.
+ "run terminator and stop inside #terminate"
+ terminator runUntil: [:ctx | ctx selectorToSendOrSelf = #priority:].
+ self assert: terminator isSuspended.
+ "resume the terminatee process and and check if the VM raises an error;
+ an error is expected because terminatee's suspendedContext equals nil"
+ self should: [terminatee resume] raise: Error.
+ "now let the terminator finish terminating the terminatee process"
+ terminator resume.
+ Processor yield.
+ self assert: resumed isNil.
+ self assert: terminatee isTerminated.
+ self assert: terminator isTerminated!
Item was added:
+ ----- Method: ProcessTest>>testRevisedSuspendExpectations (in category 'tests') -----
+ testRevisedSuspendExpectations
+ "Test revised suspend expectations vs. pre-2022 VM's suspend"
+
+ | s p list |
+ s := Semaphore new.
+ p := [s critical:[]] forkAt: Processor activePriority + 1.
+ list := p suspend.
+
+ Smalltalk processSuspensionUnblocks
+ ifFalse: [
+ self assert: p suspendingList equals: nil.
+ self assert: list equals: nil.
+ self deny: p suspendedContext selectorJustSentOrSelf equals: #wait
+ ]
+ ifTrue: [
+ self assert: p suspendingList equals: nil.
+ self assert: list equals: s.
+ self assert: p suspendedContext selectorJustSentOrSelf equals: #wait
+ ]!
Item was added:
+ ----- Method: ProcessTest>>testTerminateByHighestPriorityProcess (in category 'tests') -----
+ testTerminateByHighestPriorityProcess
+ "Test temination by a highest priority process."
+
+ "Note: in case #terminate elevates the priority of the terminating
+ process it has to make sure it doesn't exceed the highest priority.
+ Workspace example:
+ q := [Semaphore new wait] fork.
+ p := [q terminate] forkAt: Processor highestPriority.
+ q isTerminated
+
+ We have to catch the 'Invalid priority' error via the 'error' variable
+ because #shouldnt:raise: doesn't work between two processes."
+
+ | p q error |
+ p := [Semaphore new wait] fork.
+ Processor yield.
+ self assert: p isBlocked.
+ error := false.
+ q := [[p terminate] on: Error do: [error := true]] newProcess.
+ q priority: Processor highestPriority.
+ q resume.
+ self deny: error.
+ self assert: p isTerminated.
+ self assert: q isTerminated!
Item was added:
+ ----- Method: ProcessTest>>testTerminateEnsureAsStackTop (in category 'tests') -----
+ testTerminateEnsureAsStackTop
+ "Test #ensure unwind block is executed even when #ensure context is on stack's top."
+
+ | p1 p2 p3 x1 x2 x3 |
+ x1 := x2 := x3 := false.
+
+ "p1 is at the beginning of the ensure block and the unwind block hasn't run yet"
+ p1 := Process
+ forBlock: [[] ensure: [x1 := x1 not]]
+ runUntil: [:ctx | ctx isUnwindContext and: [(ctx tempAt: 2) isNil]].
+ p1 step. p1 step. "move the pc behind the send: valueNoContextSwitch instruction"
+
+ "p2 has already set complete to true (tempAt: 2) but the unwind block hasn't run yet"
+ p2 := Process
+ forBlock: [[] ensure: [x2 := x2 not]]
+ runUntil: [:ctx | ctx isUnwindContext and: [(ctx tempAt: 2) notNil]].
+
+ "p3 has already set complete to true AND the unwind block has already run;
+ we have to verify the unwind block is not executed again during termination"
+ p3 := Process
+ forBlock: [[] ensure: [x3 := x3 not]]
+ runUntil: [:ctx | ctx isUnwindContext and: [ctx willReturn]].
+
+ "make sure all processes are running and only the p3's unwind block has finished"
+ self deny: p1 isTerminated | p2 isTerminated | p3 isTerminated.
+ self deny: x1 | x2.
+ self assert: x3. "p3 has already run its unwind block; we test it won't run it again"
+ "terminate all processes and verify all unwind blocks have finished correctly"
+ p1 terminate. p2 terminate. p3 terminate.
+ self assert: p1 isTerminated & p2 isTerminated & p3 isTerminated.
+ self assert: x1 & x2 & x3!
Item was added:
+ ----- Method: ProcessTest>>testTerminateEnsureOnTopOfEnsure (in category 'tests') -----
+ testTerminateEnsureOnTopOfEnsure
+ "Test two ensure contexts on top of each other unwind correctly,
+ that both their unwind blocks get executed."
+
+ | beenHere beenHereToo bottom p top |
+ beenHere := beenHereToo := false.
+ bottom := Context contextEnsure: [beenHereToo := true].
+ top := Context contextEnsure: [Processor activeProcess suspend. beenHere := true].
+ top privSender: bottom.
+ p := Process forContext: top priority: Processor activeProcess priority.
+ p resume.
+ Processor yield.
+ self assert: p isSuspended.
+ p terminate.
+ self assert: beenHere & beenHereToo.
+ self assert: p isTerminated
+
+ !
Item was added:
+ ----- Method: ProcessTest>>testTerminateHandlingUnwindError (in category 'tests') -----
+ testTerminateHandlingUnwindError
+ "Test an error inside an unwind block is handled correctly."
+
+ "Workspace example:
+ [ [[Processor activeProcess terminate] ensure: [1/0]] on: ZeroDivide do: [] ] fork
+
+ ZeroDivide error should get caught by the handler without opening the Debugger.
+
+ To model this example as a test case we have to keep in mind that an error signal
+ in one thread cannot be caught in a different thread: if process 'p' signals an error
+ it won't be searching for a handler in the thread that sent 'p terminate' message.
+ So we can't do something like:
+ p := [ [ [Semaphore new wait] ensure: [1/0] ] on: ZeroDivide do: [] ] fork.
+ Processor yield.
+ self shouldnt: [p terminate] raise: Error
+ Instead, in order to catch the situation the ZeroDivide error is not caught within 'p',
+ we try to catch the UnhandledError raised in 'p' indicating the ZeroDivide has been
+ missed. "
+
+ | p error unwindBlock |
+ unwindBlock := [[1/0] on: UnhandledError do: [error := true]].
+ p := [ [ [Semaphore new wait] ensure: unwindBlock ] on: ZeroDivide do: [] ] fork.
+ Processor yield.
+ self assert: p isBlocked.
+ error := false.
+ p terminate.
+ self deny: error.
+ self assert: p isTerminated!
Item was added:
+ ----- Method: ProcessTest>>testTerminateHighestPriorityProcess (in category 'tests') -----
+ testTerminateHighestPriorityProcess
+ "Test termination of a highest priority process."
+
+ | p |
+ p := [Semaphore new wait] forkAt: Processor highestPriority.
+ Processor yield.
+ self assert: p isBlocked.
+ p terminate.
+ self assert: p isTerminated!
Item was added:
+ ----- Method: ProcessTest>>testTerminateInTerminate (in category 'tests') -----
+ testTerminateInTerminate
+ "Terminating a terminator process should unwind both the terminator and its terminatee process"
+
+ | terminator terminatee unwound |
+ unwound := false.
+ terminatee := [[Processor activeProcess suspend] ensure: [unwound := true]] fork.
+ Processor yield.
+ terminator := [terminatee terminate] newProcess.
+ self assert: terminatee isSuspended.
+ self assert: terminator isSuspended.
+ "run terminator and stop inside #terminate"
+ terminator runUntil: [:ctx | ctx selectorToSendOrSelf = #priority:].
+ self assert: terminator isSuspended.
+ terminator terminate.
+ self assert: terminator isTerminated.
+ self assert: unwound!
Item was added:
+ ----- Method: ProcessTest>>testTerminateNestedUnwind (in category 'tests') -----
+ testTerminateNestedUnwind
+ "Test all nested unwind blocks are correctly unwound; all unwind blocks halfway through their execution should be completed or at least attempted to complete, not only the innermost one"
+
+ | p x1 x2 x3 |
+ x1 := x2 := x3 := false.
+ p :=
+ [
+ [
+ [ ] ensure: [ "halfway through completion when suspended"
+ [ ] ensure: [ "halfway through completion when suspended"
+ Processor activeProcess suspend.
+ x1 := true].
+ x2 := true]
+ ] ensure: [ "not started yet when suspended"
+ x3 := true]
+ ] fork.
+ Processor yield.
+ p terminate.
+
+ self assert: x1.
+ self assert: x2.
+ self assert: x3.!
Item was added:
+ ----- Method: ProcessTest>>testTerminateNestedUnwindAggressively (in category 'tests') -----
+ testTerminateNestedUnwindAggressively
+ "Test nested unwind blocks are correctly unwound; all unwind blocks halfway through their execution should not be attempted to complete."
+
+ | p x1 x2 x3 |
+ x1 := x2 := x3 := false.
+ p :=
+ [
+ [
+ [ ] ensure: [ "halfway through completion when suspended"
+ [ ] ensure: [ "halfway through completion when suspended"
+ Processor activeProcess suspend.
+ x1 := true].
+ x2 := true]
+ ] ensure: [ "not started yet when suspended"
+ x3 := true]
+ ] fork.
+ Processor yield.
+ p terminateAggressively.
+
+ self deny: x1.
+ self deny: x2.
+ self assert: x3.!
Item was added:
+ ----- Method: ProcessTest>>testTerminateNiledSuspendedContextProcess (in category 'tests') -----
+ testTerminateNiledSuspendedContextProcess
+ "Test a process with niled suspendedContext terminates correctly."
+
+ | p |
+ p := [] newProcess.
+ self assert: p isSuspended.
+ p suspendedContext: nil.
+ p terminate.
+ self assert: p isTerminated!
Item was added:
+ ----- Method: ProcessTest>>testTerminateSingleEnsure (in category 'tests') -----
+ testTerminateSingleEnsure
+ "Test a stack consisting of a single ensure context unwinds correctly."
+
+ | beenHere p singleton |
+ beenHere := false.
+ singleton := Context contextEnsure: [beenHere := true].
+ p := Process forContext: singleton priority: Processor activeProcess priority.
+ self assert: p isSuspended.
+ self assert: p suspendedContext sender isNil.
+ p terminate.
+ self assert: beenHere.
+ self assert: p isTerminated!
Item was added:
+ ----- Method: ProcessTest>>testTerminateTerminatingProcess (in category 'tests') -----
+ testTerminateTerminatingProcess
+ "An attempt to terminate a terminating process should probably raise an error;
+ leave this test as an expected failure for the moment."
+
+ | terminatee terminator resumed semaphore |
+ semaphore := Semaphore new.
+ terminatee := [semaphore critical:[]. resumed := true] fork.
+ Processor yield.
+ terminator := [terminatee terminate] newProcess.
+ self assert: terminatee suspendingList == semaphore.
+ self assert: terminator isSuspended.
+ "run terminator and stop inside #terminate"
+ terminator runUntil: [:ctx | ctx selectorToSendOrSelf = #priority:].
+ self assert: terminator isSuspended.
+ "terminate the terminatee process again and let the termination finish;
+ an error is expected because #terminate detected multiple termination"
+ self should: [terminatee terminate] raise: Error.
+ "now let the terminator finish terminating the terminatee process"
+ terminator resume.
+ Processor yield.
+ self assert: resumed isNil.
+ self assert: terminatee isTerminated.
+ self assert: terminator isTerminated!
Item was added:
+ ----- Method: ProcessTest>>testTerminateTerminatingProcessAfterUnwindStarted (in category 'tests') -----
+ testTerminateTerminatingProcessAfterUnwindStarted
+ "Terminating a terminatee process after the terminator process restarted the terminatee
+ process should unwind the terminatee process and let the terminator process terminate."
+
+ "Such a situation may occur e.g. when a terminating process encounters an error and
+ opens a debugger (or calls another recovery machinery). In such case it's legitimate
+ to terminate the terminating process again (by closing the debugger or as a termination
+ by another recovery tool).
+
+ Note: this is a different situation than in 'testTerminateTerminatingProcess' where
+ the second termination is invoked 'too early' and may cause unpredictable outcome."
+
+ | terminator terminatee unwound unwindBlock |
+ unwound := false.
+ unwindBlock := [Processor activeProcess suspend. unwound := true].
+ terminatee := [[Semaphore new wait] ensure: unwindBlock] fork.
+ Processor yield.
+ terminator := [terminatee terminate] newProcess.
+ self assert: terminatee isBlocked.
+ self assert: terminator isSuspended.
+ terminator resume.
+ Processor yield.
+ "terminator starts terminatee's unwind"
+ Processor yield.
+ "terminatee resumes and stops at unwindBlock's #suspend"
+ self assert: terminatee isSuspended.
+ terminatee terminate.
+ self assert: terminatee isTerminated.
+ self assert: unwound.
+ Processor yield.
+ self assert: terminator isTerminated!
Item was added:
+ ----- Method: ProcessTest>>testTerminateTerminatingProcessInUnwindTo (in category 'tests') -----
+ testTerminateTerminatingProcessInUnwindTo
+ "Terminating a terminatee process after the terminator process restarted the terminatee
+ process should unwind the terminatee process and let the terminator process terminate."
+
+ | terminator terminatee unwound |
+ unwound := false.
+ terminatee := [[Semaphore new wait] ensure: [unwound := true]] fork.
+ Processor yield.
+ terminator := [terminatee terminate] newProcess.
+ self assert: terminatee isBlocked.
+ self assert: terminator isSuspended.
+ terminator runUntil: [:ctx | ctx selectorToSendOrSelf = #resume].
+ "terminator steps until terminatee's unwind context is set"
+ terminator suspendedContext nextInstruction. "skip terminatee resume instruction"
+ terminator resume. "and run until parked at wait"
+ "terminatee is inside its helper stack, about to call #unwindTo:"
+ self assert: terminatee isSuspended.
+ terminatee terminate.
+ self assert: terminatee isTerminated.
+ self assert: unwound.
+ Processor yield.
+ self assert: terminator isTerminated!
Item was added:
+ ----- Method: ProcessTest>>testTerminateWithDelayInUnwind (in category 'tests') -----
+ testTerminateWithDelayInUnwind
+ "Test the process that invoked the termination of another process waits
+ for the other process to finish unwinding."
+
+ "Insert delay into the unwind block to force rescheduling; alternatively,
+ 'Processor yield' could be used instead of 'delay wait'."
+
+ | delay p |
+ delay := Delay forMilliseconds: 10.
+ p := [[Processor activeProcess suspend] ensure: [delay wait]] fork.
+ Processor yield.
+ self assert: p isSuspended.
+ p terminate.
+ self assert: p isTerminated!
Item was added:
+ AbstractProcessTest subclass: #ProcessUnwindTest
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'KernelTests-Processes'!
Item was added:
+ ----- Method: ProcessUnwindTest>>testTerminateActiveInNestedEnsure1 (in category 'tests') -----
+ testTerminateActiveInNestedEnsure1
+ "Terminate active process.
+ Test all nested unwind blocks are correctly executed;
+ all unwind blocks halfway through their execution should be completed."
+
+ | p x1 x2 x3 x4 |
+ x1 := x2 := x3 := x4 := false.
+ p :=
+ [
+ [
+ [ ] ensure: [
+ [Processor activeProcess terminate] ensure: [
+ x1 := true].
+ x2 := true]
+ ] ensure: [
+ x3 := true].
+ x4 := true.
+ ] newProcess.
+ p resume.
+ Processor yield.
+ self assert: p isTerminated.
+ self assert: x1 & x2 & x3.
+ self deny: x4.!
Item was added:
+ ----- Method: ProcessUnwindTest>>testTerminateActiveInNestedEnsure2 (in category 'tests') -----
+ testTerminateActiveInNestedEnsure2
+ "Terminate active process.
+ Test all nested unwind blocks are correctly executed;
+ all unwind blocks halfway through their execution should be completed."
+
+ | p x1 x2 x3 x4 |
+ x1 := x2 := x3 := x4 := false.
+ p :=
+ [
+ [
+ [ ] ensure: [
+ [ ] ensure: [
+ Processor activeProcess terminate.
+ x1 := true].
+ x2 := true]
+ ] ensure: [
+ x3 := true].
+ x4 := true.
+ ] newProcess.
+ p resume.
+ Processor yield.
+ self assert: p isTerminated.
+ self assert: x1 & x2 & x3.
+ self deny: x4.!
Item was added:
+ ----- Method: ProcessUnwindTest>>testTerminateBlockedInNestedEnsure1 (in category 'tests') -----
+ testTerminateBlockedInNestedEnsure1
+ "Terminate blocked process.
+ Test all nested unwind blocks are correctly executed;
+ all unwind blocks halfway through their execution should be completed."
+
+ | p x1 x2 x3 x4 |
+ x1 := x2 := x3 := x4 := false.
+ p :=
+ [
+ [
+ [ ] ensure: [
+ [semaphore wait] ensure: [
+ x1 := true].
+ x2 := true]
+ ] ensure: [
+ x3 := true].
+ x4 := true.
+ ] newProcess.
+ p resume.
+ Processor yield.
+ "make sure p is blocked and none of the unwind blocks has finished yet"
+ self assert: p isBlocked.
+ self deny: x1 | x2 | x3 | x4.
+ "now terminate the process and make sure all unwind blocks have finished"
+ p terminate.
+ self assert: p isTerminated.
+ self assert: x1 & x2 & x3.
+ self deny: x4.!
Item was added:
+ ----- Method: ProcessUnwindTest>>testTerminateBlockedInNestedEnsure2 (in category 'tests') -----
+ testTerminateBlockedInNestedEnsure2
+ "Terminate blocked process.
+ Test all nested unwind blocks are correctly executed;
+ all unwind blocks halfway through their execution should be completed."
+
+ | p x1 x2 x3 x4 |
+ x1 := x2 := x3 := x4 := false.
+ p :=
+ [
+ [
+ [ ] ensure: [
+ [ ] ensure: [
+ semaphore wait.
+ x1 := true].
+ x2 := true]
+ ] ensure: [
+ x3 := true].
+ x4 := true.
+ ] newProcess.
+ p resume.
+ Processor yield.
+ "make sure p is blocked and none of the unwind blocks has finished yet"
+ self assert: p isBlocked.
+ self deny: x1 | x2 | x3 | x4.
+ "now terminate the process and make sure all unwind blocks have finished"
+ p terminate.
+ self assert: p isTerminated.
+ self assert: x1 & x2 & x3.
+ self deny: x4.!
Item was added:
+ ----- Method: ProcessUnwindTest>>testTerminateInNestedEnsureWithReturn1 (in category 'tests') -----
+ testTerminateInNestedEnsureWithReturn1
+ "Terminate suspended process.
+ Test all nested unwind blocks are correctly executed;
+ all unwind blocks halfway through their execution should be completed."
+
+ | p x1 x2 x3 x4 |
+ x1 := x2 := x3 := x4 := false.
+ p :=
+ [
+ [:return |
+ [
+ [ ] ensure: [
+ [Processor activeProcess suspend] ensure: [
+ x1 := true. return value].
+ x2 := true]
+ ] ensure: [
+ x3 := true].
+ x4 := true.
+ ] valueWithExit
+ ] newProcess.
+ p resume.
+ Processor yield.
+ "make sure p is suspended and none of the unwind blocks has finished yet"
+ self assert: p isSuspended.
+ self deny: x1 | x2 | x3 | x4.
+ "now terminate the process and make sure all unwind blocks have finished"
+ p terminate.
+ self assert: p isTerminated.
+ self assert: x1 & x3.
+ self deny: x2 & x4.!
Item was added:
+ ----- Method: ProcessUnwindTest>>testTerminateInNestedEnsureWithReturn2 (in category 'tests') -----
+ testTerminateInNestedEnsureWithReturn2
+ "Terminate suspended process.
+ Test all nested unwind blocks are correctly executed;
+ all unwind blocks halfway through their execution should be completed."
+
+ | p x1 x2 x3 x4 |
+ x1 := x2 := x3 := x4 := false.
+ p :=
+ [
+ [:return |
+ [
+ [ ] ensure: [
+ [] ensure: [
+ Processor activeProcess suspend.
+ x1 := true. return value].
+ x2 := true]
+ ] ensure: [
+ x3 := true].
+ x4 := true.
+ ] valueWithExit
+ ] newProcess.
+ p resume.
+ Processor yield.
+ "make sure p is suspended and none of the unwind blocks has finished yet"
+ self assert: p isSuspended.
+ self deny: x1 | x2 | x3 | x4.
+ "now terminate the process and make sure all unwind blocks have finished"
+ p terminate.
+ self assert: p isTerminated.
+ self assert: x1 & x3.
+ self deny: x2 & x4.!
Item was added:
+ ----- Method: ProcessUnwindTest>>testTerminateInNestedEnsureWithReturn3 (in category 'tests') -----
+ testTerminateInNestedEnsureWithReturn3
+ "Terminate suspended process.
+ Test all nested unwind blocks are correctly executed;
+ all unwind blocks halfway through their execution should be completed."
+
+ | p x1 x2 x3 x4 |
+ x1 := x2 := x3 := x4 := false.
+ p :=
+ [
+ [:return |
+ [
+ [ ] ensure: [
+ [Processor activeProcess suspend] ensure: [
+ x1 := true].
+ x2 := true. return value]
+ ] ensure: [
+ x3 := true].
+ x4 := true.
+ ] valueWithExit
+ ] newProcess.
+ p resume.
+ Processor yield.
+ "make sure p is suspended and none of the unwind blocks has finished yet"
+ self assert: p isSuspended.
+ self deny: x1 | x2 | x3 | x4.
+ "now terminate the process and make sure all unwind blocks have finished"
+ p terminate.
+ self assert: p isTerminated.
+ self assert: x1 & x2 & x3.
+ self deny: x4.!
Item was added:
+ ----- Method: ProcessUnwindTest>>testTerminateInNestedEnsureWithReturn4 (in category 'tests') -----
+ testTerminateInNestedEnsureWithReturn4
+ "Terminate suspended process.
+ Test all nested unwind blocks are correctly executed;
+ all unwind blocks halfway through their execution should be completed."
+
+ | p x1 x2 x3 x4 |
+ x1 := x2 := x3 := x4 := false.
+ p :=
+ [
+ [:return |
+ [
+ [ ] ensure: [
+ [] ensure: [
+ Processor activeProcess suspend.
+ x1 := true].
+ x2 := true. return value]
+ ] ensure: [
+ x3 := true].
+ x4 := true.
+ ] valueWithExit
+ ] newProcess.
+ p resume.
+ Processor yield.
+ "make sure p is suspended and none of the unwind blocks has finished yet"
+ self assert: p isSuspended.
+ self deny: x1 | x2 | x3 | x4.
+ "now terminate the process and make sure all unwind blocks have finished"
+ p terminate.
+ self assert: p isTerminated.
+ self assert: x1 & x2 & x3.
+ self deny: x4.!
Item was added:
+ ----- Method: ProcessUnwindTest>>testTerminateInNestedEnsureWithReturn5 (in category 'tests') -----
+ testTerminateInNestedEnsureWithReturn5
+ "Terminate suspended process.
+ Test all nested unwind blocks are correctly executed;
+ all unwind blocks halfway through their execution should be completed."
+
+ | p x1 x2 x3 x4 |
+ x1 := x2 := x3 := x4 := false.
+ p :=
+ [
+ [:return |
+ [
+ [ ] ensure: [
+ [Processor activeProcess suspend] ensure: [
+ x1 := true].
+ x2 := true]
+ ] ensure: [
+ x3 := true. return value].
+ x4 := true.
+ ] valueWithExit
+ ] newProcess.
+ p resume.
+ Processor yield.
+ "make sure p is suspended and none of the unwind blocks has finished yet"
+ self assert: p isSuspended.
+ self deny: x1 | x2 | x3 | x4.
+ "now terminate the process and make sure all unwind blocks have finished"
+ p terminate.
+ self assert: p isTerminated.
+ self assert: x1 & x2 & x3.
+ self deny: x4.!
Item was added:
+ ----- Method: ProcessUnwindTest>>testTerminateInNestedEnsureWithReturn6 (in category 'tests') -----
+ testTerminateInNestedEnsureWithReturn6
+ "Terminate suspended process.
+ Test all nested unwind blocks are correctly executed;
+ all unwind blocks halfway through their execution should be completed."
+
+ | p x1 x2 x3 x4 |
+ x1 := x2 := x3 := x4 := false.
+ p :=
+ [
+ [:return |
+ [
+ [ ] ensure: [
+ [] ensure: [
+ Processor activeProcess suspend.
+ x1 := true].
+ x2 := true]
+ ] ensure: [
+ x3 := true. return value].
+ x4 := true.
+ ] valueWithExit
+ ] newProcess.
+ p resume.
+ Processor yield.
+ "make sure p is suspended and none of the unwind blocks has finished yet"
+ self assert: p isSuspended.
+ self deny: x1 | x2 | x3 | x4.
+ "now terminate the process and make sure all unwind blocks have finished"
+ p terminate.
+ self assert: p isTerminated.
+ self assert: x1 & x2 & x3.
+ self deny: x4.!
Item was added:
+ ----- Method: ProcessUnwindTest>>testTerminateInNestedEnsureWithReturn7 (in category 'tests') -----
+ testTerminateInNestedEnsureWithReturn7
+ "Terminate suspended process.
+ Test all nested unwind blocks are correctly executed;
+ all unwind blocks halfway through their execution should be completed."
+
+ | p x1 x2 x3 x4 |
+ x1 := x2 := x3 := x4 := false.
+ p :=
+ [
+ [:return |
+ [
+ [ ] ensure: [
+ [Processor activeProcess suspend] ensure: [
+ x1 := true].
+ x2 := true]
+ ] ensure: [
+ x3 := true].
+ x4 := true. return value.
+ ] valueWithExit
+ ] newProcess.
+ p resume.
+ Processor yield.
+ "make sure p is suspended and none of the unwind blocks has finished yet"
+ self assert: p isSuspended.
+ self deny: x1 | x2 | x3 | x4.
+ "now terminate the process and make sure all unwind blocks have finished"
+ p terminate.
+ self assert: p isTerminated.
+ self assert: x1 & x2 & x3.
+ self deny: x4.!
Item was added:
+ ----- Method: ProcessUnwindTest>>testTerminateInNestedEnsureWithReturn8 (in category 'tests') -----
+ testTerminateInNestedEnsureWithReturn8
+ "Terminate suspended process.
+ Test all nested unwind blocks are correctly executed;
+ all unwind blocks halfway through their execution should be completed."
+
+ | p x1 x2 x3 x4 |
+ x1 := x2 := x3 := x4 := false.
+ p :=
+ [
+ [:return |
+ [
+ [ ] ensure: [
+ [] ensure: [
+ Processor activeProcess suspend.
+ x1 := true].
+ x2 := true]
+ ] ensure: [
+ x3 := true].
+ x4 := true. return value.
+ ] valueWithExit
+ ] newProcess.
+ p resume.
+ Processor yield.
+ "make sure p is suspended and none of the unwind blocks has finished yet"
+ self assert: p isSuspended.
+ self deny: x1 | x2 | x3 | x4.
+ "now terminate the process and make sure all unwind blocks have finished"
+ p terminate.
+ self assert: p isTerminated.
+ self assert: x1 & x2 & x3.
+ self deny: x4.!
Item was added:
+ ----- Method: ProcessUnwindTest>>testTerminateNestedEnsureWithReturn1 (in category 'tests') -----
+ testTerminateNestedEnsureWithReturn1
+ "Terminate suspended process.
+ Test all nested unwind blocks are correctly executed;
+ all unwind blocks halfway through their execution should be completed."
+
+ "While testTerminateInNestedEnsureWithReturn1 to 8 start unwinding
+ from inside a halfways through unwind block, this test (and the next) start
+ the unwind from outside any ensure argument (aka unwind) block, testing
+ the second half of the #unwindTo:safely: method."
+
+ | p x1 x2 x3 x4 x5 |
+ x1 := x2 := x3 := x4 := x5 := false.
+ p :=
+ [
+ [:return |
+ [ Processor activeProcess suspend.
+ [ ] ensure: [
+ [ ] ensure: [
+ x1 := true].
+ x2 := true]
+ ] ensure: [
+ return value.
+ x3 := true].
+ x4 := true.
+ ] valueWithExit.
+ x5 := true.
+ ] newProcess.
+ p resume.
+ Processor yield.
+ "make sure p is suspended and none of the unwind blocks has finished yet"
+ self assert: p isSuspended.
+ self deny: x1 | x2 | x3 | x4 | x5.
+ "now terminate the process and make sure all unwind blocks have finished"
+ p terminate.
+ self assert: p isTerminated.
+ self deny: x1 & x2 & x3 & x4 & x5!
Item was added:
+ ----- Method: ProcessUnwindTest>>testTerminateNestedEnsureWithReturn2 (in category 'tests') -----
+ testTerminateNestedEnsureWithReturn2
+ "Terminate suspended process.
+ Test all nested unwind blocks are correctly executed;
+ all unwind blocks halfway through their execution should be completed."
+
+ | p x1 x2 x3 x4 x5 |
+ x1 := x2 := x3 := x4 := x5 := false.
+ p :=
+ [
+ [:return |
+ [
+ [Processor activeProcess suspend] ensure: [
+ [ ] ensure: [
+ x1 := true].
+ return value.
+ x2 := true]
+ ] ensure: [
+ x3 := true].
+ x4 := true.
+ ] valueWithExit.
+ x5 := true.
+ ] newProcess.
+ p resume.
+ Processor yield.
+ "make sure p is suspended and none of the unwind blocks has finished yet"
+ self assert: p isSuspended.
+ self deny: x1 | x2 | x3 | x4 | x5.
+ "now terminate the process and make sure all unwind blocks have finished"
+ p terminate.
+ self assert: p isTerminated.
+ self deny: x1 & x2 & x3 & x4 & x5!
Item was added:
+ ----- Method: ProcessUnwindTest>>testTerminateRunnableInNestedEnsure1 (in category 'tests') -----
+ testTerminateRunnableInNestedEnsure1
+ "Terminate runnable process.
+ Test all nested unwind blocks are correctly executed;
+ all unwind blocks halfway through their execution should be completed."
+
+ | p x1 x2 x3 x4 |
+ x1 := x2 := x3 := x4 := false.
+ p :=
+ [
+ [
+ [ ] ensure: [
+ [Processor yield] ensure: [
+ x1 := true].
+ x2 := true]
+ ] ensure: [
+ x3 := true].
+ x4 := true.
+ ] newProcess.
+ p resume.
+ Processor yield.
+ "make sure p is runnable and none of the unwind blocks has finished yet"
+ self assert: p isRunnable.
+ self deny: x1 | x2 | x3 | x4.
+ "now terminate the process and make sure all unwind blocks have finished"
+ p terminate.
+ self assert: p isTerminated.
+ self assert: x1 & x2 & x3.
+ self deny: x4.!
Item was added:
+ ----- Method: ProcessUnwindTest>>testTerminateRunnableInNestedEnsure2 (in category 'tests') -----
+ testTerminateRunnableInNestedEnsure2
+ "Terminate runnable process.
+ Test all nested unwind blocks are correctly executed;
+ all unwind blocks halfway through their execution should be completed."
+
+ | p x1 x2 x3 x4 |
+ x1 := x2 := x3 := x4 := false.
+ p :=
+ [
+ [
+ [ ] ensure: [
+ [ ] ensure: [
+ Processor yield.
+ x1 := true].
+ x2 := true]
+ ] ensure: [
+ x3 := true].
+ x4 := true.
+ ] newProcess.
+ p resume.
+ Processor yield.
+ "make sure p is runnable and none of the unwind blocks has finished yet"
+ self assert: p isRunnable.
+ self deny: x1 | x2 | x3 | x4.
+ "now terminate the process and make sure all unwind blocks have finished"
+ p terminate.
+ self assert: p isTerminated.
+ self assert: x1 & x2 & x3.
+ self deny: x4.!
Item was added:
+ ----- Method: ProcessUnwindTest>>testTerminateSuspendedInNestedEnsure1 (in category 'tests') -----
+ testTerminateSuspendedInNestedEnsure1
+ "Terminate suspended process.
+ Test all nested unwind blocks are correctly executed;
+ all unwind blocks halfway through their execution should be completed."
+
+ | p x1 x2 x3 x4 |
+ x1 := x2 := x3 := x4 := false.
+ p :=
+ [
+ [
+ [ ] ensure: [
+ [Processor activeProcess suspend] ensure: [
+ x1 := true].
+ x2 := true]
+ ] ensure: [
+ x3 := true].
+ x4 := true.
+ ] newProcess.
+ p resume.
+ Processor yield.
+ "make sure p is suspended and none of the unwind blocks has finished yet"
+ self assert: p isSuspended.
+ self deny: x1 | x2 | x3 | x4.
+ "now terminate the process and make sure all unwind blocks have finished"
+ p terminate.
+ self assert: p isTerminated.
+ self assert: x1 & x2 & x3.
+ self deny: x4.!
Item was added:
+ ----- Method: ProcessUnwindTest>>testTerminateSuspendedInNestedEnsure2 (in category 'tests') -----
+ testTerminateSuspendedInNestedEnsure2
+ "Terminate suspended process.
+ Test all nested unwind blocks are correctly executed;
+ all unwind blocks halfway through their execution should be completed."
+
+ | p x1 x2 x3 x4 |
+ x1 := x2 := x3 := x4 := false.
+ p :=
+ [
+ [
+ [ ] ensure: [
+ [ ] ensure: [
+ Processor activeProcess suspend.
+ x1 := true].
+ x2 := true]
+ ] ensure: [
+ x3 := true].
+ x4 := true.
+ ] newProcess.
+ p resume.
+ Processor yield.
+ "make sure p is suspended and none of the unwind blocks has finished yet"
+ self assert: p isSuspended.
+ self deny: x1 | x2 | x3 | x4.
+ "now terminate the process and make sure all unwind blocks have finished"
+ p terminate.
+ self assert: p isTerminated.
+ self assert: x1 & x2 & x3.
+ self deny: x4.!
Item was added:
+ ----- Method: Promise>>unsynchronized (in category '*KernelTests-Processes') -----
+ unsynchronized
+ "This is useful for tests, because it's quite easy otherwise to deadlock your image. It is a DISASTER to use this in production code!!"
+ mutex := NullMutex new.!
Item was added:
+ TestCase subclass: #PromiseTest
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'KernelTests-Processes'!
Item was added:
+ ----- Method: PromiseTest>>testAnErrorInOnRejectedRejectsPromise (in category 'tests - monad') -----
+ testAnErrorInOnRejectedRejectsPromise
+ "https://promisesaplus.com section 2.2.7.2"
+ | p q error |
+ p := Promise new.
+ q := p ifRejected: [:e | (error := KeyNotFound new) signal].
+ p rejectWith: 1.
+ self assert: p isRejected description: 'Original Promise not rejected'.
+ self assert: q isRejected description: 'Broken Promise not rejected'.
+ self assert: p error = 1.
+ self assert: q error == error.!
Item was added:
+ ----- Method: PromiseTest>>testAnErrorInThenRejectsPromise (in category 'tests - monad') -----
+ testAnErrorInThenRejectsPromise
+ "https://promisesaplus.com section 2.2.7.2"
+ | p q error |
+ p := Promise new.
+ q := p then: [:v | (error := KeyNotFound new) signal].
+ p resolveWith: 1.
+ self deny: p isRejected description: 'Original Promise rejected'.
+ self assert: q isRejected description: 'Broken Promise not rejected'.
+ self assert: p value = 1.
+ self assert: q error == error.!
Item was added:
+ ----- Method: PromiseTest>>testCanRejectPromise (in category 'tests - monad') -----
+ testCanRejectPromise
+ | p |
+ p := Promise new.
+ p rejectWith: Error new.!
Item was added:
+ ----- Method: PromiseTest>>testCannotRejectFulfilledPromise (in category 'tests - monad') -----
+ testCannotRejectFulfilledPromise
+ | p |
+ p := Promise unit: 1.
+ p rejectWith: Error new.
+ self assert: p isResolved.
+ self assert: 1 equals: p value.
+ !
Item was added:
+ ----- Method: PromiseTest>>testCannotResolveaRejectedPromise (in category 'tests - monad') -----
+ testCannotResolveaRejectedPromise
+ | p e |
+ p := Promise new.
+ e := Error new.
+ p rejectWith: e.
+ p resolveWith: 1.
+ self assert: p isRejected.
+ self assert: p error == e.
+ !
Item was added:
+ ----- Method: PromiseTest>>testChainedResolvers (in category 'tests') -----
+ testChainedResolvers
+ | promise1 promise2 result |
+ promise1 := Promise new.
+ promise2 := Promise new.
+ promise1 whenResolved: [:bool | promise2 resolveWith: bool not].
+ promise2 whenResolved: [:bool | result := bool].
+ promise1 resolveWith: false.
+ self should: [result].!
Item was added:
+ ----- Method: PromiseTest>>testCollapsesChainsOfPromises (in category 'tests - monad') -----
+ testCollapsesChainsOfPromises
+ "The monadic bind operator has signature (m a -> (a -> m b) -> m b): that is, in our setting,
+ the block given to `then:` is expected to return a *Promise* of a value, not a value directly.
+ It is convenient to accept non-promise values and automatically lift them into the monad,
+ but we must also ensure we treat the case where a `then:`-block yields a Promise correctly."
+ | p q r |
+ p := Promise new.
+ q := p then: [:v | Promise unit: v * 2].
+ r := q then: [:v | Promise unit: v + 1].
+ p resolveWith: 4.
+ self assert: 4 * 2 equals: q value.
+ self assert: (4 * 2 + 1) equals: r value.!
Item was added:
+ ----- Method: PromiseTest>>testFirstResolutionWins (in category 'tests - monad') -----
+ testFirstResolutionWins
+ | p |
+ p := Promise new.
+ p resolveWith: 1.
+ p resolveWith: 2.
+ self assert: p isResolved.
+ self assert: p value == 1.
+ !
Item was added:
+ ----- Method: PromiseTest>>testFulfillWithError (in category 'tests') -----
+ testFulfillWithError
+ | p |
+ p := Promise new.
+ p fulfillWith: [ 1 / 0 ] passErrors: false.
+ self assert: p isRejected.
+ self assert: ZeroDivide equals: p error class.!
Item was added:
+ ----- Method: PromiseTest>>testFulfillWithHaltAndResult (in category 'tests') -----
+ testFulfillWithHaltAndResult
+ | p |
+ p := Promise new.
+ [
+ p fulfillWith: [ self halt. 3 + 4 ]
+ ] on: Halt do: [:ex | ex resume].
+ self assert: p isResolved.
+ self assert: 7 equals: p value.!
Item was added:
+ ----- Method: PromiseTest>>testFulfillWithResult (in category 'tests') -----
+ testFulfillWithResult
+ | p |
+ p := Promise new.
+ p fulfillWith: [ 3 + 4 ].
+ self assert: p isResolved.
+ self assert: 7 equals: p value.!
Item was added:
+ ----- Method: PromiseTest>>testFutureRejectionInvisibleError (in category 'tests - future') -----
+ testFutureRejectionInvisibleError
+ | p |
+ p := 1 future / 0.
+ p whenRejected: []. "Installing a rejection handler is enough to cause the exception to be swallowed."
+ self assert: (self waitUntil: [p isRejected] orCycleCount: 100).
+ self assert: p isRejected.
+ self assert: ZeroDivide equals: p error class.!
Item was added:
+ ----- Method: PromiseTest>>testFutureRejectionVisibleError (in category 'tests - future') -----
+ testFutureRejectionVisibleError
+ | p |
+ p := 1 future / 0.
+ [
+ self assert: (self waitUntil: [p isRejected] orCycleCount: 100)
+ ] on: ZeroDivide do: [:ex | "Fall through." ].
+ self assert: p isRejected.
+ self assert: ZeroDivide equals: p error class.!
Item was added:
+ ----- Method: PromiseTest>>testFutureResolution (in category 'tests - future') -----
+ testFutureResolution
+ | p |
+ p := 3 future + 4.
+ self assert: (self waitUntil: [p isResolved] orCycleCount: 100).
+ self assert: p isResolved.
+ self assert: 7 equals: p value.!
Item was added:
+ ----- Method: PromiseTest>>testMultipleResolvers (in category 'tests') -----
+ testMultipleResolvers
+ | promise sum |
+ sum := 0.
+ promise := Promise new.
+ 5 timesRepeat: [
+ promise whenResolved: [:val | sum := sum + val].
+ ].
+ promise resolveWith: 5.
+ self should: [sum = 25].
+ !
Item was added:
+ ----- Method: PromiseTest>>testNilErrBlockPropagation (in category 'tests - monad') -----
+ testNilErrBlockPropagation
+ "https://promisesaplus.com section 2.2.7.4"
+ | p q |
+ p := Promise new.
+ q := p then: [:v | self error: 'Shouldn''t call resolvedBlock'] ifRejected: nil.
+ p rejectWith: 1.
+ self assert: p isRejected.
+ self assert: q isRejected.
+ self assert: p error equals: 1.
+ self assert: q error equals: 1.!
Item was added:
+ ----- Method: PromiseTest>>testNilResolvedBlockPropagation (in category 'tests - monad') -----
+ testNilResolvedBlockPropagation
+ "https://promisesaplus.com section 2.2.7.3"
+ | p q |
+ p := Promise new.
+ q := p then: nil ifRejected: [:e | self error: 'Shouldn''t call errBlock'].
+ p resolveWith: 1.
+ self assert: p isResolved.
+ self assert: q isResolved.
+ self assert: p value equals: 1.
+ self assert: q value equals: 1.!
Item was added:
+ ----- Method: PromiseTest>>testRejectWithInvokesErrorHandlers (in category 'tests - monad') -----
+ testRejectWithInvokesErrorHandlers
+ | p error returnedError |
+ returnedError := nil.
+ error := KeyNotFound new.
+ p := Promise ifRejected: [:e | returnedError := e].
+ p rejectWith: error.
+ self assert: returnedError notNil description: 'Error block did not run.'.
+ self assert: error equals: returnedError description: 'Error not passed into block'.
+ self assert: error equals: p error description: 'Promise didn''t store error'.!
Item was added:
+ ----- Method: PromiseTest>>testSingleResolver (in category 'tests') -----
+ testSingleResolver
+ | promise sum |
+ sum := 0.
+ promise := Promise new.
+ promise whenResolved: [:val | sum := sum + val].
+ promise resolveWith: 5.
+ self assert: 5 equals: sum.
+ !
Item was added:
+ ----- Method: PromiseTest>>testThenPermitsChainingOfPromises (in category 'tests - monad') -----
+ testThenPermitsChainingOfPromises
+ | p q r |
+ p := Promise new.
+ q := p then: [:v | v * 2].
+ r := q then: [:v | v + 1].
+ p resolveWith: 4.
+ self assert: 4 * 2 equals: q value.
+ self assert: (4 * 2 + 1) equals: r value.!
Item was added:
+ ----- Method: PromiseTest>>testThenReturnsaPromise (in category 'tests - monad') -----
+ testThenReturnsaPromise
+ | p |
+ p := Promise new then: [:v | v * 2].
+ self assert: Promise equals: p class.!
Item was added:
+ ----- Method: PromiseTest>>testTimeout (in category 'tests') -----
+ testTimeout
+ | promise |
+ promise := Promise new.
+ self shouldnt: [promise waitTimeoutMSecs: 1].
+ self shouldnt: [promise isResolved].
+ self shouldnt: [promise isRejected].
+ promise resolveWith: 45.
+ self should: [promise waitTimeoutMSecs: 1].
+ self should: [promise isResolved].
+ self shouldnt: [promise isRejected].!
Item was added:
+ ----- Method: PromiseTest>>testTimeoutRejected (in category 'tests') -----
+ testTimeoutRejected
+ | promise |
+ promise := Promise new.
+ self shouldnt: [promise waitTimeoutMSecs: 1].
+ self shouldnt: [promise isResolved].
+ self shouldnt: [promise isRejected].
+ promise rejectWith: 45.
+ self shouldnt: [promise waitTimeoutMSecs: 1].
+ self shouldnt: [promise isResolved].
+ self should: [promise isRejected].!
Item was added:
+ ----- Method: PromiseTest>>testUnitReturnsaPromise (in category 'tests - monad') -----
+ testUnitReturnsaPromise
+ | p |
+ p := Promise unit: 1.
+ self assert: Promise equals: p class.
+ self assert: p isResolved.!
Item was added:
+ ----- Method: PromiseTest>>testWaitForRejection (in category 'tests - monad') -----
+ testWaitForRejection
+ | p |
+ p := Promise new.
+ [ (Delay forMilliseconds: 1) wait. p rejectWith: Error new ] fork.
+ self should: [ p wait ] raise: BrokenPromise.!
Item was added:
+ ----- Method: PromiseTest>>testWaitForResolution (in category 'tests - monad') -----
+ testWaitForResolution
+ | p |
+ p := Promise new.
+ [ (Delay forMilliseconds: 1) wait. p resolveWith: #ok ] fork.
+ self assert: [ p wait = #ok ]!
Item was added:
+ ----- Method: PromiseTest>>testWaitRejectionYieldsCorrectBrokenPromise (in category 'tests - monad') -----
+ testWaitRejectionYieldsCorrectBrokenPromise
+ | p |
+ p := Promise new.
+ [ (Delay forMilliseconds: 1) wait. p rejectWith: Error new ] fork.
+ [ p wait ] on: BrokenPromise do: [ :bp | ^ self assert: [ bp promise == p ] ].
+ self fail: 'Should not reach this point'!
Item was added:
+ ----- Method: PromiseTest>>testifRejectedDoesNotRunBlockIfPromiseResolves (in category 'tests - monad') -----
+ testifRejectedDoesNotRunBlockIfPromiseResolves
+ | p q error |
+ error := nil.
+ p := Promise new.
+ q := p ifRejected: [:e | error := e].
+ p resolveWith: 1.
+ self deny: q isRejected.
+ self assert: nil equals: error.!
Item was added:
+ ----- Method: PromiseTest>>testifRejectedRunsBlockIfPromiseFails (in category 'tests - monad') -----
+ testifRejectedRunsBlockIfPromiseFails
+ "https://promisesaplus.com section 2.2.7.1"
+ | p q error |
+ error := nil.
+ p := Promise new.
+ q := p ifRejected: [:e | error := e "N.B. returns a value, does not signal an Exception"].
+ p rejectWith: KeyNotFound new.
+ self assert: q isResolved.
+ self assert: KeyNotFound equals: error class.
+ self assert: q value == error.!
Item was added:
+ ----- Method: PromiseTest>>waitUntil:orCycleCount: (in category 'private') -----
+ waitUntil: aBlock orCycleCount: anInteger
+ "This is a gross hack that depends on running the tests in Morphic.
+ We simply repeatedly do a cycle of the interaction loop, which happens
+ to also be the way that the queue of pending futures gets serviced."
+ | counter |
+ counter := 0.
+ [
+ aBlock value ifTrue: [^ true].
+ Project current world doOneSubCycle.
+ counter := counter + 1.
+ counter >= anInteger ifTrue: [^ false].
+ ] repeat!
Item was added:
+ ClassTestCase subclass: #ProtoObjectTest
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'KernelTests-Objects'!
+
+ !ProtoObjectTest commentStamp: '<historical>' prior: 0!
+ This is the unit test for the class ProtoObject. Unit tests are a good way to exercise the functionality of your system in a repeatable and automatic manner. They are therefore recommended if you plan to release anything. For more information, see:
+ - http://www.c2.com/cgi/wiki?UnitTest
+ - http://minnow.cc.gatech.edu/squeak/1547
+ - the sunit class category!
Item was added:
+ ----- Method: ProtoObjectTest>>testFlag (in category 'tests - testing') -----
+ testFlag
+ "This should never throw an exception."
+ ProtoObject new flag: #hallo.!
Item was added:
+ ----- Method: ProtoObjectTest>>testIfNil (in category 'tests - testing') -----
+ testIfNil
+
+ | object block |
+ object := ProtoObject new.
+ self shouldnt: [ object ifNil: [ self halt ]] raise: Halt.
+ self assert: (object ifNil: [ nil ]) == object.
+ "Now the same without inlining."
+ block := [ self halt ].
+ self shouldnt: [ object ifNil: block ] raise: Halt.
+ block := [ nil ].
+ self assert: (object ifNil: block) == object.
+
+ !
Item was added:
+ ----- Method: ProtoObjectTest>>testIfNilIfNotNil (in category 'tests - testing') -----
+ testIfNilIfNotNil
+
+ | object returnValue block |
+ object := ProtoObject new.
+ returnValue := Object new.
+ self should: [ object ifNil: [ self error ] ifNotNil: [ self halt ] ] raise: Halt.
+ self should: [ object ifNil: [ self error ] ifNotNil: [ :o | self halt ] ] raise: Halt.
+ self assert: (object ifNil: [ false ] ifNotNil: [ :o | o == object ]).
+ self assert: (object ifNil: [ nil ] ifNotNil: [ returnValue ]) == returnValue.
+ self assert: (object ifNil: [ nil ] ifNotNil: [ :o | returnValue ]) == returnValue.
+ "Now the same without inlining."
+ block := [ self halt ].
+ self should: [ object ifNil: [ self error ] ifNotNil: block ] raise: Halt.
+ block := [ :o | self halt ].
+ self should: [ object ifNil: [ self error ] ifNotNil: block ] raise: Halt.
+ block := [ :o | o == object ].
+ self assert: (object ifNil: [ false ] ifNotNil: block).
+ block := [ returnValue ].
+ self assert: (object ifNil: [ nil ] ifNotNil: block) = returnValue.
+ block := [ :o | returnValue ].
+ self assert: (object ifNil: [ nil ] ifNotNil: block) = returnValue!
Item was added:
+ ----- Method: ProtoObjectTest>>testIfNotNil (in category 'tests - testing') -----
+ testIfNotNil
+
+ | object returnValue block |
+ object := ProtoObject new.
+ returnValue := Object new.
+ self should: [ object ifNotNil: [ self halt ] ] raise: Halt.
+ self should: [ object ifNotNil: [ :o | self halt ] ] raise: Halt.
+ self assert: (object ifNotNil: [ :o | o == object ]).
+ self assert: (object ifNotNil: [ returnValue ]) == returnValue.
+ self assert: (object ifNotNil: [ :o | returnValue ]) == returnValue.
+ "Now the same without inlining."
+ block := [ self halt ].
+ self should: [ object ifNotNil: block ] raise: Halt.
+ block := [ :o | self halt ].
+ self should: [ object ifNotNil: block ] raise: Halt.
+ block := [ :o | o == object ].
+ self assert: (object ifNotNil: block).
+ block := [ returnValue ].
+ self assert: (object ifNotNil: block) = returnValue.
+ block := [ :o | returnValue ].
+ self assert: (object ifNotNil: block) = returnValue!
Item was added:
+ ----- Method: ProtoObjectTest>>testIfNotNilIfNil (in category 'tests - testing') -----
+ testIfNotNilIfNil
+
+ | object returnValue block |
+ object := ProtoObject new.
+ returnValue := Object new.
+ self should: [ object ifNotNil: [ self halt ] ifNil: [ self error ] ] raise: Halt.
+ self should: [ object ifNotNil: [ :o | self halt ] ifNil: [ self error ] ] raise: Halt.
+ self assert: (object ifNotNil: [ :o | o == object ] ifNil: [ false ]).
+ self assert: (object ifNotNil: [ returnValue ] ifNil: [ false ]) == returnValue.
+ self assert: (object ifNotNil: [ :o | returnValue ] ifNil: [ false ]) == returnValue.
+ "Now the same without inlining."
+ block := [ self halt ].
+ self should: [ object ifNotNil: block ifNil: [ self error ] ] raise: Halt.
+ block := [ :o | self halt ].
+ self should: [ object ifNotNil: block ifNil: [ self error ] ] raise: Halt.
+ block := [ :o | o == object ].
+ self assert: (object ifNotNil: block ifNil: [ false ]).
+ block := [ returnValue ].
+ self assert: (object ifNotNil: block ifNil: [ false ]) == returnValue.
+ block := [ :o | returnValue ].
+ self assert: (object ifNotNil: block ifNil: [ false ]) == returnValue!
Item was added:
+ ----- Method: ProtoObjectTest>>testIsNil (in category 'tests - testing') -----
+ testIsNil
+
+ self deny: ProtoObject new isNil!
Item was added:
+ ClassTestCase subclass: #RandomTest
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'KernelTests-Numbers'!
+
+ !RandomTest commentStamp: 'ul 2/27/2015 12:36' prior: 0!
+ I test the random number generator implemented by Random. Whenever its implementation changes, I'll have to be updated to match the new implementation.
+ Instead of adding methods to Random to access the internal state, I use reflection (#instVarNamed:).!
Item was added:
+ ----- Method: RandomTest>>assertFirstValuesAre:finalStatesAre:withSeed: (in category 'helpers') -----
+ assertFirstValuesAre: expectedValues finalStatesAre: expectedFinalStates withSeed: seed
+ "Verify that the first generated numbers with the given seed are the same as in expectedValues. Also check that the state of the generator matches expectedFinalStates after the last number was generated."
+
+ | random states |
+ random := Random seed: seed.
+ expectedValues do: [ :each |
+ self assert: each equals: random nextValue ].
+ states := random instVarNamed: #states.
+ self
+ assert: expectedFinalStates
+ equals: states.
+ self
+ assert: expectedValues size \\ states size + 1
+ equals: (random instVarNamed: #index)
+ !
Item was added:
+ ----- Method: RandomTest>>assertInitialStateIs:withSeed: (in category 'helpers') -----
+ assertInitialStateIs: expectedInitialState withSeed: seed
+ "Verify that the initial values of the states variable match the given values for the given seed."
+
+ | random |
+ random := Random basicNew.
+ random initializeStatesWith: seed.
+ self
+ assert: expectedInitialState
+ equals: (random instVarNamed: #states)!
Item was added:
+ ----- Method: RandomTest>>testExpectedValuesAndFinalStates (in category 'tests') -----
+ testExpectedValuesAndFinalStates
+ "The numbers here were generated with a modified version of dcmt. http://www.math.sci.hiroshima-u.ac.jp/~m-mat/MT/DC/dc.html ."
+
+ self
+ assertFirstValuesAre: #(791793822 321208675 533452018 916714539 223319369 1012473888 519521402 691227136 655932023 762631845 263546831 924338090 559722895 178321509 916222900 335844726 321863848 695515717 112692096 738657692 395570358 340088260 887167633 1009518587 243735024 275847384 769544812 100974653 906270421 342913954 97518663 1067659127 901766500 960849649 913009938 458031838 820147509 822604220 642364166 55274442 357680755 991571674 13914935 857799117 66453038 971120160 398083276 373288317 684827868 674731247)
+ finalStatesAre: #(635250399 668117719 848992573 251038832 98606638 713392708 276649431 1832634 607491210 416789795 914892960 325580685 799306927 249385527 318375379 748373901 904063250 170318087)
+ withSeed: 1.
+ self
+ assertFirstValuesAre: #(687305094 702568716 681618148 361497334 56139518 745675778 952599938 953942824 73974730 564274490 1060767469 886737457 1039805902 722013528 64171798 764123925 432128359 274234212 668956319 716744939 309797615 780783289 301460951 535739904 224961890 114117836 193753287 1031006106 336541050 154594855 533038119 881775175 158057306 77776036 493306911 605604566 1048063493 584525301 1022642202 864508130 413151089 57876224 191759976 1008496211 868455235 165567279 536395892 455845625 913969488 1031304391)
+ finalStatesAre: #(1042729719 217432604 1069856876 162320335 202162581 218490242 297015026 68487684 898813855 71972347 874350418 438504195 940031925 17654607 153301097 316080480 107798001 361001990)
+ withSeed: 16rFFFFFFFF.
+ self
+ assertFirstValuesAre: #(508754231 328289850 498391260 573176063 453719461 935895611 435707860 570185280 1062441194 1069509491 70217464 149146838 858549983 755358687 617299553 468867114 401402744 731268746 224918805 447062722 290392391 137004397 311801760 320322691 258212560 536704035 950550708 555923010 982471103 981495169 294632011 175884018 503667308 154136572 291636083 607893878 617073742 310910219 169050729 996306290 695080363 165230559 945376911 612064901 884146961 873827275 491094423 292583589 257673098 606271793)
+ finalStatesAre: #(650871495 911703262 863344052 176605894 655312644 446078144 11879373 102580040 573515471 123917283 104253098 1042658978 222575135 487008331 309368251 253108077 333913878 249510222)
+ withSeed: 36rSqueak!
Item was added:
+ ----- Method: RandomTest>>testInitialStates (in category 'tests') -----
+ testInitialStates
+ "The numbers here were generated with a modified version of dcmt. http://www.math.sci.hiroshima-u.ac.jp/~m-mat/MT/DC/dc.html ."
+
+ self
+ assertInitialStateIs: #(1 738691430 491934885 961690497 64984499 171432612 446538473 482277108 305861910 321062125 1021787430 989754889 231135540 639897334 889001601 577497588 377121465 745575081)
+ withSeed: 1.
+ self
+ assertInitialStateIs: #(1073741823 266459757 720566430 20126452 56152695 937338158 159797905 1043117473 406704525 811309125 915542797 222137334 82370074 761921770 934153467 57368396 980436236 43660082)
+ withSeed: 16rFFFFFFFF.
+ self
+ assertInitialStateIs: #(664399324 1024531762 951500119 549828849 614037886 888424945 697907173 598650154 380912181 737669773 997432646 1017772356 307774789 986202438 417447953 558454367 229264988 682340290)
+ withSeed: 36rSqueak.
+
+ !
Item was added:
+ ----- Method: RandomTest>>testNext (in category 'tests') -----
+ testNext
+ "Generate some float values, and see if they are in the [0,1) interval. Also check that the smallest and the largest values are small/large enough."
+
+ | random min max |
+ min := Float infinity.
+ max := Float negativeInfinity.
+ random := Random seed: 112629.
+ 100000 timesRepeat: [
+ | next |
+ next := random next.
+ next < min ifTrue: [ min := next ].
+ next > max ifTrue: [ max := next ].
+ self assert: next >= 0.0 description: [ 'Generated value ', next asString, ' should be non-negative.' ].
+ self assert: next < 1.0 description: [ 'Generated value ', next asString, ' should be less than 1.0.' ] ].
+ self assert: max > 0.9999 description: 'The largest generated value should be greater than 0.9999.'.
+ self assert: min < 0.0001 description: 'The smallest generated value should be less than 0.0001.'!
Item was added:
+ ----- Method: RandomTest>>testNextInt (in category 'tests') -----
+ testNextInt
+ "Generate many integer values from a small range, and see if they are distributed equally on that range. This is not an exact test, but it's good enough to find obvious errors in the generator."
+
+ | random |
+ random := Random seed: 1234567812345678.
+ #(
+ 2 100000
+ 3 200000
+ 10 300000
+ 100 400000
+ ) groupsDo: [ :bucketCount :runs |
+ | buckets |
+ buckets := Array new: bucketCount withAll: 0.
+ runs timesRepeat: [
+ | next |
+ next := random nextInt: bucketCount.
+ buckets at: next put: (buckets at: next) + 1 ].
+ buckets do: [ :each |
+ self assert: (each / (runs / bucketCount) between: 0.95 and: 1.05) ] ]!
Item was added:
+ ----- Method: RandomTest>>testNextIntLarge (in category 'tests') -----
+ testNextIntLarge
+ "Generate many 1281-bit integers and see if their bits are equally distributed. This is not an exact test, but it's good enough to find obvious errors in the generator."
+
+ <timeout: 15>
+ | random bits bitCounts maxValue runs |
+ random := Random seed: 1234567812345678.
+ bits := 1281.
+ bitCounts := Array new: bits withAll: 0.
+ maxValue := 1 << bits.
+ runs := 20000.
+ runs timesRepeat: [
+ | value |
+ value := (random nextInt: maxValue) - 1.
+ 1 to: bits do: [ :bitIndex |
+ bitCounts at: bitIndex put: (bitCounts at: bitIndex) + (value bitAt: bitIndex) ] ].
+ bitCounts do: [ :each |
+ self assert: ((each / (runs / 2)) between: 0.95 and: 1.05) ]
+ !
Item was added:
+ ----- Method: RandomTest>>testRoll (in category 'tests') -----
+ testRoll
+
+ | random result |
+ random := Random seed: 14482.
+
+ "Roll the default die (d6)"
+ 100 timesRepeat: [
+ result := random roll: 'd'.
+ self assert: result >= 1 description: [ 'Rolled value ', result asString, ' should be 1 or more.' ].
+ self assert: result <= 6 description: [ 'Rolled value ', result asString, ' should be 6 or less.' ] ].
+ 100 timesRepeat: [
+ result := random roll: '1d'.
+ self assert: result >= 1 description: [ 'Rolled value ', result asString, ' should be 1 or more.' ].
+ self assert: result <= 6 description: [ 'Rolled value ', result asString, ' should be 6 or less.' ] ].
+
+ "Roll a d20"
+ 100 timesRepeat: [
+ result := random roll: '1d20'.
+ self assert: result >= 1 description: [ 'Rolled value ', result asString, ' should be 1 or more.' ].
+ self assert: result <= 20 description: [ 'Rolled value ', result asString, ' should be 20 or less.' ] ].
+
+ "Roll a d% (d100)"
+ 1000 timesRepeat: [
+ result := random roll: '1d%'.
+ self assert: result >= 1 description: [ 'Rolled value ', result asString, ' should be 1 or more.' ].
+ self assert: result <= 100 description: [ 'Rolled value ', result asString, ' should be 100 or less.' ] ].
+ 1000 timesRepeat: [
+ result := random roll: 'd%'.
+ self assert: result >= 1 description: [ 'Rolled value ', result asString, ' should be 1 or more.' ].
+ self assert: result <= 100 description: [ 'Rolled value ', result asString, ' should be 100 or less.' ] ].
+
+ "Roll multiple dice"
+ 100 timesRepeat: [
+ result := random roll: '2d2'.
+ self assert: result >= 2 description: [ 'Rolled value ', result asString, ' should be 2 or more.' ].
+ self assert: result <= 4 description: [ 'Rolled value ', result asString, ' should be 4 or less.' ] ].
+ 100 timesRepeat: [
+ result := random roll: '1d2+1d2'.
+ self assert: result >= 2 description: [ 'Rolled value ', result asString, ' should be 2 or more.' ].
+ self assert: result <= 4 description: [ 'Rolled value ', result asString, ' should be 4 or less.' ] ].
+
+ "Roll some d1s"
+ result := random roll: '10d1'.
+ self assert: result = 10 description: [ 'Rolled value ', result asString, 'should be 10.' ].
+ result := random roll: '10d1-5d1'.
+ self assert: result = 5 description: [ 'Rolled value ', result asString, 'should be 5.' ].
+
+ "Roll a constant value"
+ result := random roll: '5'.
+ self assert: result = 5 description: [ 'Rolled value ', result asString, 'should be 5.' ].
+ result := random roll: '5+3+2'.
+ self assert: result = 10 description: [ 'Rolled value ', result asString, 'should be 10.' ].
+
+ "Roll die and add constant value"
+ result := random roll: '1d1+3'.
+ self assert: result = 4 description: [ 'Rolled value ', result asString, 'should be 4.' ].!
Item was added:
+ ClassTestCase subclass: #ScaledDecimalTest
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'KernelTests-Numbers'!
+
+ !ScaledDecimalTest commentStamp: '<historical>' prior: 0!
+ I provide a test suite for ScaledDecimal values. Examine my tests to see how SmallIntegers should behave, and see how to use them.!
Item was added:
+ ----- Method: ScaledDecimalTest>>testAsNumber (in category 'tests') -----
+ testAsNumber
+ "Ensure no loss of precision"
+
+ | sd |
+ sd := '1.40s2' asNumber.
+ self assert: ScaledDecimal == sd class.
+ self assert: sd scale = 2.
+ self assert: '1.40s2' = sd printString.
+ !
Item was added:
+ ----- Method: ScaledDecimalTest>>testAsNumberNegatedWithoutDecimalPoint (in category 'tests') -----
+ testAsNumberNegatedWithoutDecimalPoint
+
+ | sd |
+ sd := '-123s0' asNumber.
+ self assert: ScaledDecimal == sd class.
+ self assert: sd scale = 0.
+ self assert: '-123s0' = sd printString.
+ !
Item was added:
+ ----- Method: ScaledDecimalTest>>testAsNumberNegatedWithoutDecimalPoint2 (in category 'tests') -----
+ testAsNumberNegatedWithoutDecimalPoint2
+
+ | sd |
+ sd := '-123s2' asNumber.
+ self assert: ScaledDecimal == sd class.
+ self assert: sd scale = 2.
+ self assert: '-123.00s2' = sd printString.
+ !
Item was added:
+ ----- Method: ScaledDecimalTest>>testAsNumberWithExtendedScale (in category 'tests') -----
+ testAsNumberWithExtendedScale
+
+ | sd |
+ sd := '123s2' asNumber.
+ self assert: ScaledDecimal == sd class.
+ self assert: sd scale = 2.
+ self assert: '123.00s2' = sd printString.
+ !
Item was added:
+ ----- Method: ScaledDecimalTest>>testAsNumberWithRadix (in category 'tests') -----
+ testAsNumberWithRadix
+
+ | sd |
+ sd := '10r-22.2s5' asNumber.
+ self assert: ScaledDecimal == sd class.
+ self assert: sd scale = 5.
+ self assert: '-22.20000s5' = sd printString.
+ !
Item was added:
+ ----- Method: ScaledDecimalTest>>testAsNumberWithSuperfluousDecimalPoint (in category 'tests') -----
+ testAsNumberWithSuperfluousDecimalPoint
+
+ | sd |
+ sd := '123.s2' asNumber.
+ self assert: ScaledDecimal == sd class.
+ self assert: sd scale = 2.
+ self assert: '123.00s2' = sd printString.
+
+ !
Item was added:
+ ----- Method: ScaledDecimalTest>>testAsNumberWithoutDecimalPoint (in category 'tests') -----
+ testAsNumberWithoutDecimalPoint
+
+ | sd |
+ sd := '123s0' asNumber.
+ self assert: ScaledDecimal == sd class.
+ self assert: sd scale = 0.
+ self assert: '123s0' = sd printString.
+ !
Item was added:
+ ----- Method: ScaledDecimalTest>>testAsNumberWithoutDecimalPoint2 (in category 'tests') -----
+ testAsNumberWithoutDecimalPoint2
+
+ | sd |
+ sd := '123s2' asNumber.
+ self assert: ScaledDecimal == sd class.
+ self assert: sd scale = 2.
+ self assert: '123.00s2' = sd printString.
+ !
Item was added:
+ ----- Method: ScaledDecimalTest>>testCoercion (in category 'tests') -----
+ testCoercion
+ #( #* #+ #- #/) do: [:op |
+ self assert: (1.0s1 perform: op with: 2) class = ScaledDecimal.
+ self assert: (1.0s1 perform: op with: 1/2) class = ScaledDecimal.
+ self deny: (1.0s1 perform: op with: 1.0) class = ScaledDecimal.
+
+ self assert: (1 perform: op with: 2.0s1) class = ScaledDecimal.
+ self assert: (1/2 perform: op with: 2.0s1) class = ScaledDecimal.
+ self deny: (1.0 perform: op with: 1.0s1) class = ScaledDecimal]!
Item was added:
+ ----- Method: ScaledDecimalTest>>testConvertFromFloat (in category 'tests') -----
+ testConvertFromFloat
+
+ | aFloat sd f2 diff |
+ aFloat := 11/13 asFloat.
+ sd := aFloat asScaledDecimal: 2.
+ self assert: 2 = sd scale.
+ self assert: '0.84s2' = sd printString.
+ self assert: '-0.84s2' = sd negated printString.
+ f2 := sd asFloat.
+ diff := f2 - aFloat.
+ self assert: diff abs < 1.0e-9. "actually, f = f2, but this is not a requirement"
+ !
Item was added:
+ ----- Method: ScaledDecimalTest>>testConvertFromFraction (in category 'tests') -----
+ testConvertFromFraction
+ "Converting a Fractionwith asScaledDecimal use strictly necessary number of decimal places when possible."
+
+ | defaultNumberOfDecimals |
+ 0 to: 11 do: [:pow2 |
+ 0 to: 11 do: [:pow5 |
+ | fraction sd sd2 |
+ fraction := 13 / (2 raisedTo: pow2) / (5 raisedTo: pow5).
+ sd := fraction asScaledDecimal.
+ self assert: sd scale = (pow2 max: pow5).
+ sd2 := ScaledDecimal readFrom: sd printString.
+ self assert: sd = sd2]].
+
+ defaultNumberOfDecimals := (1/3) asScaledDecimal scale.
+ #(6 7 9 11 12 13 14 17 18 19 21 22 23 24) do: [:den |
+ | sd sd2 |
+ sd := (1/den) asScaledDecimal.
+ self assert: sd scale = defaultNumberOfDecimals.
+ sd2 := ScaledDecimal readFrom: sd printString.
+ self deny: sd = sd2
+ ] !
Item was added:
+ ----- Method: ScaledDecimalTest>>testConvertFromFractionWithScale (in category 'tests') -----
+ testConvertFromFractionWithScale
+
+ | sd |
+ sd := (13 / 11) asScaledDecimal: 6.
+ self assert: ScaledDecimal == sd class.
+ self assert: ('1.181818s6' = sd printString).
+ self assert: 6 = sd scale.
+ sd := (-13 / 11) asScaledDecimal: 6.
+ self assert: ScaledDecimal == sd class.
+ self assert: ('-1.181818s6' = sd printString).
+ self assert: 6 = sd scale
+ !
Item was added:
+ ----- Method: ScaledDecimalTest>>testConvertFromInteger (in category 'tests') -----
+ testConvertFromInteger
+ "Converting an Integer with asScaledDecimal use strictly necessary number of decimal places: 0."
+
+ | sd |
+ sd := 13 asScaledDecimal.
+ self assert: 0 = sd scale.
+ self assert: ('13s0' = sd printString).
+ sd := -13 asScaledDecimal.
+ self assert: 0 = sd scale.
+ self assert: ('-13s0' = sd printString).
+ sd := 130000000013 asScaledDecimal.
+ self assert: 0 = sd scale.
+ self assert: ('130000000013s0' = sd printString).
+ sd := -130000000013 asScaledDecimal.
+ self assert: 0 = sd scale.
+ self assert: ('-130000000013s0' = sd printString)
+ !
Item was added:
+ ----- Method: ScaledDecimalTest>>testConvertFromIntegerWithScale (in category 'tests') -----
+ testConvertFromIntegerWithScale
+ "Converting an Integer with asScaledDecimal: does now honour the scale passed as message argument."
+
+ | sd |
+ sd := 13 asScaledDecimal: 6.
+ self assert: 6 = sd scale.
+ self assert: ('13.000000s6' = sd printString).
+ sd := -13 asScaledDecimal: 4.
+ self assert: 4 = sd scale.
+ self assert: ('-13.0000s4' = sd printString).
+ sd := 130000000013 asScaledDecimal: 3.
+ self assert: 3 = sd scale.
+ self assert: ('130000000013.000s3' = sd printString).
+ sd := -130000000013 asScaledDecimal: 1.
+ self assert: 1 = sd scale.
+ self assert: ('-130000000013.0s1' = sd printString)
+ !
Item was added:
+ ----- Method: ScaledDecimalTest>>testExactNthRoot (in category 'tests') -----
+ testExactNthRoot
+ | eight thousandth tenth two |
+ eight := 8.0s1.
+ two := eight raisedTo: 1/3.
+ self assert: two = 2.
+ self assert: (two class = eight class and: [two scale = eight scale]).
+ thousandth := 0.001s3.
+ tenth := thousandth raisedTo: 1/3.
+ self assert: tenth * 10 = 1.
+ self assert: (tenth class = thousandth class and: [tenth scale = thousandth scale]).!
Item was added:
+ ----- Method: ScaledDecimalTest>>testExactSqrt (in category 'tests') -----
+ testExactSqrt
+ | four hundredth tenth two |
+ four := 4.0s1.
+ two := four sqrt.
+ self assert: two = 2.
+ self assert: (two class = four class and: [two scale = four scale]).
+ hundredth := 0.01s2.
+ tenth := hundredth sqrt.
+ self assert: tenth * 10 = 1.
+ self assert: (tenth class = hundredth class and: [tenth scale = hundredth scale]).!
Item was added:
+ ----- Method: ScaledDecimalTest>>testFloorLogExactness (in category 'tests - mathematical functions') -----
+ testFloorLogExactness
+ 1 + (Float fminDenormalized floorLog: 10) to: (Float fmax floorLog: 10) do: [:n |
+ self assert: ((10 raisedTo: n) asScaledDecimal floorLog: 10) = n description: 'floorLog should be exact for ScaledDecimals'.]!
Item was added:
+ ----- Method: ScaledDecimalTest>>testInexactNthRoot (in category 'tests') -----
+ testInexactNthRoot
+ | tenth cubicRoot3 fifthRootTenth three |
+ three := 3.0s1.
+ cubicRoot3 := three raisedTo: 1/3.
+ self assert: cubicRoot3 isFloat.
+ self deny: cubicRoot3 squared = 3.
+ tenth := 0.10s2.
+ fifthRootTenth := tenth raisedTo: 1/5.
+ self assert: fifthRootTenth isFloat.
+ self deny: fifthRootTenth squared = tenth!
Item was added:
+ ----- Method: ScaledDecimalTest>>testInexactSqrt (in category 'tests') -----
+ testInexactSqrt
+ | tenth sqrt3 sqrtTenth three |
+ three := 3.0s1.
+ sqrt3 := three sqrt.
+ self assert: sqrt3 isFloat.
+ self deny: sqrt3 squared = 3.
+ tenth := 0.10s2.
+ sqrtTenth := tenth sqrt.
+ self assert: sqrtTenth isFloat.
+ self deny: sqrtTenth squared = tenth!
Item was added:
+ ----- Method: ScaledDecimalTest>>testIsLiteral (in category 'tests') -----
+ testIsLiteral
+ "This test is related to http://bugs.squeak.org/view.php?id=6796"
+
+ self assert: 1.00s2 isLiteral description: 'every literal obviously isLiteral'.
+
+ "Note that (1 / 3.00s2) is not a well behaved literal,
+ because it does not re-evaluate to self...
+ Every literal should be evaluated as self (see isSelfEvaluating).
+ There is currently no way to print it as a literal.
+ So i propose it shall not answer true."
+ self deny: (1/3.00s2) isLiteral description: 'this number cannot represent itself as a literal'.!
Item was added:
+ ----- Method: ScaledDecimalTest>>testLiteral (in category 'tests') -----
+ testLiteral
+
+ | sd |
+ sd := 1.40s2.
+ self assert: ScaledDecimal == sd class.
+ self assert: sd scale = 2.
+ self assert: '1.40s2' = sd printString!
Item was added:
+ ----- Method: ScaledDecimalTest>>testLn (in category 'tests - mathematical functions') -----
+ testLn
+ self assert: (100.0s1 ln closeTo: 10 ln*2).
+ self assert: ((2 raisedTo: Float emax + 3) asScaledDecimal ln closeTo: 2 ln*(Float emax + 3)) description: 'ScaledDecimal>>ln should not overflow'!
Item was added:
+ ----- Method: ScaledDecimalTest>>testLog (in category 'tests - mathematical functions') -----
+ testLog
+ self assert: ((10 raisedTo: 400) asScaledDecimal log closeTo: 400) description: 'log should be immune to intermediate Float overflow'.
+ self assert: ((10 raisedTo: -400) asScaledDecimal log closeTo: -400) description: 'log should be immune to intermediate Float underflow'!
Item was added:
+ ----- Method: ScaledDecimalTest>>testOneRaisedToInteger (in category 'tests') -----
+ testOneRaisedToInteger
+ "One might be handled specially"
+
+ self assert: (1.0s1 raisedToInteger: -1) scale = 1.
+ self assert: (1.0s1 raisedToInteger: -1) = 1.
+ self assert: (1.0s1 raisedToInteger: 0) scale = 1.
+ self assert: (1.0s1 raisedToInteger: 0) = 1.
+ self assert: (1.0s1 raisedToInteger: 1) scale = 1.
+ self assert: (1.0s1 raisedToInteger: 1) = 1.
+ self assert: (1.0s1 raisedToInteger: 2) scale = 1.
+ self assert: (1.0s1 raisedToInteger: 2) = 1.!
Item was added:
+ ----- Method: ScaledDecimalTest>>testPrintString (in category 'tests') -----
+ testPrintString
+ "The printed representation of a ScaledDecimal is truncated, not rounded.
+ Not sure if this is right, so this test describes the current Squeak implementation.
+ If someone knows a reason that rounding would be preferable, then update
+ this test."
+
+ | sd |
+ sd := (13 / 11) asScaledDecimal: 6.
+ self assert: ('1.181818s6' = sd printString).
+ sd := (13 / 11) asScaledDecimal: 5.
+ self deny: ('1.18182s5' = sd printString).
+ sd := (13 / 11) asScaledDecimal: 5.
+ self assert: ('1.18181s5' = sd printString)
+ !
Item was added:
+ ----- Method: ScaledDecimalTest>>testRaisedToInteger (in category 'tests') -----
+ testRaisedToInteger
+ "Raising to integer should preserve class and scale"
+
+ self assert: (3.0s1 raisedToInteger: -1) scale = 1.
+ self assert: (3.0s1 raisedToInteger: -1) = (1/3).
+ self assert: (3.0s1 raisedToInteger: 0) scale = 1.
+ self assert: (3.0s1 raisedToInteger: 0) = 1.
+ self assert: (3.0s1 raisedToInteger: 1) scale = 1.
+ self assert: (3.0s1 raisedToInteger: 1) = 3.
+ self assert: (3.0s1 raisedToInteger: 2) scale = 1.
+ self assert: (3.0s1 raisedToInteger: 2) = 9.!
Item was added:
+ ----- Method: ScaledDecimalTest>>testReadFrom (in category 'tests') -----
+ testReadFrom
+ "This is related to http://bugs.squeak.org/view.php?id=6779"
+
+ self should: [(ScaledDecimal readFrom: '5.3') isKindOf: ScaledDecimal]
+ description: 'Reading a ScaledDecimal should answer a ScaledDecimal'.
+ self should: [((ScaledDecimal readFrom: '5.3') asScaledDecimal: 1) = (53/10 asScaledDecimal: 1)]
+ description: 'ScaledDecimal readFrom: should not use Float intermediate because it would introduce round off errors'.!
Item was added:
+ ----- Method: ScaledDecimalTest>>testScaleExtension (in category 'tests') -----
+ testScaleExtension
+ "The scale is extended to the larger one in case of arithmetic operation"
+
+ #( #* #+ #- #/) do: [:op |
+ self assert: (2.5s1 perform: op with: 1.000s3) scale = 3.
+ self assert: (3.5000s4 perform: op with: 1.0s1) scale = 4.]!
Item was added:
+ ----- Method: ScaledDecimalTest>>testStoreOn (in category 'tests') -----
+ testStoreOn
+ "this is http://bugs.squeak.org/view.php?id=4378"
+
+ "Both results should be 1.
+ ScaledDecimal representations are exact
+ (though only scale digits or fractional part are printed)"
+
+ self assert:
+ (Compiler evaluate: (0.5s1 squared storeString)) * 4
+ = (0.5s1 squared * 4).
+
+
+ "However, exact literals should store literaly
+ If not, they would break Decompiler."
+
+ "BUG: i cannot write the test like this:
+ self assert:
+ 0.5s2 squared storeString = '0.25s2'
+ BECAUSE compiler would consider 0.5s2 as = 0.5s1 and would reuse same slot..."
+
+ self assert:
+ 0.25s2 storeString = '0.25s2'!
Item was added:
+ ----- Method: ScaledDecimalTest>>testZeroRaisedToInteger (in category 'tests') -----
+ testZeroRaisedToInteger
+ "Zero might be handle specially"
+
+ self should: [0.0s1 raisedToInteger: -1] raise: Error.
+ self assert: (0.0s1 raisedToInteger: 0) = 1.
+ self assert: (0.0s1 raisedToInteger: 0) scale = 1.
+ self assert: (0.0s1 raisedToInteger: 1) = 0.
+ self assert: (0.0s1 raisedToInteger: 1) scale = 1.
+ self assert: (0.0s1 raisedToInteger: 2) = 0.
+ self assert: (0.0s1 raisedToInteger: 2) scale = 1.!
Item was added:
+ ClassTestCase subclass: #SemaphoreTest
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'KernelTests-Processes'!
+
+ !SemaphoreTest commentStamp: 'tlk 5/5/2006 13:32' prior: 0!
+ A SemaphoreTest is sunit test for simple and multiEx semaphores
+
+ Instance Variables none; does not have common test fixture accross all tests (because its testing differenct sorts of semaphores (could refactor into muliple testcases if there were more test conditions.
+ !
Item was added:
+ ----- Method: SemaphoreTest>>criticalError (in category 'private') -----
+ criticalError
+ Processor activeProcess terminate!
Item was added:
+ ----- Method: SemaphoreTest>>expectedFailures (in category 'failures') -----
+ expectedFailures
+
+ ^ #(testUnwindSemaInCriticalWait)!
Item was added:
+ ----- Method: SemaphoreTest>>testCritical (in category 'tests') -----
+ testCritical
+ | lock |
+ lock := Semaphore forMutualExclusion.
+ [lock critical: [self criticalError]] forkAt: Processor userInterruptPriority.
+ self assert: lock isSignaled!
Item was added:
+ ----- Method: SemaphoreTest>>testCriticalIfError (in category 'tests') -----
+ testCriticalIfError
+ | lock |
+ lock := Semaphore forMutualExclusion.
+ [lock critical: [self criticalError ifError:[]]] forkAt: Processor userInterruptPriority.
+ self assert: lock isSignaled!
Item was added:
+ ----- Method: SemaphoreTest>>testSemaAfterCriticalWait (in category 'tests') -----
+ testSemaAfterCriticalWait "self run: #testSemaAfterCriticalWait"
+ "This tests whether a semaphore that has just left the wait in Semaphore>>critical:
+ leaves it with signaling the associated semaphore."
+ | s p |
+ s := Semaphore new.
+ p := [s critical:[]] forkAt: Processor activePriority-1.
+ "wait until p entered the critical section"
+ [p suspendingList == s] whileFalse:[(Delay forMilliseconds: 10) wait].
+ "Now that p entered it, signal the semaphore. p now 'owns' the semaphore
+ but since we are running at higher priority than p it will not get to do
+ anything."
+ s signal.
+ p terminate.
+ self assert: 1 equals: s excessSignals!
Item was added:
+ ----- Method: SemaphoreTest>>testSemaAfterCriticalWaitSuspended (in category 'tests') -----
+ testSemaAfterCriticalWaitSuspended "self run: #testSemaAfterCriticalWaitSuspended"
+ "This tests whether a semaphore that has just left the wait in Semaphore>>critical: but
+ has been suspended before termination, leaves it with signaling the associated semaphore."
+ | s p |
+ s := Semaphore new.
+ p := [s critical:[]] forkAt: Processor activePriority-1.
+ "wait until p entered the critical section"
+ [p suspendingList == s] whileFalse:[(Delay forMilliseconds: 10) wait].
+ "Now that p entered it, signal the semaphore. p now 'owns' the semaphore
+ but since we are running at higher priority than p it will not get to do
+ anything."
+ s signal.
+ self assert: p suspendingList class == LinkedList.
+ p suspend.
+ self assert: p suspendingList == nil.
+ p terminate.
+ self assert: 1 equals: s excessSignals!
Item was added:
+ ----- Method: SemaphoreTest>>testSemaCriticalBlockedInEnsure (in category 'tests') -----
+ testSemaCriticalBlockedInEnsure "self run: #testSemaCriticalBlockedInEnsure"
+ "This tests whether a semaphore that is in ensure: but has yet to evaluate the valueNoContextSwitch
+ leaves it with signaling the associated semaphore."
+ | decompilation needSignalToEnterEnsure s p |
+ "Distinguish between e.g.
+ critical: t1 <criticalSection> ^[self wait. t1 value] ensure: [self signal]
+ and
+ critical: t1 <criticalSection> self wait. ^t1 ensure: [self signal]"
+ decompilation := (Semaphore>>#critical:) decompileString.
+ needSignalToEnterEnsure := (decompilation indexOfSubCollection: #wait) < (decompilation indexOf: $[).
+ s := Semaphore new.
+ needSignalToEnterEnsure ifTrue: [s signal].
+ p := [s critical: []] newProcess.
+ p priority: Processor activePriority - 1.
+ "step until in critical:"
+ [p suspendedContext selector == #critical:] whileFalse: [p step].
+ "step until in ensure: (can't do this until in critical: cuz ensure: may be in newProcess etc...)"
+ [p suspendedContext selector == #ensure:] whileFalse: [p step].
+ "Now check that if we needed a signal to enter ensure: it has been consumed."
+ self assert: 0 equals: s excessSignals.
+ "Now that p is at the right point, resume the process and immediately terminate it."
+ p resume; terminate.
+ self assert: (needSignalToEnterEnsure ifTrue: [1] ifFalse: [0]) equals: s excessSignals!
Item was added:
+ ----- Method: SemaphoreTest>>testSemaInCriticalEnsureArgument (in category 'tests') -----
+ testSemaInCriticalEnsureArgument "self run: #testSemaInCriticalEnsureArgument"
+ "This tests whether a process that is in ensure argument block but has yet to evaluate the signal
+ leaves it with signaling the associated semaphore."
+
+ | terminatee sema |
+ sema := Semaphore forMutualExclusion.
+ terminatee := [sema critical: []] newProcess.
+ self assert: terminatee isSuspended.
+ terminatee runUntil: [:ctx | ctx selectorToSendOrSelf = #signal].
+ self assert: terminatee isSuspended.
+ terminatee terminate.
+ self assert: terminatee isTerminated.
+ self assert: sema excessSignals = 1 !
Item was added:
+ ----- Method: SemaphoreTest>>testSemaInCriticalWait (in category 'tests') -----
+ testSemaInCriticalWait "self run: #testSemaInCriticalWait"
+ "This tests whether a semaphore that has entered the wait in Semaphore>>critical:
+ leaves it without signaling the associated semaphore."
+ | s p |
+ s := Semaphore new.
+ p := [s critical:[]] fork.
+ Processor yield.
+ self assert:(p suspendingList == s).
+ p terminate.
+ self assert: 0 equals: s excessSignals!
Item was added:
+ ----- Method: SemaphoreTest>>testSuspendAndResume (in category 'tests') -----
+ testSuspendAndResume
+ "Test the semantics of suspending and resuming a process blocked on a semaphore;
+ Note the difference between #suspend and #suspendAndUnblock.
+ Note: this test will fail when run with older VMs without primitive suspend 578."
+
+ | p |
+ p := [Semaphore new wait] fork.
+ Processor yield.
+ p suspend; resume.
+ "suspend removes p from the semaphore but backs up its pc;
+ hence when resumed p reenters the wait state"
+ Processor yield.
+ self assert: p isBlocked.
+
+ p := [Semaphore new wait] fork.
+ Processor yield.
+ p suspendAndUnblock; resume.
+ "suspendAndUnblock just removes p from the semaphore;
+ hence when resumed p simply proceeds"
+ Processor yield.
+ self assert: p isTerminated!
Item was added:
+ ----- Method: SemaphoreTest>>testUnwindSemaInCriticalWait (in category 'tests') -----
+ testUnwindSemaInCriticalWait "self run: #testSemaInCriticalWait"
+ "This tests whether a semaphore that has entered the wait in Semaphore>>critical:
+ leaves it without signaling the associated semaphore."
+ | s p |
+ s := Semaphore new.
+ p := [[] ensure: [s critical:[]]] fork.
+ Processor yield.
+ self assert:(p suspendingList == s).
+ p terminate.
+ self assert: 0 equals: s excessSignals!
Item was added:
+ ----- Method: SemaphoreTest>>testWaitAndWaitTimeoutTogether (in category 'tests') -----
+ testWaitAndWaitTimeoutTogether
+ | semaphore value waitProcess waitTimeoutProcess |
+ semaphore := Semaphore new.
+
+ waitProcess := [semaphore wait. value := #wait] fork.
+
+ waitTimeoutProcess := [semaphore waitTimeoutMSecs: 50. value := #waitTimeout] fork.
+
+ "Wait for the timeout to happen"
+ (Delay forMilliseconds: 100) wait.
+
+ "The waitTimeoutProcess should already have timed out. This should release the waitProcess"
+ semaphore signal.
+
+ [waitProcess isTerminated and: [waitTimeoutProcess isTerminated]]
+ whileFalse: [(Delay forMilliseconds: 100) wait].
+
+ self assert: value = #wait.
+ !
Item was added:
+ ----- Method: SemaphoreTest>>testWaitTimeoutMSecs (in category 'tests') -----
+ testWaitTimeoutMSecs
+ "Ensure that waitTimeoutMSecs behaves properly"
+
+ "Ensure that a timed out waitTimeoutMSecs: returns true from the wait"
+ self assert: (Semaphore new waitTimeoutMSecs: 50) == true.
+
+ "Ensure that a signaled waitTimeoutMSecs: returns false from the wait"
+ self assert: (Semaphore new signal waitTimeoutMSecs: 50) == false.
+ !
Item was added:
+ ClassTestCase subclass: #SmallIntegerTest
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'KernelTests-Numbers'!
+
+ !SmallIntegerTest commentStamp: 'fbs 3/8/2004 22:13' prior: 0!
+ I provide a test suite for SmallInteger values. Examine my tests to see how SmallIntegers should behave, and see how to use them.!
Item was added:
+ ----- Method: SmallIntegerTest>>testBasicNew (in category 'tests - Class Methods') -----
+ testBasicNew
+
+ self shouldRaiseError: [SmallInteger basicNew].!
Item was added:
+ ----- Method: SmallIntegerTest>>testDecimalDigitLength (in category 'tests - printing') -----
+ testDecimalDigitLength
+
+ | x length random |
+ "Test edge cases"
+ x := 1.
+ length := 1.
+ [ x <= SmallInteger maxVal ] whileTrue: [
+ self
+ assert: length equals: x decimalDigitLength;
+ assert: (length - 1 max: 1) equals: (x - 1) decimalDigitLength.
+ x := x * 10.
+ length := length + 1 ].
+ "A few values by hand"
+ #(
+ 0 1
+ 4 1
+ 12 2
+ 123 3
+ 1234 4
+ 56789 5
+ 657483 6
+ 6571483 7
+ 65174383 8
+ 625744831 9
+ 1000001111 10
+ ), {
+ SmallInteger maxVal. Smalltalk wordSize = 8 ifTrue: [ 19 ] ifFalse: [ 10 ]
+ } groupsDo: [ :input :expectedOutput |
+ self assert: expectedOutput equals: input decimalDigitLength ].
+ "Pseudorandom tests."
+ random := Random seed: 36rSqueak.
+ 10000 timesRepeat: [
+ x := SmallInteger maxVal atRandom: random.
+ self assert: x asString size equals: x decimalDigitLength ]!
Item was added:
+ ----- Method: SmallIntegerTest>>testDivide (in category 'tests - arithmetic') -----
+ testDivide
+
+ self assert: 2 / 1 = 2.
+ self assert: (3 / 2) isFraction.
+ self assert: 4 / 2 = 2.
+ self should: [ 1 / 0 ] raise: ZeroDivide.!
Item was added:
+ ----- Method: SmallIntegerTest>>testDivideMayOverflow (in category 'tests - arithmetic') -----
+ testDivideMayOverflow
+ "Dividing a SmallInteger by another Integer may answer a Large Integer.
+ These cases have caused several VM bugs in the past, it's better to keep some assrtion around."
+
+ self assert: (SmallInteger minVal / -1) isLarge.
+ self assert: (SmallInteger minVal / -1) = (SmallInteger maxVal + 1).
+
+ self assert: (SmallInteger minVal quo: -1) isLarge.
+ self assert: (SmallInteger minVal quo: -1) = (SmallInteger maxVal + 1).
+
+ self assert: (SmallInteger minVal // -1) isLarge.
+ self assert: (SmallInteger minVal // -1) = (SmallInteger maxVal + 1).!
Item was added:
+ ----- Method: SmallIntegerTest>>testEven (in category 'tests - basic') -----
+ testEven
+
+ self assert: (SmallInteger minVal even).
+ self deny: (SmallInteger maxVal even).
+
+ self deny: ((SmallInteger minVal + 1) even).
+ self assert: ((SmallInteger maxVal - 1) even).
+
+ self deny: (1 even).
+ self deny: (-1 even).
+
+ self assert: (2 even).
+ self assert: (-2 even).
+
+ self assert: (0 even).!
Item was added:
+ ----- Method: SmallIntegerTest>>testMaxVal (in category 'tests - Class Methods') -----
+ testMaxVal
+
+ self assert: (SmallInteger maxVal = 16r3FFFFFFF or: [SmallInteger maxVal = 16rFFFFFFFFFFFFFFF]).!
Item was added:
+ ----- Method: SmallIntegerTest>>testMinVal (in category 'tests - Class Methods') -----
+ testMinVal
+
+ self assert: (SmallInteger minVal = -16r40000000 or: [SmallInteger minVal = -16r1000000000000000]).!
Item was added:
+ ----- Method: SmallIntegerTest>>testNew (in category 'tests - Class Methods') -----
+ testNew
+
+ self shouldRaiseError: [SmallInteger new].!
Item was added:
+ ----- Method: SmallIntegerTest>>testOdd (in category 'tests - basic') -----
+ testOdd
+
+ self deny: (SmallInteger minVal odd).
+ self assert: (SmallInteger maxVal odd).
+
+ self assert: ((SmallInteger minVal + 1) odd).
+ self deny: ((SmallInteger maxVal - 1) odd).
+
+ self assert: (1 odd).
+ self assert: (-1 odd).
+
+ self deny: (2 odd).
+ self deny: (-2 odd).
+
+ self deny: (0 odd).!
Item was added:
+ ----- Method: SmallIntegerTest>>testPrintPaddedWith (in category 'tests - printing') -----
+ testPrintPaddedWith
+
+ self assert: (123 printPaddedWith: $0 to: 10 base: 2) = '0001111011'.
+ self assert: (123 printPaddedWith: $0 to: 10 base: 8) = '0000000173'.
+ self assert: (123 printPaddedWith: $0 to: 10 base: 10) = '0000000123'.
+ self assert: (123 printPaddedWith: $0 to: 10 base: 16) = '000000007B'.!
Item was added:
+ ----- Method: SmallIntegerTest>>testPrintString (in category 'tests - printing') -----
+ testPrintString
+
+ self assert: 1 printString = '1'.
+ self assert: -1 printString = '-1'.
+ self assert: SmallInteger minVal printString = (Smalltalk wordSize = 8 ifTrue: [ '-1152921504606846976'] ifFalse: ['-1073741824']).
+ self assert: SmallInteger maxVal printString = (Smalltalk wordSize = 8 ifTrue: [ '1152921504606846975'] ifFalse: ['1073741823']).
+ self assert: 12345 printString = '12345'.
+ self assert: -54321 printString = '-54321'!
Item was added:
+ ClassTestCase subclass: #SqNumberParserTest
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'KernelTests-Numbers'!
+
+ !SqNumberParserTest commentStamp: 'nice 5/7/2006 17:54' prior: 0!
+ Provide tests for new clas aimed at parsing numbers.
+
+ It duplicates NumberParsingTest, with few more tests.!
Item was added:
+ ----- Method: SqNumberParserTest>>areLowercaseDigitsAllowed (in category 'utility') -----
+ areLowercaseDigitsAllowed
+ "Answer true if lowercase letter are allowed digits."
+
+ ^(SqNumberParser parse: '16re' onError: [-1]) = 16rE!
Item was added:
+ ----- Method: SqNumberParserTest>>testBases (in category 'tests - fail') -----
+ testBases
+
+ self assert: (SqNumberParser parse: '16r20') equals: 32.
+ self assert: (SqNumberParser parse: '2r10') equals: 2.
+ self assert: ((SqNumberParser on: '10')
+ nextIntegerBase: 2) equals: 2.
+ self assert: ((SqNumberParser on: '10')
+ defaultBase: 2;
+ nextNumber) equals: 2.
+ self assert: ((SqNumberParser on: '1000r10')
+ defaultBase: 2;
+ nextNumber) equals: 8.!
Item was added:
+ ----- Method: SqNumberParserTest>>testFail (in category 'tests - fail') -----
+ testFail
+ "Verify that the value of a failblock is returned."
+ self assert: (SqNumberParser parse: 'blablabla' onError: [42]) equals: 42!
Item was added:
+ ----- Method: SqNumberParserTest>>testFloatFromStreamAsNumber (in category 'tests - Float') -----
+ testFloatFromStreamAsNumber
+ "This covers parsing in Number>>readFrom:"
+
+ | rs aFloat |
+ rs := '10r-12.3456' readStream.
+ aFloat := SqNumberParser parse: rs.
+ self assert: -12.3456 = aFloat.
+ self assert: rs atEnd.
+
+ rs := '10r-12.3456e2' readStream.
+ aFloat := SqNumberParser parse: rs.
+ self assert: -1234.56 = aFloat.
+ self assert: rs atEnd.
+
+ rs := '10r-12.3456e2e2' readStream.
+ aFloat := SqNumberParser parse: rs.
+ self assert: -1234.56 = aFloat.
+ self assert: rs upToEnd = 'e2'.
+
+ rs := '10r-12.3456d2' readStream.
+ aFloat := SqNumberParser parse: rs.
+ self assert: -1234.56 = aFloat.
+ self assert: rs atEnd.
+
+ rs := '10r-12.3456q2' readStream.
+ aFloat := SqNumberParser parse: rs.
+ self assert: -1234.56 = aFloat.
+ self assert: rs atEnd.
+
+ rs := '-12.3456q2' readStream.
+ aFloat := SqNumberParser parse: rs.
+ self assert: -1234.56 = aFloat.
+ self assert: rs atEnd.
+
+ rs := '12.3456q2' readStream.
+ aFloat := SqNumberParser parse: rs.
+ self assert: 1234.56 = aFloat.
+ self assert: rs atEnd.
+
+ rs := '12.3456z2' readStream.
+ aFloat := SqNumberParser parse: rs.
+ self assert: 12.3456 = aFloat.
+ self assert: rs upToEnd = 'z2'.
+ !
Item was added:
+ ----- Method: SqNumberParserTest>>testFloatFromStreamWithExponent (in category 'tests - Float') -----
+ testFloatFromStreamWithExponent
+ "This covers parsing in Number>>readFrom:"
+
+ | rs aFloat |
+ rs := '1.0e-14' readStream.
+ aFloat := SqNumberParser parse: rs.
+ self assert: 1.0e-14 = aFloat.
+ self assert: rs atEnd.
+
+ rs := '1.0e-14 1' readStream.
+ aFloat := SqNumberParser parse: rs.
+ self assert: 1.0e-14 = aFloat.
+ self assert: rs upToEnd = ' 1'.
+
+ rs := '1.0e-14eee' readStream.
+ aFloat := SqNumberParser parse: rs.
+ self assert: 1.0e-14 = aFloat.
+ self assert: rs upToEnd = 'eee'.
+
+ rs := '1.0e14e10' readStream.
+ aFloat := SqNumberParser parse: rs.
+ self assert: 1.0e14 = aFloat.
+ self assert: rs upToEnd = 'e10'.
+
+ rs := '1.0e+14e' readStream. "Plus sign is not parseable"
+ aFloat := SqNumberParser parse: rs.
+ self assert: 1.0 = aFloat.
+ self assert: rs upToEnd = 'e+14e'.
+
+ rs := '1.0e' readStream.
+ aFloat := SqNumberParser parse: rs.
+ self assert: 1.0 = aFloat.
+ self assert: rs upToEnd = 'e'.!
Item was added:
+ ----- Method: SqNumberParserTest>>testFloatGradualUnderflow (in category 'tests - Float') -----
+ testFloatGradualUnderflow
+ "Gradual underflow are tricky.
+ This is a non regression test for http://bugs.squeak.org/view.php?id=6976"
+
+ | float trueFraction str |
+
+ "as a preamble, use a base 16 representation to avoid round off error and check that number parsing is correct"
+ trueFraction := 16r2D2593D58B4FC4 / (16 raisedTo: 256+13).
+ "Parse the number in base 16 if possible - it is impossible if lowercase letter are allowed digits due to exponent letter ambiguity."
+ float := self areLowercaseDigitsAllowed
+ ifFalse: [SqNumberParser parse: '16r2.D2593D58B4FC4e-256']
+ ifTrue: [trueFraction asFloat]..
+ self assert: float asTrueFraction = trueFraction.
+ self assert: float = trueFraction asFloat.
+
+ "now print in base 10"
+ str := (String new: 32) writeStream.
+ float printOn: str base: 10.
+
+ "verify if SqNumberParser can read it back"
+ self assert: (SqNumberParser parse: str contents) = float. !
Item was added:
+ ----- Method: SqNumberParserTest>>testFloatPrintString (in category 'tests - Float') -----
+ testFloatPrintString
+ "self debug: #testFloatPrintString"
+
+ | f r bases |
+ f := Float basicNew: 2.
+ r := Random new seed: 1234567.
+ "printing a Float in base other than 10 is broken if lowercase digits are allowed"
+ bases := self areLowercaseDigitsAllowed
+ ifTrue: [#(10)]
+ ifFalse: [#(2 8 10 16)].
+ 100
+ timesRepeat: [f basicAt: 1 put: (r nextInt: 16r100000000)- 1.
+ f basicAt: 2 put: (r nextInt: 16r100000000) - 1.
+ bases
+ do: [:base | | str |
+ str := (String new: 64) writeStream.
+ f negative ifTrue: [str nextPut: $-].
+ str print: base; nextPut: $r.
+ f abs printOn: str base: base.
+ self assert: (SqNumberParser parse: str contents) = f]].
+ "test big num near infinity"
+ 10
+ timesRepeat: [f basicAt: 1 put: 16r7FE00000 + ((r nextInt: 16r100000) - 1).
+ f basicAt: 2 put: (r nextInt: 16r100000000) - 1.
+ bases
+ do: [:base | | str |
+ str := (String new: 64) writeStream.
+ f negative ifTrue: [str nextPut: $-].
+ str print: base; nextPut: $r.
+ f abs printOn: str base: base.
+ self assert: (SqNumberParser parse: str contents) = f]].
+ "test infinitesimal (gradual underflow)"
+ 10
+ timesRepeat: [f basicAt: 1 put: 0 + ((r nextInt: 16r100000) - 1).
+ f basicAt: 2 put: (r nextInt: 16r100000000) - 1.
+ bases
+ do: [:base | | str |
+ str := (String new: 64) writeStream.
+ f negative ifTrue: [str nextPut: $-].
+ str print: base; nextPut: $r.
+ f abs printOn: str base: base.
+ self assert: (SqNumberParser parse: str contents) = f]].!
Item was added:
+ ----- Method: SqNumberParserTest>>testFloatReadError (in category 'tests - Float') -----
+ testFloatReadError
+ "This covers parsing in Number>>readFrom:"
+
+ | rs num |
+ rs := '1e' readStream.
+ num := SqNumberParser parse: rs.
+ self assert: 1 = num.
+ self assert: rs upToEnd = 'e'.
+
+ rs := '1.' readStream.
+ num := SqNumberParser parse: rs.
+ self assert: 1 = num.
+ self assert: num isInteger.
+ self assert: rs upToEnd = '.'.
+
+ rs := '' readStream.
+ self should: [SqNumberParser parse: rs] raise: Error.
+
+ rs := 'foo' readStream.
+ self should: [SqNumberParser parse: rs] raise: Error.
+
+ rs := 'radix' readStream.
+ self should: [SqNumberParser parse: rs] raise: Error.
+
+ rs := '.e0' readStream.
+ self should: [SqNumberParser parse: rs] raise: Error.
+
+ rs := '-.e0' readStream.
+ self should: [SqNumberParser parse: rs] raise: Error.
+
+ rs := '--1' readStream.
+ self should: [SqNumberParser parse: rs] raise: Error.!
Item was added:
+ ----- Method: SqNumberParserTest>>testFloatReadWithRadix (in category 'tests - Float') -----
+ testFloatReadWithRadix
+ "This covers parsing in Number>>readFrom:
+ Note: In most Smalltalk dialects, the radix notation is not used for numbers
+ with exponents. In Squeak, a string with radix and exponent can be parsed,
+ and the exponent is always treated as base 10 (not the base indicated in the
+ radix prefix). I am not sure if this is a feature, a bug, or both, but the
+ Squeak behavior is documented in this test. -dtl"
+
+ | aNumber rs |
+ aNumber := '2r1.0101e9' asNumber.
+ self assert: 672.0 = aNumber.
+ self assert: (SqNumberParser parse: '2r1.0101e9') = (1.3125 * (2 raisedTo: 9)).
+ rs := ReadStream on: '2r1.0101e9e9'.
+ self assert: (SqNumberParser parse: rs) = 672.0.
+ self assert: rs upToEnd = 'e9'
+ !
Item was added:
+ ----- Method: SqNumberParserTest>>testIntegerReadFrom (in category 'tests - Integer') -----
+ testIntegerReadFrom
+ "Ensure remaining characters in a stream are not lost when parsing an integer."
+
+ | rs i s |
+ rs := ReadStream on: '123.s could be confused with a ScaledDecimal'.
+ i := SqNumberParser parse: rs.
+ self assert: (i isInteger and: [ i = 123 ]).
+ s := rs upToEnd.
+ self assert: '.s could be confused with a ScaledDecimal' = s
+ !
Item was added:
+ ----- Method: SqNumberParserTest>>testIntegerReadWithRadix (in category 'tests - Integer') -----
+ testIntegerReadWithRadix
+ "This covers parsing in Number>>readFrom:
+ Note: In most Smalltalk dialects, the radix notation is not used for numbers
+ with exponents. In Squeak, a string with radix and exponent can be parsed,
+ and the exponent is always treated as base 10 (not the base indicated in the
+ radix prefix). I am not sure if this is a feature, a bug, or both, but the
+ Squeak behavior is documented in this test. -dtl"
+
+ | aNumber rs |
+ aNumber := '2r1e26' asNumber.
+ self assert: 67108864 = aNumber.
+ self assert: (SqNumberParser parse: '2r1e26') = (2 raisedTo: 26).
+ rs := '2r1e26eee' readStream.
+ self assert: (SqNumberParser parse: rs) = 67108864.
+ self assert: rs upToEnd = 'eee'
+ !
Item was added:
+ ----- Method: SqNumberParserTest>>testScaledDecimalWithImplicitScale (in category 'tests - ScaledDecimal') -----
+ testScaledDecimalWithImplicitScale
+ "Implicit scale is automatically adjusted to the number of fractional digits specified"
+
+ #(
+ ('123s' 123s0)
+ ('0.5s' 0.5s1)
+ ('1.60s' 1.60s2)
+ ('23.070s' 23.070s3)
+ ) do: [:each |
+ [:string :scaledDecimal |
+ | value |
+ value := SqNumberParser parse: string readStream.
+ self assert: value = scaledDecimal.
+ self assert: value class = scaledDecimal class.
+ self assert: value scale = scaledDecimal scale] valueWithArguments: each]!
Item was added:
+ ----- Method: SqNumberParserTest>>testScaledDecimalWithTrailingZeroes (in category 'tests - ScaledDecimal') -----
+ testScaledDecimalWithTrailingZeroes
+ "This is a non regression tests for http://bugs.squeak.org/view.php?id=7169"
+
+ self assert: (SqNumberParser parse: '0.50s2') = (1/2).
+ self assert: (SqNumberParser parse: '0.500s3') = (1/2).
+ self assert: (SqNumberParser parse: '0.050s3') = (1/20).!
Item was added:
+ ClassForBehaviorTest subclass: #SubClassForBehaviorTest
+ instanceVariableNames: 'iv3'
+ classVariableNames: 'CV3'
+ poolDictionaries: ''
+ category: 'KernelTests-Classes'!
Item was added:
+ ----- Method: SubClassForBehaviorTest class>>install (in category 'accessing') -----
+ install
+ civ1 := true!
Item was added:
+ ----- Method: SubClassForBehaviorTest>>iv2: (in category 'accessing') -----
+ iv2: anyObject
+ iv2 := anyObject printString!
Item was added:
+ ----- Method: SubClassForBehaviorTest>>resetIV1 (in category 'accessing') -----
+ resetIV1
+ iv1 := nil!
Item was added:
+ DynamicVariable subclass: #TestDynamicVariable
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'KernelTests-Processes'!
+ TestDynamicVariable class
+ instanceVariableNames: 'defaultValue'!
+
+ !TestDynamicVariable commentStamp: 'mvl 3/13/2007 13:51' prior: 0!
+ TestDynamicVariable is a test class using in ProcessSpecificTest.
+
+ !
+ TestDynamicVariable class
+ instanceVariableNames: 'defaultValue'!
Item was added:
+ ----- Method: TestDynamicVariable class>>default (in category 'accessing') -----
+ default
+
+ ^ defaultValue!
Item was added:
+ ----- Method: TestDynamicVariable class>>default: (in category 'accessing') -----
+ default: anObject
+
+ defaultValue := anObject.!
Item was added:
+ nil subclass: #TestEmptyClass
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'KernelTests-Methods'!
+
+ !TestEmptyClass commentStamp: 'ct 11/25/2021 11:49' prior: 0!
+ I do not even understand #doesNotUnderstand:!! Sending any non-inlined message to me should crash the executor.!
Item was added:
+ ProcessLocalVariable subclass: #TestLocalVariable
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'KernelTests-Processes'!
+
+ !TestLocalVariable commentStamp: 'mvl 3/13/2007 13:52' prior: 0!
+ TestLocalVariable is a test class using in ProcessSpecificTest.!
Item was added:
+ ----- Method: TestLocalVariable class>>default (in category 'as yet unclassified') -----
+ default
+ "My default value for a new process is 0."
+
+ ^0!
Item was added:
+ ProtoObject subclass: #TestObjectForMethod
+ instanceVariableNames: 'method'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'KernelTests-Methods'!
Item was added:
+ ----- Method: TestObjectForMethod>>doesNotUnderstand: (in category 'dynamic forwarding') -----
+ doesNotUnderstand: aMessage
+
+ ^ aMessage sendTo: method!
Item was added:
+ ----- Method: TestObjectForMethod>>flushCache (in category 'compatibility') -----
+ flushCache!
Item was added:
+ ----- Method: TestObjectForMethod>>methodClass: (in category 'compatibility') -----
+ methodClass: aMethodClass!
Item was added:
+ ----- Method: TestObjectForMethod>>run:with:in: (in category 'evaluating') -----
+ run: oldSelector with: arguments in: receiver
+ ^ {oldSelector. arguments. receiver}!
Item was added:
+ ----- Method: TestObjectForMethod>>selector: (in category 'compatibility') -----
+ selector: aSymbol!
Item was added:
+ ----- Method: TestObjectForMethod>>xxxMethod: (in category 'accessing') -----
+ xxxMethod: aCompiledMethod
+
+ method := aCompiledMethod!
Item was added:
+ ClassTestCase subclass: #TrueTest
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'KernelTests-Objects'!
Item was added:
+ ----- Method: TrueTest>>testAND (in category 'tests') -----
+ testAND
+
+ self assert: (true & true) = true.
+ self assert: (true & false) = false.!
Item was added:
+ ----- Method: TrueTest>>testAnd (in category 'tests') -----
+ testAnd
+
+ self assert: (true and: ['alternativeBlock']) = 'alternativeBlock'.!
Item was added:
+ ----- Method: TrueTest>>testAsBit (in category 'tests') -----
+ testAsBit
+
+ self assert: (true asBit = 1).!
Item was added:
+ ----- Method: TrueTest>>testIfFalse (in category 'tests') -----
+ testIfFalse
+
+ self assert: (true ifFalse: ['alternativeBlock']) = nil. !
Item was added:
+ ----- Method: TrueTest>>testIfFalseIfTrue (in category 'tests') -----
+ testIfFalseIfTrue
+
+ self assert: (true ifFalse: ['falseAlternativeBlock']
+ ifTrue: ['trueAlternativeBlock']) = 'trueAlternativeBlock'. !
Item was added:
+ ----- Method: TrueTest>>testIfTrue (in category 'tests') -----
+ testIfTrue
+
+ self assert: (true ifTrue: ['alternativeBlock']) = 'alternativeBlock'. !
Item was added:
+ ----- Method: TrueTest>>testIfTrueIfFalse (in category 'tests') -----
+ testIfTrueIfFalse
+
+ self assert: (true ifTrue: ['trueAlternativeBlock']
+ ifFalse: ['falseAlternativeBlock']) = 'trueAlternativeBlock'. !
Item was added:
+ ----- Method: TrueTest>>testInMemory (in category 'tests') -----
+ testInMemory
+
+ self assert: (true isInMemory = true).!
Item was added:
+ ----- Method: TrueTest>>testNew (in category 'tests') -----
+ testNew
+
+ self should: [True new] raise: Error. !
Item was added:
+ ----- Method: TrueTest>>testNot (in category 'tests') -----
+ testNot
+
+ self assert: (true not = false).!
Item was added:
+ ----- Method: TrueTest>>testOR (in category 'tests') -----
+ testOR
+
+ self assert: (true | true) = true.
+ self assert: (true | false) = true.!
Item was added:
+ ----- Method: TrueTest>>testOr (in category 'tests') -----
+ testOr
+
+ self assert: (true or: ['alternativeBlock']) = true.!
Item was added:
+ ----- Method: TrueTest>>testPrintOn (in category 'tests') -----
+ testPrintOn
+
+ self assert: (String streamContents: [:stream | true printOn: stream]) = 'true'. !
Item was added:
+ ----- Method: TrueTest>>testXor (in category 'tests') -----
+ testXor
+ self assert: (true xor: true) = false.
+ self assert: (true xor: false) = true.
+ self assert: (true xor: [true]) = false.
+ self assert: (true xor: [false]) = true.
+ "Verify that boolean with non-boolean raise errors."
+ self should: [true xor: [1]] raise: Error.
+ self should: [true xor: 1] raise: Error.!
Item was added:
+ ClassTestCase subclass: #UndefinedObjectTest
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'KernelTests-Objects'!
+
+ !UndefinedObjectTest commentStamp: '<historical>' prior: 0!
+ This is the unit test for the class UndefinedObject. Unit tests are a good way to exercise the functionality of your system in a repeatable and automatic manner. They are therefore recommended if you plan to release anything. For more information, see:
+ - http://www.c2.com/cgi/wiki?UnitTest
+ - http://minnow.cc.gatech.edu/squeak/1547
+ - the sunit class category!
Item was added:
+ ----- Method: UndefinedObjectTest>>testAllInstances (in category 'tests - Class Methods') -----
+ testAllInstances
+ self assert: UndefinedObject allInstances size = 1 description: 'There should be a single instance of UndefinedObject'.
+ self assert: (UndefinedObject allInstances includes: nil) description: 'nil should be an instance of UndefinedObject'.!
Item was added:
+ ----- Method: UndefinedObjectTest>>testDeepCopy (in category 'tests - copying') -----
+ testDeepCopy
+
+ self assert: (nil deepCopy = nil).!
Item was added:
+ ----- Method: UndefinedObjectTest>>testHaltIfNil (in category 'tests - testing') -----
+ testHaltIfNil
+
+ self should: [ nil haltIfNil] raise: Halt.!
Item was added:
+ ----- Method: UndefinedObjectTest>>testIfNil (in category 'tests - testing') -----
+ testIfNil
+
+ | object block |
+ object := Object new.
+ self should: [ nil ifNil: [ self halt ] ] raise: Halt.
+ self assert: (nil ifNil: [ object ]) == object.
+ "Now the same without inlining."
+ block := [ self halt ].
+ self should: [ nil ifNil: block ] raise: Halt.
+ block := [ object ].
+ self assert: (nil ifNil: block) == object.
+
+
+
+ !
Item was added:
+ ----- Method: UndefinedObjectTest>>testIfNilIfNotNil (in category 'tests - testing') -----
+ testIfNilIfNotNil
+
+ | object block |
+ object := Object new.
+ self should: [ nil ifNil: [self halt] ifNotNil: [ self error] ] raise: Halt.
+ self should: [ nil ifNil: [ self halt ] ifNotNil: [ :o | self error ] ] raise: Halt.
+ self assert: (nil ifNil: [ object ] ifNotNil: [ 1 ]) == object.
+ self assert: (nil ifNil: [ object ] ifNotNil: [ :o | 1 ]) == object.
+ "Now the same without inlining."
+ block := [ self halt ].
+ self should: [ nil ifNil: block ifNotNil: [ self error ] ] raise: Halt.
+ self should: [ nil ifNil: block ifNotNil: [ :o | self error ] ] raise: Halt.
+ block := [ object ].
+ self assert: (nil ifNil: block ifNotNil: [ 1 ]) == object.
+ self assert: (nil ifNil: block ifNotNil: [ :o | 1 ]) == object!
Item was added:
+ ----- Method: UndefinedObjectTest>>testIfNotNil (in category 'tests - testing') -----
+ testIfNotNil
+
+ | block |
+ self shouldnt: [ nil ifNotNil: [ self halt ] ] raise: Halt.
+ self shouldnt: [ nil ifNotNil: [ :object | self halt ] ] raise: Halt.
+ self assert: (nil ifNotNil: [ 1 ]) == nil.
+ self assert: (nil ifNotNil: [ :o | 1 ]) == nil.
+ "Now the same without inlining."
+ block := [ self halt ].
+ self shouldnt: [ nil ifNotNil: block ] raise: Halt.
+ block := [ :object | self halt ].
+ self shouldnt: [ nil ifNotNil: block ] raise: Halt.
+ block := [ 1 ].
+ self assert: (nil ifNotNil: block) == nil.
+ block := [ :o | 1 ].
+ self assert: (nil ifNotNil: block) == nil.
+
+
+ !
Item was added:
+ ----- Method: UndefinedObjectTest>>testIfNotNilIfNil (in category 'tests - testing') -----
+ testIfNotNilIfNil
+
+ | object block |
+ object := Object new.
+ self should: [ nil ifNotNil: [ self error ] ifNil: [ self halt ] ] raise: Halt.
+ self should: [ nil ifNotNil: [ :o | self error] ifNil: [ self halt ] ] raise: Halt.
+ self assert: (nil ifNotNil: [ 1 ] ifNil: [ object ]) == object.
+ self assert: (nil ifNotNil: [ :o | 1 ] ifNil: [ object ]) == object.
+ "Now the same without inlining."
+ block := [ self error ].
+ self should: [ nil ifNotNil: block ifNil: [ self halt ] ] raise: Halt.
+ block := [ :o | self error].
+ self should: [ nil ifNotNil: block ifNil: [ self halt ] ] raise: Halt.
+ block := [ 1 ].
+ self assert: (nil ifNotNil: block ifNil: [ object ]) == object.
+ block := [ :o | 1 ].
+ self assert: (nil ifNotNil: block ifNil: [ object ]) == object!
Item was added:
+ ----- Method: UndefinedObjectTest>>testInitializedInstance (in category 'tests - Class Methods') -----
+ testInitializedInstance
+
+ self assert: ( UndefinedObject initializedInstance class == UndefinedObject).!
Item was added:
+ ----- Method: UndefinedObjectTest>>testIsEmptyOrNil (in category 'tests - testing') -----
+ testIsEmptyOrNil
+
+ self assert: (nil isEmptyOrNil).!
Item was added:
+ ----- Method: UndefinedObjectTest>>testIsLiteral (in category 'tests - testing') -----
+ testIsLiteral
+
+ self assert: (nil isLiteral).!
Item was added:
+ ----- Method: UndefinedObjectTest>>testIsNil (in category 'tests - testing') -----
+ testIsNil
+
+ self assert: nil isNil!
Item was added:
+ ----- Method: UndefinedObjectTest>>testNew (in category 'tests - Class Methods') -----
+ testNew
+
+ self should: [ UndefinedObject new] raise: Error.!
Item was added:
+ ----- Method: UndefinedObjectTest>>testNotNil (in category 'tests - testing') -----
+ testNotNil
+
+ self deny: nil notNil!
Item was added:
+ ----- Method: UndefinedObjectTest>>testPrintOn (in category 'tests - printing') -----
+ testPrintOn
+
+ | string |
+ string := String streamContents: [:stream | nil printOn: stream].
+ self assert: (string = 'nil').!
Item was added:
+ ----- Method: UndefinedObjectTest>>testShallowCopy (in category 'tests - copying') -----
+ testShallowCopy
+
+ self assert: (nil shallowCopy = nil).!
Item was added:
+ ----- Method: UndefinedObjectTest>>testStoreOn (in category 'tests - printing') -----
+ testStoreOn
+
+ | string |
+ string := String streamContents: [:stream | nil storeOn: stream].
+ self assert: ((Compiler evaluate: string) = nil).!
Item was added:
+ ----- Method: UndefinedObjectTest>>testVeryDeepCopyWith (in category 'tests - copying') -----
+ testVeryDeepCopyWith
+
+ self assert: ((nil veryDeepCopyWith: nil) = nil).!
Item was added:
+ ClassTestCase subclass: #WeakMessageSendTest
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'KernelTests-Objects'!
Item was added:
+ ----- Method: WeakMessageSendTest>>testNoArguments (in category 'tests') -----
+ testNoArguments
+ "self run: #testNoArguments"
+
+ | m |
+ m := WeakMessageSend
+ receiver: true
+ selector: #yourself.
+ self assert: (m value).
+ !
Item was added:
+ ----- Method: WeakMessageSendTest>>testOneArgument (in category 'tests') -----
+ testOneArgument
+ "self run: #testOneArgument"
+
+ | m |
+ m := WeakMessageSend
+ receiver: Array
+ selector: #with:
+ argument: 1.
+ Smalltalk garbageCollectMost.
+ self assert: (m value = { 1 })
+ !
Item was added:
+ ----- Method: WeakMessageSendTest>>testOneArgumentWithGC (in category 'tests') -----
+ testOneArgumentWithGC
+
+ | m |
+ m := WeakMessageSend
+ receiver: Array
+ selector: #with:
+ arguments: { Object new }.
+ Smalltalk garbageCollectMost.
+ self assert: (m value isNil)!
Item was added:
+ ----- Method: WeakMessageSendTest>>testReceiverWithGC (in category 'tests') -----
+ testReceiverWithGC
+
+ | m |
+ m := WeakMessageSend
+ receiver: Object new
+ selector: #isNil.
+ Smalltalk garbageCollectMost.
+ self assert: (m value isNil).!
Item was added:
+ ----- Method: WeakMessageSendTest>>testTwoArguments (in category 'tests') -----
+ testTwoArguments
+
+ | m |
+ m := WeakMessageSend
+ receiver: Array
+ selector: #with:with:
+ arguments: { 1 . 2 }.
+ Smalltalk garbageCollectMost.
+ self assert: (m value = { 1 . 2 }).
+ !
Item was added:
+ Object subclass: #WriteBarrierAnotherStub
+ instanceVariableNames: 'var1 var2 var3 var4 var5 var6 var7 var8 var9 var10'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'KernelTests-WriteBarrier'!
Item was added:
+ ----- Method: WriteBarrierAnotherStub>>var1 (in category 'accessing') -----
+ var1
+ ^ var1!
Item was added:
+ ----- Method: WriteBarrierAnotherStub>>var10 (in category 'accessing') -----
+ var10
+ ^ var10!
Item was added:
+ ----- Method: WriteBarrierAnotherStub>>var10: (in category 'accessing') -----
+ var10: anObject
+ var10 := anObject!
Item was added:
+ ----- Method: WriteBarrierAnotherStub>>var1: (in category 'accessing') -----
+ var1: anObject
+ var1 := anObject!
Item was added:
+ Object subclass: #WriteBarrierStub
+ instanceVariableNames: 'var1 var2 var3 var4 var5 var6 var7 var8 var9 var10'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'KernelTests-WriteBarrier'!
Item was added:
+ ----- Method: WriteBarrierStub>>var1 (in category 'accessing') -----
+ var1
+ ^ var1!
Item was added:
+ ----- Method: WriteBarrierStub>>var10 (in category 'accessing') -----
+ var10
+ ^ var10!
Item was added:
+ ----- Method: WriteBarrierStub>>var10: (in category 'accessing') -----
+ var10: anObject
+ var10 := anObject!
Item was added:
+ ----- Method: WriteBarrierStub>>var1: (in category 'accessing') -----
+ var1: anObject
+ var1 := anObject!
Item was added:
+ TestCase subclass: #WriteBarrierTest
+ instanceVariableNames: ''
+ classVariableNames: 'ContextInstance'
+ poolDictionaries: ''
+ category: 'KernelTests-WriteBarrier'!
+
+ !WriteBarrierTest commentStamp: '' prior: 0!
+ My tests ensure the ReadOnly property of objects work properly.
+
+ #testMutateIVObject is a good start to understand what is going on.
+
+ The VM needs to be compiled with -DIMMUTABILTY= true for those tests to work.!
Item was added:
+ ----- Method: WriteBarrierTest class>>initialize (in category 'initialization') -----
+ initialize
+
+ ContextInstance := Context sender: nil receiver: self new method: self >> #alwaysWritableObjects arguments: #()!
Item was added:
+ ----- Method: WriteBarrierTest>>alwaysReadOnlyObjects (in category 'guinea pigs') -----
+ alwaysReadOnlyObjects
+ "Immediates are always immutable"
+ ^ { 1 }!
Item was added:
+ ----- Method: WriteBarrierTest>>alwaysWritableObjects (in category 'guinea pigs') -----
+ alwaysWritableObjects
+ "Objects that currently can't be immutable"
+ ^ { ContextInstance .
+ Processor .
+ Processor activeProcess }!
Item was added:
+ ----- Method: WriteBarrierTest>>expectedFailures (in category 'expected failures') -----
+ expectedFailures
+ Smalltalk supportsReadOnlyObjects ifFalse:
+ [^self class testSelectors].
+ ^#( testMutateByteArrayUsingDoubleAtPut testMutateByteArrayUsingFloatAtPut ),
+ (self mirrorPrimitives
+ ifNil: [#(testBasicProxyReadOnly testBasicProxyWritable testSetIsReadOnlySuccessProxy)]
+ ifNotNil: [#()])!
Item was added:
+ ----- Method: WriteBarrierTest>>maybeReadOnlyObjects (in category 'guinea pigs') -----
+ maybeReadOnlyObjects
+ "ByteObject, Variable object, fixed sized object"
+ ^ { { 1 . 2 . 3 } asByteArray . { 1 . 2 . 3 } . (MessageSend receiver: 1 selector: #+ argument: 2) }!
Item was added:
+ ----- Method: WriteBarrierTest>>mirrorPrimitives (in category 'tests - helper') -----
+ mirrorPrimitives
+
+ ^Smalltalk classNamed: #MirrorPrimitives!
Item was added:
+ ----- Method: WriteBarrierTest>>testAttemptToMutateLiterals (in category 'tests - object') -----
+ testAttemptToMutateLiterals
+ | guineaPigs |
+ guineaPigs := {#[1 2 3] . #(1 2 3) }.
+ guineaPigs do:
+ [ :guineaPig |
+ self should: [guineaPig at: 1 put: 4]
+ raise: ModificationForbidden].
+
+ self should: [guineaPigs first become: guineaPigs second ]
+ raise: ModificationForbidden.
+
+ self should: [ByteString adoptInstance: guineaPigs first]
+ raise: ModificationForbidden.
+
+ self should: [WeakArray adoptInstance: guineaPigs last]
+ raise: ModificationForbidden!
Item was added:
+ ----- Method: WriteBarrierTest>>testBasicProxyReadOnly (in category 'tests - proxy') -----
+ testBasicProxyReadOnly
+ self alwaysReadOnlyObjects do: [ :each |
+ self assert: (self mirrorPrimitives isObjectReadOnly: each) equals: true ]!
Item was added:
+ ----- Method: WriteBarrierTest>>testBasicProxyWritable (in category 'tests - proxy') -----
+ testBasicProxyWritable
+ self alwaysWritableObjects , self maybeReadOnlyObjects do: [ :each |
+ self assert: (self mirrorPrimitives isObjectReadOnly: each) equals: false ]!
Item was added:
+ ----- Method: WriteBarrierTest>>testBasicReadOnly (in category 'tests - object') -----
+ testBasicReadOnly
+ self alwaysReadOnlyObjects do: [ :each |
+ self assert: each isReadOnlyObject equals: true ]!
Item was added:
+ ----- Method: WriteBarrierTest>>testBasicWritable (in category 'tests - object') -----
+ testBasicWritable
+ self alwaysWritableObjects , self maybeReadOnlyObjects do: [ :each |
+ self assert: each isReadOnlyObject equals: false ]!
Item was added:
+ ----- Method: WriteBarrierTest>>testBecomeReadOnly (in category 'tests - object') -----
+ testBecomeReadOnly
+ | readOnlyArrays readOnlyByteArrays |
+ readOnlyArrays := (1 to: 3) collect: [:n| (0 to: n) asArray beReadOnlyObject; yourself].
+ "N.B. if the targets are read-only this fails, which is correct for elementsForwardIdentityTo: since copyHash is implicitly true;
+ we need to write a test for a putative elementsForwardIdentityNoCopyHashTo:"
+ readOnlyByteArrays := (1 to: 3) collect: [:n| (0 to: n) asByteArray" beReadOnlyObject; yourself"].
+ self should: [readOnlyArrays elementsForwardIdentityTo: readOnlyByteArrays]
+ raise: ModificationForbidden.
+ [readOnlyArrays elementsForwardIdentityTo: readOnlyByteArrays]
+ on: ModificationForbidden
+ do: [:ex|
+ false
+ ifTrue: "This fails, but should succeed. I *think* it's to do with catching signals when resignalling"
+ [(ex mirror detect: [:element| element isReadOnlyObject] ifNone: []) ifNotNil:
+ [:readOnlyObj| readOnlyObj beWritableObject]]
+ ifFalse:
+ [ex mirror do: [:element| element beWritableObject]].
+ ex retryModification].
+ self assert: (readOnlyArrays allSatisfy: [:array| array class == ByteArray])!
Item was added:
+ ----- Method: WriteBarrierTest>>testMutateByteArrayUsingByteAtPut (in category 'tests - object') -----
+ testMutateByteArrayUsingByteAtPut
+ | guineaPig |
+ guineaPig := ByteArray new: 5.
+ guineaPig beReadOnlyObject.
+
+ self
+ should: [ guineaPig byteAt: 1 put: 12 ]
+ raise: ModificationForbidden.
+
+ [ guineaPig byteAt: 1 put: 12 ]
+ on: ModificationForbidden
+ do: [:modification |
+ self assert: modification fieldIndex equals: 1.
+ modification object beWritableObject.
+ modification retryModification ].
+
+ self assert: guineaPig first equals: 12.
+ self deny: guineaPig isReadOnlyObject.
+
+ guineaPig beReadOnlyObject.
+ self
+ should: [ guineaPig byteAt: 1 put: 13 ]
+ raise: ModificationForbidden.
+
+ [ guineaPig byteAt: 1 put: 13 ]
+ on: ModificationForbidden
+ do: [ :modification |
+ modification object beWritableObject.
+ modification retryModificationNoResume.
+ modification object beReadOnlyObject.
+ modification resume].
+
+ self assert: guineaPig first equals: 13.
+ self assert: guineaPig isReadOnlyObject!
Item was added:
+ ----- Method: WriteBarrierTest>>testMutateByteArrayUsingDoubleAtPut (in category 'tests - object') -----
+ testMutateByteArrayUsingDoubleAtPut
+ | guineaPig |
+ guineaPig := ByteArray new: 8.
+ guineaPig beReadOnlyObject.
+
+ self
+ should: [ guineaPig doubleAt: 1 put: (2 raisedTo: 65) asFloat ]
+ raise: ModificationForbidden.
+
+ [ guineaPig doubleAt: 1 put: (2 raisedTo: 65) asFloat ]
+ on: ModificationForbidden
+ do: [:modification |
+ self assert: modification fieldIndex equals: 1.
+ modification object beWritableObject.
+ modification retryModification ].
+
+ self assert: guineaPig first equals: (2 raisedTo: 65) asFloat.
+ self deny: guineaPig isReadOnlyObject.
+
+ guineaPig beReadOnlyObject.
+ self
+ should: [ guineaPig doubleAt: 1 put: (2 raisedTo: 64) asFloat ]
+ raise: ModificationForbidden.
+
+ [ guineaPig doubleAt: 1 put: (2 raisedTo: 64) asFloat ]
+ on: ModificationForbidden
+ do: [ :modification |
+ modification object beWritableObject.
+ modification retryModificationNoResume.
+ modification object beReadOnlyObject.
+ modification resume].
+
+ self assert: guineaPig first equals: (2 raisedTo: 64) asFloat.
+ self assert: guineaPig isReadOnlyObject!
Item was added:
+ ----- Method: WriteBarrierTest>>testMutateByteArrayUsingFloatAtPut (in category 'tests - object') -----
+ testMutateByteArrayUsingFloatAtPut
+ | guineaPig |
+ guineaPig := ByteArray new: 5.
+ guineaPig beReadOnlyObject.
+
+ self
+ should: [ guineaPig floatAt: 1 put: 1.0 ]
+ raise: ModificationForbidden.
+
+ [ guineaPig floatAt: 1 put: 1.0 ]
+ on: ModificationForbidden
+ do: [:modification |
+ self assert: modification fieldIndex equals: 1.
+ modification object beWritableObject.
+ modification retryModification ].
+
+ self assert: guineaPig first equals: 1.0.
+ self deny: guineaPig isReadOnlyObject.
+
+ guineaPig beReadOnlyObject.
+
+ self
+ should: [ guineaPig floatAt: 1 put: 2.0 ]
+ raise: ModificationForbidden.
+
+ [ guineaPig floatAt: 1 put: 2.0 ]
+ on: ModificationForbidden
+ do: [:modification |
+ self assert: modification fieldIndex equals: 1.
+ modification object beWritableObject.
+ modification retryModificationNoResume.
+ modification object beReadOnlyObject.
+ modification resume].
+
+ self assert: guineaPig first equals: 2.0.
+ self assert: guineaPig isReadOnlyObject!
Item was added:
+ ----- Method: WriteBarrierTest>>testMutateByteStringyUsingAtPut (in category 'tests - object') -----
+ testMutateByteStringyUsingAtPut
+ | guineaPig |
+ guineaPig := ByteString new: 5.
+ guineaPig beReadOnlyObject.
+
+ self
+ should: [ guineaPig at: 1 put: $h ]
+ raise: ModificationForbidden.
+
+ [ guineaPig at: 1 put: $h ]
+ on: ModificationForbidden
+ do: [:modification |
+ self assert: modification fieldIndex equals: 1.
+ modification object beWritableObject.
+ modification retryModification ].
+
+ self assert: guineaPig first equals: $h.
+ self deny: guineaPig isReadOnlyObject.
+
+ guineaPig beReadOnlyObject.
+
+ self
+ should: [ guineaPig at: 1 put: $g ]
+ raise: ModificationForbidden.
+
+ [ guineaPig at: 1 put: $g ]
+ on: ModificationForbidden
+ do: [:modification |
+ self assert: modification fieldIndex equals: 1.
+ modification object beWritableObject.
+ modification retryModificationNoResume.
+ modification object beReadOnlyObject.
+ modification resume ].
+
+ self assert: guineaPig first equals: $g.
+ self assert: guineaPig isReadOnlyObject!
Item was added:
+ ----- Method: WriteBarrierTest>>testMutateByteStringyUsingByteAtPut (in category 'tests - object') -----
+ testMutateByteStringyUsingByteAtPut
+ | guineaPig |
+ guineaPig := ByteString new: 5.
+ guineaPig beReadOnlyObject.
+
+ self
+ should: [ guineaPig byteAt: 1 put: 100 ]
+ raise: ModificationForbidden.
+
+ [ guineaPig byteAt: 1 put: 100 ]
+ on: ModificationForbidden
+ do: [:modification |
+ self assert: modification fieldIndex equals: 1.
+ modification object beWritableObject.
+ modification retryModification ].
+
+ self assert: guineaPig first asciiValue equals: 100!
Item was added:
+ ----- Method: WriteBarrierTest>>testMutateIVObject (in category 'tests - object') -----
+ testMutateIVObject
+ | guineaPig |
+ guineaPig := MessageSend new.
+ guineaPig beReadOnlyObject.
+ [ guineaPig receiver: 1 ]
+ on: ModificationForbidden
+ do: [ :modification | "Surely a NoModification error" ].
+ guineaPig
+ beWritableObject;
+ selector: #+;
+ beReadOnlyObject.
+ [ guineaPig arguments: #(2) ]
+ on: ModificationForbidden
+ do: [ :modification |"Surely a NoModification error" ].
+ self assert: guineaPig receiver isNil.
+ self assert: guineaPig arguments isNil.
+ self assert: guineaPig selector == #+.!
Item was added:
+ ----- Method: WriteBarrierTest>>testMutateObjectClass (in category 'tests - object') -----
+ testMutateObjectClass
+ | guineaPig |
+ guineaPig := WriteBarrierStub new.
+ guineaPig beReadOnlyObject.
+
+ self
+ should: [ guineaPig primitiveChangeClassTo: WriteBarrierAnotherStub new ]
+ raise: ModificationForbidden.
+
+ [ guineaPig primitiveChangeClassTo: WriteBarrierAnotherStub new ]
+ on: ModificationForbidden
+ do: [ :modification |
+ modification object beWritableObject.
+ modification retryModification ].
+
+ self assert: guineaPig class equals: WriteBarrierAnotherStub!
Item was added:
+ ----- Method: WriteBarrierTest>>testMutateObjectClassViaAdoption (in category 'tests - object') -----
+ testMutateObjectClassViaAdoption
+ | guineaPig |
+ guineaPig := WriteBarrierStub new.
+ guineaPig beReadOnlyObject.
+
+ self
+ should: [ WriteBarrierAnotherStub adoptInstance: guineaPig ]
+ raise: ModificationForbidden.
+
+ [ WriteBarrierAnotherStub adoptInstance: guineaPig ]
+ on: ModificationForbidden
+ do: [ :modification |
+ modification object beWritableObject.
+ modification retryModification ].
+
+ self assert: guineaPig class equals: WriteBarrierAnotherStub.
+ self deny: guineaPig isReadOnlyObject.
+
+ guineaPig beReadOnlyObject.
+ self
+ should: [ WriteBarrierAnotherStub adoptInstance: guineaPig ]
+ raise: ModificationForbidden.
+
+ [ WriteBarrierAnotherStub adoptInstance: guineaPig ]
+ on: ModificationForbidden
+ do: [ :modification |
+ modification object beWritableObject.
+ modification retryModificationNoResume.
+ modification object beReadOnlyObject.
+ modification resume].
+
+ self assert: guineaPig class equals: WriteBarrierAnotherStub.
+ self assert: guineaPig isReadOnlyObject!
Item was added:
+ ----- Method: WriteBarrierTest>>testMutateObjectFirstInstVarWithManyVars (in category 'tests - object') -----
+ testMutateObjectFirstInstVarWithManyVars
+ | guineaPig failure |
+ guineaPig := WriteBarrierStub new.
+ guineaPig beReadOnlyObject.
+ failure := [ guineaPig var1: #test ] on: ModificationForbidden do: [:err | err].
+
+ self assert: failure fieldIndex equals: 1!
Item was added:
+ ----- Method: WriteBarrierTest>>testMutateObjectInstVarShouldCatchRightFailure (in category 'tests - object') -----
+ testMutateObjectInstVarShouldCatchRightFailure
+ | guineaPig failure |
+ guineaPig := MessageSend new.
+ guineaPig beReadOnlyObject.
+ failure := [ guineaPig receiver: #test ] on: ModificationForbidden do: [:err | err].
+
+ self assert: failure object == guineaPig.
+ self assert: failure newValue equals: #test.
+ self assert: failure fieldIndex equals: 1.!
Item was added:
+ ----- Method: WriteBarrierTest>>testMutateObjectInstVarUsingAtPut (in category 'tests - object') -----
+ testMutateObjectInstVarUsingAtPut
+ | guineaPig |
+ guineaPig := Array new: 5.
+ guineaPig beReadOnlyObject.
+
+ self
+ should: [ guineaPig at: 1 put: #test ]
+ raise: ModificationForbidden.
+
+ [ guineaPig at: 1 put: #test ]
+ on: ModificationForbidden
+ do: [:modification |
+ self assert: modification fieldIndex equals: 1.
+ modification object beWritableObject.
+ modification retryModification ].
+
+ self assert: guineaPig first equals: #test.
+ self deny: guineaPig isReadOnlyObject.
+
+ guineaPig beReadOnlyObject.
+
+ self
+ should: [ guineaPig at: 1 put: #test ]
+ raise: ModificationForbidden.
+
+ [ guineaPig at: 1 put: #test ]
+ on: ModificationForbidden
+ do: [:modification |
+ self assert: modification fieldIndex equals: 1.
+ modification object beWritableObject.
+ modification retryModificationNoResume.
+ modification object beReadOnlyObject.
+ modification resume ].
+
+ self assert: guineaPig first equals: #test.
+ self assert: guineaPig isReadOnlyObject
+ !
Item was added:
+ ----- Method: WriteBarrierTest>>testMutateObjectInstVarUsingBasicAtPut (in category 'tests - object') -----
+ testMutateObjectInstVarUsingBasicAtPut
+ | guineaPig |
+ guineaPig := Array new: 5.
+ guineaPig beReadOnlyObject.
+
+ self
+ should: [ guineaPig basicAt: 1 put: #test ]
+ raise: ModificationForbidden.
+
+ [ guineaPig basicAt: 1 put: #test ]
+ on: ModificationForbidden
+ do: [:modification |
+ self assert: modification fieldIndex equals: 1.
+ modification object beWritableObject.
+ modification retryModification ].
+
+ self assert: guineaPig first equals: #test!
Item was added:
+ ----- Method: WriteBarrierTest>>testMutateObjectInstVarUsingInstVarAtPut (in category 'tests - object') -----
+ testMutateObjectInstVarUsingInstVarAtPut
+ | guineaPig |
+ guineaPig := WriteBarrierStub new.
+ guineaPig beReadOnlyObject.
+
+ self
+ should: [ guineaPig instVarAt: 1 put: #test ]
+ raise: ModificationForbidden.
+
+ [ guineaPig instVarAt: 1 put: #test ]
+ on: ModificationForbidden
+ do: [:modification |
+ self assert: modification fieldIndex equals: 1.
+ modification object beWritableObject.
+ modification retryModification ].
+
+ self assert: guineaPig var1 equals: #test!
Item was added:
+ ----- Method: WriteBarrierTest>>testMutateObjectLastInstVarWithManyVars (in category 'tests - object') -----
+ testMutateObjectLastInstVarWithManyVars
+ | guineaPig failure |
+ guineaPig := WriteBarrierStub new.
+ guineaPig beReadOnlyObject.
+ failure := [ guineaPig var10: #test ] on: ModificationForbidden do: [:err | err].
+
+ self assert: failure fieldIndex equals: 10!
Item was added:
+ ----- Method: WriteBarrierTest>>testMutateVariableObject (in category 'tests - object') -----
+ testMutateVariableObject
+ | guineaPigs |
+ guineaPigs := {#[1 2 3] . #(1 2 3) }.
+ guineaPigs do: [ :guineaPig |
+ guineaPig beReadOnlyObject.
+ [guineaPig at: 1 put: 4]
+ on: ModificationForbidden
+ do: [ "Surely a NoModification error" ].
+ guineaPig
+ beWritableObject;
+ at: 2 put: 5;
+ beReadOnlyObject.
+ [guineaPig at: 3 put: 6]
+ on: ModificationForbidden
+ do: [ "Surely a NoModification error" ].
+ self assert: guineaPig first = 1.
+ self assert: guineaPig second = 5.
+ self assert: guineaPig third = 3 ]!
Item was added:
+ ----- Method: WriteBarrierTest>>testMutateWideStringUsingAtPut (in category 'tests - object') -----
+ testMutateWideStringUsingAtPut
+ | guineaPig |
+ guineaPig := 'hello' asWideString.
+ guineaPig beReadOnlyObject.
+
+ self
+ should: [ guineaPig at: 1 put: $q ]
+ raise: ModificationForbidden.
+
+ [ guineaPig at: 1 put: $q ]
+ on: ModificationForbidden
+ do: [:modification |
+ self assert: modification fieldIndex equals: 1.
+ modification object beWritableObject.
+ modification retryModification ].
+
+ self assert: guineaPig first equals: $q!
Item was added:
+ ----- Method: WriteBarrierTest>>testMutateWideStringUsingWordAtPut (in category 'tests - object') -----
+ testMutateWideStringUsingWordAtPut
+ | guineaPig |
+ guineaPig := 'hello' asWideString.
+ guineaPig beReadOnlyObject.
+
+ self
+ should: [ guineaPig wordAt: 1 put: 65536 ]
+ raise: ModificationForbidden.
+
+ [ guineaPig wordAt: 1 put: 65536 ]
+ on: ModificationForbidden
+ do: [:modification |
+ self assert: modification fieldIndex equals: 1.
+ modification object beWritableObject.
+ modification retryModification ].
+
+ self assert: guineaPig first asciiValue equals: 65536!
Item was added:
+ ----- Method: WriteBarrierTest>>testObject:initialState:tuples: (in category 'tests - helper') -----
+ testObject: object initialState: initialState tuples: tuples
+ self
+ testObject: object
+ initialState: initialState
+ tuples: tuples
+ setReadOnlyBlock: [ :value | object setIsReadOnlyObject: value ]!
Item was added:
+ ----- Method: WriteBarrierTest>>testObject:initialState:tuples:setReadOnlyBlock: (in category 'tests - helper') -----
+ testObject: object initialState: initialState tuples: tuples setReadOnlyBlock: setImmutabilityBlock
+ self assert: object isReadOnlyObject equals: initialState.
+ tuples do: [ :tuple |
+ | stateToSet expectedResult expectedNewState |
+ stateToSet := tuple first.
+ expectedResult := tuple second.
+ expectedNewState := tuple last.
+ [self assert: (setImmutabilityBlock value: stateToSet) equals: expectedResult ]
+ on: ((Smalltalk classNamed: #PrimitiveFailed) ifNil: [Error])
+ do: [ self assert: (self alwaysReadOnlyObjects , self alwaysWritableObjects includes: object) ].
+ self assert: object isReadOnlyObject equals: expectedNewState ]!
Item was added:
+ ----- Method: WriteBarrierTest>>testProxyObject:initialState:tuples: (in category 'tests - helper') -----
+ testProxyObject: object initialState: initialState tuples: tuples
+ self
+ testObject: object
+ initialState: initialState
+ tuples: tuples
+ setReadOnlyBlock: [ :value |
+ self mirrorPrimitives makeObject: object readOnly: value ]!
Item was added:
+ ----- Method: WriteBarrierTest>>testRetryingInstVarModification (in category 'tests - object') -----
+ testRetryingInstVarModification
+ | guineaPig |
+ guineaPig := MessageSend new.
+ guineaPig beReadOnlyObject.
+
+ [ guineaPig receiver: 1 ] on: ModificationForbidden do: [:err |
+ guineaPig beWritableObject.
+ err retryModification ].
+
+ self assert: guineaPig receiver equals: 1!
Item was added:
+ ----- Method: WriteBarrierTest>>testRetryingPointInstVarModification (in category 'tests - object') -----
+ testRetryingPointInstVarModification
+ | guineaPig labRat |
+ guineaPig := 1@2.
+ labRat := guineaPig copy bitShiftPoint: 3.
+ guineaPig beReadOnlyObject.
+
+ [ guineaPig bitShiftPoint: 3 ]
+ on: ModificationForbidden
+ do: [:err |
+ guineaPig beWritableObject.
+ err retryModification ].
+
+ self assert: guineaPig equals: labRat.
+ self deny: guineaPig isReadOnlyObject.
+
+ guineaPig bitShiftPoint: -3; beReadOnlyObject.
+ self assert: guineaPig equals: 1@2.
+
+ [ guineaPig bitShiftPoint: 3 ]
+ on: ModificationForbidden
+ do: [:err |
+ guineaPig beWritableObject.
+ err retryModificationNoResume.
+ guineaPig beReadOnlyObject.
+ err resume ].
+
+ self assert: guineaPig equals: labRat.
+ self assert: guineaPig isReadOnlyObject!
Item was added:
+ ----- Method: WriteBarrierTest>>testSetIsReadOnlyFailure (in category 'tests - object') -----
+ testSetIsReadOnlyFailure
+ self alwaysWritableObjects do: [ :each |
+ self
+ testObject: each
+ initialState: false
+ tuples: #( (true false false) (false false false) ) ]!
Item was added:
+ ----- Method: WriteBarrierTest>>testSetIsReadOnlyFailureProxy (in category 'tests - proxy') -----
+ testSetIsReadOnlyFailureProxy
+ self alwaysWritableObjects do: [ :each |
+ self
+ testProxyObject: each
+ initialState: false
+ tuples: #( (true false false) (false false false) ) ]!
Item was added:
+ ----- Method: WriteBarrierTest>>testSetIsReadOnlyImmediate (in category 'tests - object') -----
+ testSetIsReadOnlyImmediate
+ self alwaysReadOnlyObjects do: [ :each |
+ self
+ testObject: each
+ initialState: true
+ tuples: #( (true true true) (false true true) ) ]!
Item was added:
+ ----- Method: WriteBarrierTest>>testSetIsReadOnlyImmediateProxy (in category 'tests - proxy') -----
+ testSetIsReadOnlyImmediateProxy
+ self alwaysReadOnlyObjects do: [ :each |
+ self
+ testProxyObject: each
+ initialState: true
+ tuples: #( (true true true) (false true true) ) ]!
Item was added:
+ ----- Method: WriteBarrierTest>>testSetIsReadOnlySuccess (in category 'tests - object') -----
+ testSetIsReadOnlySuccess
+ self maybeReadOnlyObjects do: [ :each |
+ self
+ testObject: each
+ initialState: false
+ tuples: #( (true false true) (false true false) ) ]!
Item was added:
+ ----- Method: WriteBarrierTest>>testSetIsReadOnlySuccessProxy (in category 'tests - proxy') -----
+ testSetIsReadOnlySuccessProxy
+ self maybeReadOnlyObjects do: [ :each |
+ self
+ testProxyObject: each
+ initialState: false
+ tuples: #( (true false true) (false true false) ) ]!
1
0