Packages May 2022

packages@lists.squeakfoundation.org

1 participants
142 discussions

The Trunk: Kernel-mt.1471.mcz
by commits＠source.squeak.org 30 May '22

30 May '22

Marcel Taeumel uploaded a new version of Kernel to project The Trunk: http://source.squeak.org/trunk/Kernel-mt.1471.mcz ==================== Summary ==================== Name: Kernel-mt.1471 Author: mt Time: 30 May 2022, 5:26:05.189291 pm UUID: 7f39e643-816d-8b47-8b91-dee1f1de18fb Ancestors: Kernel-dtl.1468, Kernel-jar.1470 Merge Kernel-jar.1468: Update to accommodate the new suspend semantics using primitives 568 and 578. Use new suspend primitive 579 but 568 could be used as well if preferred. The old primitive 88 has been moved to #suspendAndUnblock for convenience and backward compatibiity. Update #terminate to be able to unblock and terminate processes being blocked on a condition variable. This minimum set of changes is partly compatible with older VMs with only suspend primitive 88. For improved compatibility with older VMs #isTerminated would require to be updated as well. =============== Diff against Kernel-dtl.1468 =============== Item was added: + ----- Method: Context>>runUntilReturnFrom: (in category 'private-exceptions') ----- + runUntilReturnFrom: aContext + "Run the receiver (which must be its stack top context) until aContext returns. Avoid a context that cannot return. + Note: to avoid infinite recursion of MNU error inside unwind blocks, implement e.g. a wrapper around the message + sentTo: receiver in #doesNotUnderstand:. Note: This method is a trivialized version of #runUntilErrorOrReturnFrom: + and was intended to be used by #unwindTo as a helper method to unwind non-local returns inside unwind blocks." + + | here unwindBottom newTop | + here := thisContext. + "Avoid a context that cannot return (see Note 1 below)" + unwindBottom := (self findContextSuchThat: [:ctx | ctx selector = #cannotReturn:]) ifNil: [aContext]. + newTop := aContext sender. + "Insert ensure context under unwindBottom in self's stack (see Note 2 below)" + unwindBottom insertSender: (Context contextEnsure: [here jump]). + self jump. "Control jumps to the receiver's stack (see Note 2 below)" + "Control resumes here once the above inserted ensure block is executed (see #jump comments)" + ^newTop "Return the new top context (see Note 3 below)" + + "Note 1: returning from #cannotReturn's sender would crash the VM so we install a guard ensure context right + above it; after returning here the unwind will continue safely. Try running and debugging this example + (avoid Proceeding the BCR error though; it may indeed crash the image): + [[[] ensure: [^2]] ensure: [^42]] fork" + + "Note 2: the receiver (self) is run by jumping directly to it (the active process abandons thisContext and executes + self on its own stack; self must be its top context). However, before jumping to self we insert an ensure block under + unwindBottom context that will execute a jump back to thisContext when evaluated. The inserted guard ensure + context is removed once control jumps back to thisContext." + + "Note 3: it doesn't matter newTop is not a proper stack top context because #unwindTo will only use it as a starting + point in the search for the next unwind context and the computation will never return here. We could make newTop + a proper top context by pushing nil to its stack (^newTop push: nil) if need be (see #jump comments). + Cf. the pattern in #runUntilErrorOrReturnFrom:: removing the inserted ensure context by stepping until popped + when executing non-local returns wouldn't work here and would fail tests testTerminateInNestedEnsureWithReturn1 + through 4."! Item was changed: ----- Method: Context>>unwindTo: (in category 'private-exceptions') ----- unwindTo: aContext + "Unwind the receiver to aContext to execute all pending unwind blocks." + self unwindTo: aContext safely: true! - | ctx unwindBlock | - ctx := self. - [(ctx := ctx findNextUnwindContextUpTo: aContext) isNil] whileFalse: [ - (ctx tempAt: 2) ifNil:[ - ctx tempAt: 2 put: true. - unwindBlock := ctx tempAt: 1. - unwindBlock value] - ]. - ! Item was added: + ----- Method: Context>>unwindTo:safely: (in category 'private-exceptions') ----- + unwindTo: aContext safely: aBoolean + "Unwind self to aContext to execute pending #ensure:/#ifCurtailed: argument blocks between self + and aContext. If aBoolean is false, unwind only blocks that have not run yet, otherwise complete all + pending unwind blocks including those currently in the middle of their execution; these blocks will + just finish their execution. Run all unwinds on their original stack using #runUntilReturnFrom:." + + | top ctx | + ctx := top := self. + aBoolean ifTrue: [ + "If self is a top context of a stack already halfways through an unwind, complete the outer-most + unfinished unwind block first; all nested pending unwind blocks will be completed in the process; + see testTerminationDuringUnwind and tests in ProcessTest/UnwindTest. + Note: Halfway-through blocks have already set the complete variable (ctxt tempAt: 2) in their + defining #ensure:/#ifCurtailed contexts from nil to true; we'll search for the bottom-most one." + | outerMost | + ctx isUnwindContext ifFalse: [ctx := ctx findNextUnwindContextUpTo: aContext]. + [ctx isNil] whileFalse: [ + (ctx tempAt:2) ifNotNil: [ + outerMost := ctx]. + ctx := ctx findNextUnwindContextUpTo: aContext]. + outerMost ifNotNil: [top := (top runUntilReturnFrom: outerMost) sender]]. + "By now no halfway-through unwind blocks are on the stack. + Note: top points to the former outerMost sender now, i.e. to the next context to be explored." + + ctx := top. + "#findNextUnwindContextUpTo: starts searching from the receiver's sender so we must check + the receiver explicitly whether it is an unwind context; see testTerminateEnsureAsStackTop. + Create a new top context (i.e. a new branch off the original stack) for each pending unwind block + (ctxt tempAt: 1) and execute it on the unwind block's stack to evaluate non-local returns correctly." + ctx isUnwindContext ifFalse: [ctx := ctx findNextUnwindContextUpTo: aContext]. + [ctx isNil] whileFalse: [ + (ctx tempAt: 2) ifNil: [ + ctx tempAt: 2 put: true. + top := (ctx tempAt: 1) asContextWithSender: ctx. + top runUntilReturnFrom: top]. + ctx := ctx findNextUnwindContextUpTo: aContext] + "Note: Cf. the unwind pattern in the previous versions of unwindTo: (1999-2021). Using #value + instead of #runUntilReturnFrom: lead to a failure to evaluate some non-local returns correctly; + a non-local return must be evaluated in the evaluation context (sender chain) in which it was defined."! Item was changed: ----- Method: DelayWaitTimeout>>signalWaitingProcess (in category 'signaling') ----- signalWaitingProcess "Release the given process from the semaphore it is waiting on. This method relies on running at highest priority so that it cannot be preempted by the process being released." beingWaitedOn := false. "Release the process but only if it is still waiting on its original list" process suspendingList == delaySemaphore ifTrue:[ expired := true. + process suspendAndUnblock; resume. - process suspend; resume. ]. ! Item was changed: ----- Method: Process>>signalException: (in category 'signaling') ----- signalException: anException "Signal an exception in the receiver process...if the receiver is currently suspended, the exception will get signaled when the receiver is resumed. If the receiver is blocked on a Semaphore, it will be immediately re-awakened and the exception will be signaled; if the exception is resumed, then the receiver will return to a blocked state unless the blocking Semaphore has excess signals" + - | oldList | "If we are the active process, go ahead and signal the exception" + self isActiveProcess ifTrue: [^anException signal]. - self isActiveProcess ifTrue: [^anException signal]. + "Suspend myself first to ensure that I won't run away + in the midst of the following modifications." + self suspend. + suspendedContext := Context + sender: suspendedContext + receiver: anException + method: (anException class lookupSelector: #signal) + arguments: #(). + ^self resume! - "Suspend myself first to ensure that I won't run away in the - midst of the following modifications." - myList ifNotNil:[oldList := self suspend]. - - "Add a new method context to the stack that will signal the exception" - suspendedContext := Context - sender: suspendedContext - receiver: self - method: (self class lookupSelector: #pvtSignal:list:) - arguments: (Array with: anException with: oldList). - - "If we are on a list to run, then suspend and restart the receiver - (this lets the receiver run if it is currently blocked on a semaphore). If - we are not on a list to be run (i.e. this process is suspended), then when the - process is resumed, it will signal the exception" - - oldList ifNotNil: [self resume]! Item was changed: ----- Method: Process>>suspend (in category 'changing process state') ----- suspend + "eem 1/3/2022 10:38: + Primitive. Suspend the receiver, aProcess, such that it can be executed again + by sending #resume. If the given process is not the active process, take it off + its corresponding list. If the list was not its run queue assume it was on some + condition variable (Semaphore, Mutex) and back up its pc to the send that + invoked the wait state the process entered. Hence when the process resumes + it will reenter the wait state. Answer the list the receiver was previously on iff + it was not active and not blocked, otherwise answer nil." + + <primitive: 578 error: ec> + "This is fallback code for VMs which only support the old primitiveSuspend 88. + Note: in this case some tests may fail and some methods assuming the revised + suspend semantics described above may not work entirely as expected (e.g. + Context >> #releaseCriticalSection or Process >> #signalException)." + ^self suspendAndUnblock! - "Primitive. Stop the process that the receiver represents in such a way - that it can be restarted at a later time (by sending the receiver the - message resume). If the receiver represents the activeProcess, suspend it. - Otherwise remove the receiver from the list of waiting processes. - The return value of this method is the list the receiver was previously on (if any)." - | oldList | - <primitive: 88> - "This is fallback code for VMs which only support the old primitiveSuspend which - would not accept processes that are waiting to be run." - myList ifNil:[^nil]. "this allows us to use suspend multiple times" - oldList := myList. - myList := nil. - oldList remove: self ifAbsent:[]. - ^oldList! Item was added: + ----- 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, et al), then the ensure: + block needs to be run." + + | 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]. + + ((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 added: + ----- Method: Process>>suspendAndUnblock (in category 'changing process state') ----- + suspendAndUnblock + "ar 12/7/2007 17:10: + Primitive. Stop the process that the receiver represents in such a way + that it can be restarted at a later time (by sending the receiver the + message resume). If the receiver represents the activeProcess, suspend it. + Otherwise remove the receiver from the list of waiting processes. + The return value of this method is the list the receiver was previously on (if any)." + + <primitive: 88 error: ec> + "ar 12/7/2007 17:10: + This is fallback code for VMs which only support the old primitiveSuspend which + would not accept processes that are waiting to be run." + ^myList ifNotNil: "this allows us to use suspend multiple times" + [:oldList| + myList := nil. + oldList remove: self ifAbsent: []. + oldList]! Item was changed: ----- Method: Process>>terminate (in category 'changing process state') ----- terminate + "Stop the process that the receiver represents forever. + Unwind to execute pending #ensure:/#ifCurtailed: blocks before terminating; + allow all unwind blocks to run; if they are currently in progress, let them finish. + If the process is in the middle of a #critical: critical section, release it properly." + + "This is the kind of behavior we expect when terminating a healthy process. + See further comments in #terminateAggressively and #destroy methods dealing + with process termination when closing the debugger or after a catastrophic failure." + + "If terminating the active process, create a parallel stack and run unwinds from there; + if terminating a suspended process, again, create a parallel stack for the process being + terminated and resume the suspended process to complete its termination from the new + parallel stack. Use a priority higher than the active priority to make the process that + invoked the termination wait for its completion." - "Stop the receiver forever. - Run all unwind contexts (#ensure:/#ifCurtailed: blocks) on the stack, even if they are currently in progress. If already active unwind contexts should not be continued, send #terminateAggressively instead. - Note that ill unwind contexts are theoretically able to stall the termination (for instance, by placing a non-local return in an unwind block); however, this is a disrecommended practice. - If the process is in the middle of a critical section, release it properly." + "If terminating a suspended process (including runnable and blocked), always suspend + the terminating process first so it doesn't accidentally get woken up. Equally important is + the side effect of the suspension; In 2022 a new suspend semantics has been introduced: + the revised #suspend backs up a process waiting on a conditional variable to the send that + invoked the wait state, while the pre-2022 #suspend simply removed the process from + the conditional variable's list it was previously waiting on; see Process>>suspend comments. + 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." + + | context | - | ctxt unwindBlock oldList outerMost | self isActiveProcess ifTrue: [ + context := thisContext. + ^[context unwindTo: nil. self suspend] asContext jump]. - "If terminating the active process, suspend it first and terminate it as a suspended process." - [self terminate] fork. - ^self suspend]. + [] ensure: [ + self suspendAndReleaseCriticalSection. + context := suspendedContext ifNil: [^self]. + suspendedContext := [context unwindTo: nil. self suspend] asContext. + self priority: (Processor activePriority + 1 min: Processor highestPriority); resume]! - "Always suspend the process first so it doesn't accidentally get woken up. - N.B. If oldList is a LinkedList then the process is runnable. If it is a Semaphore/Mutex et al - then the process is blocked, and if it is nil then the process is already suspended." - oldList := self suspend. - suspendedContext ifNotNil: - ["Release any method marked with the <criticalSection> pragma. - The argument is whether the process is runnable." - self releaseCriticalSection: (oldList isNil or: [oldList class == LinkedList]). - - "If terminating a process halfways through an unwind, try to complete that unwind block first; - if there are multiple such nested unwind blocks, try to complete the outer-most one; the inner - blocks will be completed in the process." - ctxt := suspendedContext. - [(ctxt := ctxt findNextUnwindContextUpTo: nil) isNil] whileFalse: - "Contexts under evaluation have already set their complete (tempAt: 2) to true." - [(ctxt tempAt:2) ifNotNil: [outerMost := ctxt]]. - outerMost ifNotNil: [ - "This is the outer-most unwind context currently under evaluation; - let's find an inner context executing outerMost's argument block (tempAt: 1)" - (suspendedContext findContextSuchThat: [:ctx | - ctx closure == (outerMost tempAt: 1)]) ifNotNil: [:inner | - "Let's finish the unfinished unwind context only (i.e. up to inner) and return here" - suspendedContext runUntilErrorOrReturnFrom: inner. - "Update the receiver's suspendedContext (the previous step reset its sender to nil); - return, if the execution stack reached its bottom (e.g. in case of non-local returns)." - (suspendedContext := outerMost sender) ifNil: [^self]]]. - - "Now all unwind blocks caught halfway through have been completed; - let's execute the ones still pending. Note: #findNextUnwindContextUpTo: starts - searching from the receiver's sender but the receiver itself may be an unwind context." - ctxt := suspendedContext. - ctxt isUnwindContext ifFalse: [ctxt := ctxt findNextUnwindContextUpTo: nil]. - [ctxt isNil] whileFalse: [ - (ctxt tempAt: 2) ifNil: [ - ctxt tempAt: 2 put: true. - unwindBlock := ctxt tempAt: 1. - "Create a context for the unwind block and execute it on the unwind block's stack. - Note: using #value instead of #runUntilErrorOrReturnFrom: would lead to executing - the unwind on the wrong stack preventing the correct execution of non-local returns." - suspendedContext := unwindBlock asContextWithSender: ctxt. - suspendedContext runUntilErrorOrReturnFrom: suspendedContext]. - ctxt := ctxt findNextUnwindContextUpTo: nil]. - - "Reset the context's pc and sender to nil for the benefit of isTerminated." - suspendedContext terminate]!

1 0

The Treated Inbox: ToolsTests-jar.105.mcz
by commits＠source.squeak.org 30 May '22

30 May '22

Marcel Taeumel uploaded a new version of ToolsTests to project The Treated Inbox: http://source.squeak.org/treated/ToolsTests-jar.105.mcz ==================== Summary ==================== Name: ToolsTests-jar.105 Author: jar Time: 24 May 2021, 3:14:58.469073 pm UUID: d928e860-c443-7943-820b-8b74e3120013 Ancestors: ToolsTests-nice.104 Complement latest #terminate in the Inbox. Test unwind semantics for nested Unhandled errors aborted via debugger's Abandon (interpreted as terminate). =============== Diff against ToolsTests-nice.104 =============== Item was added: + ----- Method: DebuggerTests>>test19ProcessUnwindsAfterDebuggerClose (in category 'tests') ----- + test19ProcessUnwindsAfterDebuggerClose + "Closing a debugger on a suspended process means terminating that process." + + | x1 x2 x3 x4 | + x1 := x2 := x3 := x4 := false. + process := + [ + [ + [ ] ensure: [ + [self error: 'outer error'] ensure: [ + x1 := true]. + x2 := true] + ] ensure: [ + x3 := true]. + x4 := true + ] fork. + Processor yield. + + "make sure process is suspended and none of the unwind blocks has finished yet" + self assert: process isSuspended. + self deny: x1 | x2 | x3 | x4. + + "now find and close the debugger and make sure all unwind blocks have finished" + self ensureDebugger. + debugger close. + + self assert: process isTerminated. + self assert: x1 & x2 & x3. + self deny: x4! Item was added: + ----- Method: DebuggerTests>>test20ProcessUnwindsAfterDebuggerClose (in category 'tests') ----- + test20ProcessUnwindsAfterDebuggerClose + "Closing a debugger on a suspended process means terminating that process." + + | x1 x2 x3 x4 | + x1 := x2 := x3 := x4 := false. + process := + [ + [ + [ ] ensure: [ + [] ensure: [ + self error: 'inner error'. + x1 := true]. + x2 := true] + ] ensure: [ + x3 := true]. + x4 := true + ] fork. + Processor yield. + + "make sure process is suspended and none of the unwind blocks has finished yet" + self assert: process isSuspended. + self deny: x1 | x2 | x3 | x4. + + "now find and close the debugger and make sure all unwind blocks have finished" + self ensureDebugger. + debugger close. + + self assert: process isTerminated. + self assert: x1 & x2 & x3. + self deny: x4! Item was added: + ----- Method: DebuggerTests>>test21ProcessUnwindsAfterDebuggerClose (in category 'tests') ----- + test21ProcessUnwindsAfterDebuggerClose + "Closing a debugger on a suspended process means terminating that process." + + | x1 x2 x3 x4 | + x1 := x2 := x3 := x4 := false. + process := + [ + [ + [ ] ensure: [ + [self error: 'outer error'] ensure: [ + self error: 'inner error'. + x1 := true]. + x2 := true] + ] ensure: [ + x3 := true]. + x4 := true + ] fork. + Processor yield. + + "make sure process is suspended and none of the unwind blocks has finished yet" + self assert: process isSuspended. + self deny: x1 | x2 | x3 | x4. + + "now find and close the debugger and let the unwind continue to the next error" + self ensureDebugger. + process := [debugger close] fork. + Processor yield. + + "make sure process is suspended and none of the unwind blocks has finished yet" + self assert: process isSuspended. + self deny: x1 | x2 | x3 | x4. + + "now find and close the debugger and make sure all unwind blocks have finished" + self ensureDebugger. + debugger close. + + self assert: process isTerminated. + self assert: x1 & x2 & x3. + self deny: x4! Item was added: + ----- Method: DebuggerTests>>test22ProcessUnwindsAfterDebuggerClose (in category 'tests') ----- + test22ProcessUnwindsAfterDebuggerClose + "Closing a debugger on a suspended process means terminating that process." + + | x1 x2 x3 x4 | + x1 := x2 := x3 := x4 := false. + process := + [ + [ + [self error: 'outer error'] ensure: [ + [self error: 'middle error'] ensure: [ + self error: 'inner error'. + x1 := true]. + x2 := true] + ] ensure: [ + x3 := true]. + x4 := true + ] fork. + Processor yield. + + "make sure process is suspended and none of the unwind blocks has finished yet" + self assert: process isSuspended. + self deny: x1 | x2 | x3 | x4. + + "now find and close the debugger and let the unwind continue to the next error" + self ensureDebugger. + process := [debugger close] fork. + Processor yield. + + "make sure process is suspended and none of the unwind blocks has finished yet" + self assert: process isSuspended. + self deny: x1 | x2 | x3 | x4. + + "now find and close the debugger and let the unwind continue to the next error" + self ensureDebugger. + process := [debugger close] fork. + Processor yield. + + "make sure process is suspended and none of the unwind blocks has finished yet" + self assert: process isSuspended. + self deny: x1 | x2 | x3 | x4. + + "now find and close the debugger and make sure all unwind blocks have finished" + self ensureDebugger. + debugger close. + + self assert: process isTerminated. + self assert: x1 & x2 & x3. + self deny: x4!

1 0

The Treated Inbox: Kernel-jar.1447.mcz
by commits＠source.squeak.org 30 May '22

30 May '22

Marcel Taeumel uploaded a new version of Kernel to project The Treated Inbox: http://source.squeak.org/treated/Kernel-jar.1447.mcz ==================== Summary ==================== Name: Kernel-jar.1447 Author: jar Time: 22 February 2022, 8:18:05.479858 pm UUID: 3772b6a0-c6ab-634c-97bb-a82bda2ecb6a Ancestors: Kernel-eem.1444 #terminate - latest version working independently of the revised suspend semantics in the latest VMs; structured similarly as original versions of #terminate in Squeak 1.x thru 3.5 supersede Kernel-jar.1443; please remove Kernel-jar.1443, Kernel-jar.1442, Kernel-jar.1437, Kernel-jar.1436, Kernel-jar.1435, Kernel-jar.1426 =============== Diff against Kernel-eem.1444 =============== Item was added: + ----- Method: Context>>releaseCriticalSection: (in category 'private') ----- + releaseCriticalSection: oldList + "Figure out if we are terminating a process that is in the ensure: block of a critical section. + In this case, if it hasn't made progress but is beyond the wait (which we can tell by the oldList + being one of the runnable lists, i.e. a LinkedList, not a Semaphore or Mutex, et al), then the ensure: + block needs to be run." + + | selectorJustSent | + (self method pragmaAt: #criticalSection) ifNil: [^self]. + (oldList isNil or: [oldList class == LinkedList]) ifFalse: [^self]. + selectorJustSent := self selectorJustSentOrSelf. + + "If still at the wait the ensure: block has not been activated, so signal to restore." + selectorJustSent == #wait ifTrue: + [self receiver signal]. + + "If still at the lock primitive and the lock primitive just acquired ownership (indicated by it answering false) + then the ensure block has not been activated, so explicitly run primitiveExitCriticalSection to unlock." + (selectorJustSent == #primitiveEnterCriticalSection + or: [selectorJustSent == #primitiveTestAndSetOwnershipOfCriticalSection]) ifTrue: + [(self stackPtr > 0 + and: [self top == false]) ifTrue: + [self receiver primitiveExitCriticalSection]]! Item was added: + ----- Method: Context>>runUntilReturnFrom: (in category 'private-exceptions') ----- + runUntilReturnFrom: aContext + "Run the receiver (which must be its stack top context) until aContext returns. Avoid a context that cannot return. + Note: to avoid infinite recursion of MNU error inside unwind blocks, implement e.g. a wrapper around the message + sentTo: receiver in #doesNotUnderstand:. Note: This method is a trivialized version of #runUntilErrorOrReturnFrom: + and was intended to be used by #unwindTo as a helper method to unwind non-local returns inside unwind blocks." + + | here unwindBottom newTop | + here := thisContext. + "Avoid a context that cannot return (see Note 1 below)" + unwindBottom := (self findContextSuchThat: [:ctx | ctx selector = #cannotReturn:]) ifNil: [aContext]. + newTop := aContext sender. + "Insert ensure context under unwindBottom in self's stack (see Note 2 below)" + unwindBottom insertSender: (Context contextEnsure: [here jump]). + self jump. "Control jumps to the receiver's stack (see Note 2 below)" + "Control resumes here once the above inserted ensure block is executed (see #jump comments)" + ^newTop "Return the new top context (see Note 3 below)" + + "Note 1: returning from #cannotReturn's sender would crash the VM so we install a guard ensure context right + above it; after returning here the unwind will continue safely. Try running and debugging this example + (avoid Proceeding the BCR error though; it may indeed crash the image): + [[[] ensure: [^2]] ensure: [^42]] fork" + + "Note 2: the receiver (self) is run by jumping directly to it (the active process abandons thisContext and executes + self on its own stack; self must be its top context). However, before jumping to self we insert an ensure block under + unwindBottom context that will execute a jump back to thisContext when evaluated. The inserted guard ensure + context is removed once control jumps back to thisContext." + + "Note 3: it doesn't matter newTop is not a proper stack top context because #unwindTo will only use it as a starting + point in the search for the next unwind context and the computation will never return here. We could make newTop + a proper top context by pushing nil to its stack (^newTop push: nil) if need be (see #jump comments). + Cf. the pattern in #runUntilErrorOrReturnFrom:: removing the inserted ensure context by stepping until popped + when executing non-local returns wouldn't work here and would fail tests testTerminateInNestedEnsureWithReturn1 + through 4."! Item was changed: ----- Method: Context>>unwindTo: (in category 'private-exceptions') ----- unwindTo: aContext + "Unwind the receiver to aContext to execute all pending unwind blocks." + self unwindTo: aContext safely: true! - | ctx unwindBlock | - ctx := self. - [(ctx := ctx findNextUnwindContextUpTo: aContext) isNil] whileFalse: [ - (ctx tempAt: 2) ifNil:[ - ctx tempAt: 2 put: true. - unwindBlock := ctx tempAt: 1. - unwindBlock value] - ]. - ! Item was added: + ----- Method: Context>>unwindTo:safely: (in category 'private-exceptions') ----- + unwindTo: aContext safely: aBoolean + "Unwind self to aContext to execute pending #ensure:/#ifCurtailed: argument blocks between self + and aContext. If aBoolean is false, unwind only blocks that have not run yet, otherwise complete all + pending unwind blocks including those currently in the middle of their execution; these blocks will + just finish their execution. Run all unwinds on their original stack using #runUntilReturnFrom:." + + | top ctx | + ctx := top := self. + aBoolean ifTrue: [ + "If self is a top context of a stack already halfways through an unwind, complete the outer-most + unfinished unwind block first; all nested pending unwind blocks will be completed in the process; + see testTerminationDuringUnwind and tests in ProcessTest/UnwindTest. + Note: Halfway-through blocks have already set the complete variable (ctxt tempAt: 2) in their + defining #ensure:/#ifCurtailed contexts from nil to true; we'll search for the bottom-most one." + | outerMost | + ctx isUnwindContext ifFalse: [ctx := ctx findNextUnwindContextUpTo: aContext]. + [ctx isNil] whileFalse: [ + (ctx tempAt:2) ifNotNil: [ + outerMost := ctx]. + ctx := ctx findNextUnwindContextUpTo: aContext]. + outerMost ifNotNil: [top := (top runUntilReturnFrom: outerMost) sender]]. + "By now no halfway-through unwind blocks are on the stack. + Note: top points to the former outerMost sender now, i.e. to the next context to be explored." + + ctx := top. + "#findNextUnwindContextUpTo: starts searching from the receiver's sender so we must check + the receiver explicitly whether it is an unwind context; see testTerminateEnsureAsStackTop. + Create a new top context (i.e. a new branch off the original stack) for each pending unwind block + (ctxt tempAt: 1) and execute it on the unwind block's stack to evaluate non-local returns correctly." + ctx isUnwindContext ifFalse: [ctx := ctx findNextUnwindContextUpTo: aContext]. + [ctx isNil] whileFalse: [ + (ctx tempAt: 2) ifNil: [ + ctx tempAt: 2 put: true. + top := (ctx tempAt: 1) asContextWithSender: ctx. "see the note below" + top runUntilReturnFrom: top]. + ctx := ctx findNextUnwindContextUpTo: aContext] + "Note: Cf. the unwind pattern in the previous versions of unwindTo: (1999-2021). Using #value + instead of #runUntilReturnFrom: lead to a failure to evaluate some non-local returns correctly; + a non-local return must be evaluated in the evaluation context (sender chain) in which it was defined."! Item was changed: ----- Method: Process>>terminate (in category 'changing process state') ----- terminate + "Stop the process that the receiver represents forever. + Unwind to execute pending #ensure:/#ifCurtailed: blocks before terminating; + allow all unwind blocks to run; if they are currently in progress, let them finish. + If the process is in the middle of a #critical: critical section, release it properly." + + "This is the kind of behavior we expect when terminating a healthy process. + See further comments in #terminateAggressively and #destroy methods dealing + with process termination when closing the debugger or after a catastrophic failure." + + "If terminating the active process, create a parallel stack and run unwinds from there; + if terminating a suspended process, again, create a parallel stack for the process being + terminated and resume the suspended process to complete its termination from the new + parallel stack. Use a priority higher than the active priority to make the process that + invoked the termination wait for its completion." - "Stop the receiver forever. - Run all unwind contexts (#ensure:/#ifCurtailed: blocks) on the stack, even if they are currently in progress. If already active unwind contexts should not be continued, send #terminateAggressively instead. - Note that ill unwind contexts are theoretically able to stall the termination (for instance, by placing a non-local return in an unwind block); however, this is a disrecommended practice. - If the process is in the middle of a critical section, release it properly." + "If terminating a suspended process (including runnable and blocked), always suspend + the terminating process first so it doesn't accidentally get woken up. Equally important is + the side effect of the suspension; In 2022 a new suspend semantics has been introduced: + the revised #suspend backs up a process waiting on a conditional variable to the send that + invoked the wait state, while the pre-2022 #suspend simply removed the process from + the conditional variable's list it was previously waiting on; see Process>>suspend comments. + Release any method marked with the <criticalSection> pragma via #releaseCriticalSection[:]. + Execute termination in the ensure argument block to ensure it completes even if the + terminator process itself gets terminated before it's finished; see testTerminateInTerminate." + + | context | - | ctxt unwindBlock oldList outerMost | self isActiveProcess ifTrue: [ + context := thisContext. + ^[context unwindTo: nil. self suspend] asContext jump]. - "If terminating the active process, suspend it first and terminate it as a suspended process." - [self terminate] fork. - ^self suspend]. + [] ensure: [ | oldList | + oldList := myList. + self suspend. + context := suspendedContext ifNil: [^self]. + suspendedContext := [ + context releaseCriticalSection: oldList; unwindTo: nil. + self suspend] asContext. + self priority: Processor activePriority + 1; resume]! - "Always suspend the process first so it doesn't accidentally get woken up. - N.B. If oldList is a LinkedList then the process is runnable. If it is a Semaphore/Mutex et al - then the process is blocked, and if it is nil then the process is already suspended." - oldList := self suspend. - suspendedContext ifNotNil: - ["Release any method marked with the <criticalSection> pragma. - The argument is whether the process is runnable." - self releaseCriticalSection: (oldList isNil or: [oldList class == LinkedList]). - - "If terminating a process halfways through an unwind, try to complete that unwind block first; - if there are multiple such nested unwind blocks, try to complete the outer-most one; the inner - blocks will be completed in the process." - ctxt := suspendedContext. - [(ctxt := ctxt findNextUnwindContextUpTo: nil) isNil] whileFalse: - "Contexts under evaluation have already set their complete (tempAt: 2) to true." - [(ctxt tempAt:2) ifNotNil: [outerMost := ctxt]]. - outerMost ifNotNil: [ - "This is the outer-most unwind context currently under evaluation; - let's find an inner context executing outerMost's argument block (tempAt: 1)" - (suspendedContext findContextSuchThat: [:ctx | - ctx closure == (outerMost tempAt: 1)]) ifNotNil: [:inner | - "Let's finish the unfinished unwind context only (i.e. up to inner) and return here" - suspendedContext runUntilErrorOrReturnFrom: inner. - "Update the receiver's suspendedContext (the previous step reset its sender to nil); - return, if the execution stack reached its bottom (e.g. in case of non-local returns)." - (suspendedContext := outerMost sender) ifNil: [^self]]]. - - "Now all unwind blocks caught halfway through have been completed; - let's execute the ones still pending. Note: #findNextUnwindContextUpTo: starts - searching from the receiver's sender but the receiver itself may be an unwind context." - ctxt := suspendedContext. - ctxt isUnwindContext ifFalse: [ctxt := ctxt findNextUnwindContextUpTo: nil]. - [ctxt isNil] whileFalse: [ - (ctxt tempAt: 2) ifNil: [ - ctxt tempAt: 2 put: true. - unwindBlock := ctxt tempAt: 1. - "Create a context for the unwind block and execute it on the unwind block's stack. - Note: using #value instead of #runUntilErrorOrReturnFrom: would lead to executing - the unwind on the wrong stack preventing the correct execution of non-local returns." - suspendedContext := unwindBlock asContextWithSender: ctxt. - suspendedContext runUntilErrorOrReturnFrom: suspendedContext]. - ctxt := ctxt findNextUnwindContextUpTo: nil]. - - "Reset the context's pc and sender to nil for the benefit of isTerminated." - suspendedContext terminate]!

1 0

The Treated Inbox: KernelTests-jar.421.mcz
by commits＠source.squeak.org 30 May '22

30 May '22

Marcel Taeumel uploaded a new version of KernelTests to project The Treated Inbox: http://source.squeak.org/treated/KernelTests-jar.421.mcz ==================== Summary ==================== Name: KernelTests-jar.421 Author: jar Time: 5 January 2022, 3:15:22.031959 pm UUID: 97065f2d-925e-d04e-9bfb-69efecc5f415 Ancestors: KernelTests-ct.418 a battery of tests to complement new #terminate (Kernel-jar.1443 or later). replacing individual changesets: KernelTests-jar.406 KernelTests-jar.407 KernelTests-jar.415 KernelTests-jar.416 KernelTests-jar.417 KernelTests-jar.419 KernelTests-jar.420 please kindly remove these from the Inbox =============== Diff against KernelTests-ct.418 =============== Item was added: + ----- Method: MutexTest>>testMutexInCriticalEnsureArgument (in category 'tests') ----- + testMutexInCriticalEnsureArgument "self run: #testMutexInCriticalEnsureArgument" + "This tests whether a process that is in the ensure argument block in critical: but has yet to evaluate the primitiveExitCriticalSection + leaves it with the mutex unlocked." + + | terminatee mutex | + mutex := Mutex new. + terminatee := [mutex critical: []] newProcess. + self assert: terminatee isSuspended. + terminatee runUntil: [:ctx | ctx selectorToSendOrSelf = #primitiveExitCriticalSection]. + self assert: terminatee isSuspended. + terminatee terminate. + self deny: mutex isOwned. + self assert: mutex isEmpty! Item was changed: ----- Method: ProcessTest>>testAtomicSuspend (in category 'tests') ----- testAtomicSuspend "Test atomic suspend of foreign processes" | list p | p := [semaphore wait] fork. Processor yield. list := p suspendPrimitivelyOrFail. + self assert: + (Smalltalk processSuspensionUnblocks + ifFalse: [list isNil] + ifTrue: [list == semaphore])! - self assert: list == semaphore. - ! Item was added: + ----- Method: ProcessTest>>testResumeTerminatingProcess (in category 'tests') ----- + testResumeTerminatingProcess + + | terminatee terminator resumed semaphore | + semaphore := Semaphore new. + terminatee := [semaphore critical:[]. resumed := true] fork. + Processor yield. + terminator := [terminatee terminate] newProcess. + self assert: terminatee suspendingList == semaphore. + self assert: terminator isSuspended. + "run terminator and stop inside #releaseCriticalSection:" + terminator runUntil: [:ctx | ctx selectorToSendOrSelf = #selectorJustSentOrSelf]. + self assert: terminator isSuspended. + "resume the terminatee process and and check if the VM raises an error; + an error is expected because terminatee's suspendedContext equals nil" + self should: [terminatee resume] raise: Error. + "now let the terminator finish terminating the terminatee process" + terminator resume. + Processor yield. + self assert: resumed isNil. + self assert: terminatee isTerminated. + self assert: terminator isTerminated! Item was added: + ----- Method: ProcessTest>>testRevisedSuspendExpectations (in category 'tests') ----- + testRevisedSuspendExpectations + "Test revised suspend expectations vs. pre-2022 VM's suspend" + + | s p list | + s := Semaphore new. + p := [s critical:[]] forkAt: Processor activePriority + 1. + list := p suspend. + + Smalltalk processSuspensionUnblocks + ifFalse: [ + self assert: p suspendingList equals: nil. + self assert: list equals: nil. + self deny: p suspendedContext selectorJustSentOrSelf equals: #wait + ] + ifTrue: [ + self assert: p suspendingList equals: nil. + self assert: list equals: s. + self assert: p suspendedContext selectorJustSentOrSelf equals: #wait + ]! Item was added: + ----- Method: ProcessTest>>testTerminateEnsureAsStackTop (in category 'tests') ----- + testTerminateEnsureAsStackTop + "Test #ensure unwind block is executed even when #ensure context is on stack's top." + + | p1 p2 p3 x1 x2 x3 | + x1 := x2 := x3 := false. + + "p1 is at the beginning of the ensure block and the unwind block hasn't run yet" + p1 := Process + forBlock: [[] ensure: [x1 := x1 not]] + runUntil: [:ctx | ctx isUnwindContext and: [(ctx tempAt: 2) isNil]]. + + "p2 has already set complete to true (tempAt: 2) but the unwind block hasn't run yet" + p2 := Process + forBlock: [[] ensure: [x2 := x2 not]] + runUntil: [:ctx | ctx isUnwindContext and: [(ctx tempAt: 2) notNil]]. + + "p3 has already set complete to true AND the unwind block has run already run; + we have to verify the unwind block is not executed again during termination" + p3 := Process + forBlock: [[] ensure: [x3 := x3 not]] + runUntil: [:ctx | ctx isUnwindContext and: [ctx willReturn]]. + + "make sure all processes are running and only the p3's unwind block has finished" + self deny: p1 isTerminated | p2 isTerminated | p3 isTerminated. + self deny: x1 | x2. + self assert: x3. "p3 has already run its unwind block; we test it won't run it again" + "terminate all processes and verify all unwind blocks have finished correctly" + p1 terminate. p2 terminate. p3 terminate. + self assert: p1 isTerminated & p2 isTerminated & p3 isTerminated. + self assert: x1 & x2 & x3! Item was added: + ----- Method: ProcessTest>>testTerminateInTerminate (in category 'tests') ----- + testTerminateInTerminate + "Terminating a terminator process should unwind both the terminator and its terminatee process" + + | terminator terminatee unwound | + unwound := false. + terminatee := [[Processor activeProcess suspend] ensure: [unwound := true]] fork. + Processor yield. + terminator := [terminatee terminate] newProcess. + self assert: terminatee isSuspended. + self assert: terminator isSuspended. + terminator runUntil: [:ctx | ctx selectorToSendOrSelf = #suspend]. "first #suspend in #terminate" + self assert: terminator isSuspended. + terminator terminate. + self assert: terminator isTerminated. + self assert: unwound! Item was added: + ----- Method: ProcessTest>>testTerminateTerminatingProcess (in category 'tests') ----- + testTerminateTerminatingProcess + + | terminatee terminator resumed semaphore | + semaphore := Semaphore new. + terminatee := [semaphore critical:[]. resumed := true] fork. + Processor yield. + terminator := [terminatee terminate] newProcess. + self assert: terminatee suspendingList == semaphore. + self assert: terminator isSuspended. + "run terminator and stop inside #releaseCriticalSection:" + terminator runUntil: [:ctx | ctx selectorToSendOrSelf = #selectorJustSentOrSelf]. + self assert: terminator isSuspended. + "terminate the terminatee process again and let the termination finish; + an error is expected because #terminate detected multiple termination" + self should: [terminatee terminate] raise: Error. + "now let the terminator finish terminating the terminatee process" + terminator resume. + Processor yield. + self assert: resumed isNil. + self assert: terminatee isTerminated. + self assert: terminator isTerminated! Item was added: + ----- Method: SemaphoreTest>>testSemaInCriticalEnsureArgument (in category 'tests') ----- + testSemaInCriticalEnsureArgument "self run: #testSemaInCriticalEnsureArgument" + "This tests whether a process that is in ensure argument block but has yet to evaluate the signal + leaves it with signaling the associated semaphore." + + | terminatee sema | + sema := Semaphore forMutualExclusion. + terminatee := [sema critical: []] newProcess. + self assert: terminatee isSuspended. + terminatee runUntil: [:ctx | ctx selectorToSendOrSelf = #signal]. + self assert: terminatee isSuspended. + terminatee terminate. + self assert: terminatee isTerminated. + self assert: sema excessSignals = 1 ! Item was added: + ProcessTest subclass: #UnwindTest + instanceVariableNames: '' + classVariableNames: '' + poolDictionaries: '' + category: 'KernelTests-Processes'! Item was added: + ----- Method: UnwindTest>>testTerminateActiveInNestedEnsure1 (in category 'tests') ----- + testTerminateActiveInNestedEnsure1 + "Terminate active process. + Test all nested unwind blocks are correctly executed; + all unwind blocks halfway through their execution should be completed." + + | p x1 x2 x3 x4 | + x1 := x2 := x3 := x4 := false. + p := + [ + [ + [ ] ensure: [ + [Processor activeProcess terminate] ensure: [ + x1 := true]. + x2 := true] + ] ensure: [ + x3 := true]. + x4 := true. + ] newProcess. + p resume. + Processor yield. + self assert: p isTerminated. + self assert: x1 & x2 & x3. + self deny: x4.! Item was added: + ----- Method: UnwindTest>>testTerminateActiveInNestedEnsure2 (in category 'tests') ----- + testTerminateActiveInNestedEnsure2 + "Terminate active process. + Test all nested unwind blocks are correctly executed; + all unwind blocks halfway through their execution should be completed." + + | p x1 x2 x3 x4 | + x1 := x2 := x3 := x4 := false. + p := + [ + [ + [ ] ensure: [ + [ ] ensure: [ + Processor activeProcess terminate. + x1 := true]. + x2 := true] + ] ensure: [ + x3 := true]. + x4 := true. + ] newProcess. + p resume. + Processor yield. + self assert: p isTerminated. + self assert: x1 & x2 & x3. + self deny: x4.! Item was added: + ----- Method: UnwindTest>>testTerminateBlockedInNestedEnsure1 (in category 'tests') ----- + testTerminateBlockedInNestedEnsure1 + "Terminate blocked process. + Test all nested unwind blocks are correctly executed; + all unwind blocks halfway through their execution should be completed." + + | p x1 x2 x3 x4 | + x1 := x2 := x3 := x4 := false. + p := + [ + [ + [ ] ensure: [ + [semaphore wait] ensure: [ + x1 := true]. + x2 := true] + ] ensure: [ + x3 := true]. + x4 := true. + ] newProcess. + p resume. + Processor yield. + "make sure p is blocked and none of the unwind blocks has finished yet" + self assert: p isBlocked. + self deny: x1 | x2 | x3 | x4. + "now terminate the process and make sure all unwind blocks have finished" + [p terminate] forkAt: Processor activePriority + 1. + Smalltalk processSuspensionUnblocks ifFalse: [ + "terminate will suspend the process first and suspend will put the process back at #wait and + so unwind will put the process back at the wait; to continue, semaphore needs to be signaled" + "self assert: p isBlocked. <-- this wouldn't work because terminate set suspendedContext to nil" + self deny: x1 | x2 | x3 | x4. + semaphore signal. + Processor yield]. + self assert: p isTerminated. + self assert: x1 & x2 & x3. + self deny: x4.! Item was added: + ----- Method: UnwindTest>>testTerminateBlockedInNestedEnsure2 (in category 'tests') ----- + testTerminateBlockedInNestedEnsure2 + "Terminate blocked process. + Test all nested unwind blocks are correctly executed; + all unwind blocks halfway through their execution should be completed." + + | p x1 x2 x3 x4 | + x1 := x2 := x3 := x4 := false. + p := + [ + [ + [ ] ensure: [ + [ ] ensure: [ + semaphore wait. + x1 := true]. + x2 := true] + ] ensure: [ + x3 := true]. + x4 := true. + ] newProcess. + p resume. + Processor yield. + "make sure p is blocked and none of the unwind blocks has finished yet" + self assert: p isBlocked. + self deny: x1 | x2 | x3 | x4. + "now terminate the process and make sure all unwind blocks have finished" + [p terminate] forkAt: Processor activePriority + 1. + Smalltalk processSuspensionUnblocks ifFalse: [ + "terminate will suspend the process first and suspend will put the process back at #wait and + so unwind will put the process back at the wait; to continue, semaphore needs to be signaled" + "self assert: p isBlocked. <-- this wouldn't work because terminate set suspendedContext to nil" + self deny: x1 | x2 | x3 | x4. + semaphore signal. + Processor yield]. + self assert: p isTerminated. + self assert: x1 & x2 & x3. + self deny: x4.! Item was added: + ----- Method: UnwindTest>>testTerminateInNestedEnsureWithReturn1 (in category 'tests') ----- + testTerminateInNestedEnsureWithReturn1 + "Terminate suspended process. + Test all nested unwind blocks are correctly executed; + all unwind blocks halfway through their execution should be completed." + + | p x1 x2 x3 x4 | + x1 := x2 := x3 := x4 := false. + p := + [ + [:return | + [ + [ ] ensure: [ + [Processor activeProcess suspend] ensure: [ + x1 := true. return value]. + x2 := true] + ] ensure: [ + x3 := true]. + x4 := true. + ] valueWithExit + ] newProcess. + p resume. + Processor yield. + "make sure p is suspended and none of the unwind blocks has finished yet" + self assert: p isSuspended. + self deny: x1 | x2 | x3 | x4. + "now terminate the process and make sure all unwind blocks have finished" + [p terminate] forkAt: Processor activePriority + 1. + self assert: p isTerminated. + self assert: x1 & x3. + self deny: x2 & x4.! Item was added: + ----- Method: UnwindTest>>testTerminateInNestedEnsureWithReturn2 (in category 'tests') ----- + testTerminateInNestedEnsureWithReturn2 + "Terminate suspended process. + Test all nested unwind blocks are correctly executed; + all unwind blocks halfway through their execution should be completed." + + | p x1 x2 x3 x4 | + x1 := x2 := x3 := x4 := false. + p := + [ + [:return | + [ + [ ] ensure: [ + [] ensure: [ + Processor activeProcess suspend. + x1 := true. return value]. + x2 := true] + ] ensure: [ + x3 := true]. + x4 := true. + ] valueWithExit + ] newProcess. + p resume. + Processor yield. + "make sure p is suspended and none of the unwind blocks has finished yet" + self assert: p isSuspended. + self deny: x1 | x2 | x3 | x4. + "now terminate the process and make sure all unwind blocks have finished" + [p terminate] forkAt: Processor activePriority + 1. + self assert: p isTerminated. + self assert: x1 & x3. + self deny: x2 & x4.! Item was added: + ----- Method: UnwindTest>>testTerminateInNestedEnsureWithReturn3 (in category 'tests') ----- + testTerminateInNestedEnsureWithReturn3 + "Terminate suspended process. + Test all nested unwind blocks are correctly executed; + all unwind blocks halfway through their execution should be completed." + + | p x1 x2 x3 x4 | + x1 := x2 := x3 := x4 := false. + p := + [ + [:return | + [ + [ ] ensure: [ + [Processor activeProcess suspend] ensure: [ + x1 := true]. + x2 := true. return value] + ] ensure: [ + x3 := true]. + x4 := true. + ] valueWithExit + ] newProcess. + p resume. + Processor yield. + "make sure p is suspended and none of the unwind blocks has finished yet" + self assert: p isSuspended. + self deny: x1 | x2 | x3 | x4. + "now terminate the process and make sure all unwind blocks have finished" + [p terminate] forkAt: Processor activePriority + 1. + self assert: p isTerminated. + self assert: x1 & x2 & x3. + self deny: x4.! Item was added: + ----- Method: UnwindTest>>testTerminateInNestedEnsureWithReturn4 (in category 'tests') ----- + testTerminateInNestedEnsureWithReturn4 + "Terminate suspended process. + Test all nested unwind blocks are correctly executed; + all unwind blocks halfway through their execution should be completed." + + | p x1 x2 x3 x4 | + x1 := x2 := x3 := x4 := false. + p := + [ + [:return | + [ + [ ] ensure: [ + [] ensure: [ + Processor activeProcess suspend. + x1 := true]. + x2 := true. return value] + ] ensure: [ + x3 := true]. + x4 := true. + ] valueWithExit + ] newProcess. + p resume. + Processor yield. + "make sure p is suspended and none of the unwind blocks has finished yet" + self assert: p isSuspended. + self deny: x1 | x2 | x3 | x4. + "now terminate the process and make sure all unwind blocks have finished" + [p terminate] forkAt: Processor activePriority + 1. + self assert: p isTerminated. + self assert: x1 & x2 & x3. + self deny: x4.! Item was added: + ----- Method: UnwindTest>>testTerminateInNestedEnsureWithReturn5 (in category 'tests') ----- + testTerminateInNestedEnsureWithReturn5 + "Terminate suspended process. + Test all nested unwind blocks are correctly executed; + all unwind blocks halfway through their execution should be completed." + + | p x1 x2 x3 x4 | + x1 := x2 := x3 := x4 := false. + p := + [ + [:return | + [ + [ ] ensure: [ + [Processor activeProcess suspend] ensure: [ + x1 := true]. + x2 := true] + ] ensure: [ + x3 := true. return value]. + x4 := true. + ] valueWithExit + ] newProcess. + p resume. + Processor yield. + "make sure p is suspended and none of the unwind blocks has finished yet" + self assert: p isSuspended. + self deny: x1 | x2 | x3 | x4. + "now terminate the process and make sure all unwind blocks have finished" + [p terminate] forkAt: Processor activePriority + 1. + self assert: p isTerminated. + self assert: x1 & x2 & x3. + self deny: x4.! Item was added: + ----- Method: UnwindTest>>testTerminateInNestedEnsureWithReturn6 (in category 'tests') ----- + testTerminateInNestedEnsureWithReturn6 + "Terminate suspended process. + Test all nested unwind blocks are correctly executed; + all unwind blocks halfway through their execution should be completed." + + | p x1 x2 x3 x4 | + x1 := x2 := x3 := x4 := false. + p := + [ + [:return | + [ + [ ] ensure: [ + [] ensure: [ + Processor activeProcess suspend. + x1 := true]. + x2 := true] + ] ensure: [ + x3 := true. return value]. + x4 := true. + ] valueWithExit + ] newProcess. + p resume. + Processor yield. + "make sure p is suspended and none of the unwind blocks has finished yet" + self assert: p isSuspended. + self deny: x1 | x2 | x3 | x4. + "now terminate the process and make sure all unwind blocks have finished" + [p terminate] forkAt: Processor activePriority + 1. + self assert: p isTerminated. + self assert: x1 & x2 & x3. + self deny: x4.! Item was added: + ----- Method: UnwindTest>>testTerminateInNestedEnsureWithReturn7 (in category 'tests') ----- + testTerminateInNestedEnsureWithReturn7 + "Terminate suspended process. + Test all nested unwind blocks are correctly executed; + all unwind blocks halfway through their execution should be completed." + + | p x1 x2 x3 x4 | + x1 := x2 := x3 := x4 := false. + p := + [ + [:return | + [ + [ ] ensure: [ + [Processor activeProcess suspend] ensure: [ + x1 := true]. + x2 := true] + ] ensure: [ + x3 := true]. + x4 := true. return value. + ] valueWithExit + ] newProcess. + p resume. + Processor yield. + "make sure p is suspended and none of the unwind blocks has finished yet" + self assert: p isSuspended. + self deny: x1 | x2 | x3 | x4. + "now terminate the process and make sure all unwind blocks have finished" + [p terminate] forkAt: Processor activePriority + 1. + self assert: p isTerminated. + self assert: x1 & x2 & x3. + self deny: x4.! Item was added: + ----- Method: UnwindTest>>testTerminateInNestedEnsureWithReturn8 (in category 'tests') ----- + testTerminateInNestedEnsureWithReturn8 + "Terminate suspended process. + Test all nested unwind blocks are correctly executed; + all unwind blocks halfway through their execution should be completed." + + | p x1 x2 x3 x4 | + x1 := x2 := x3 := x4 := false. + p := + [ + [:return | + [ + [ ] ensure: [ + [] ensure: [ + Processor activeProcess suspend. + x1 := true]. + x2 := true] + ] ensure: [ + x3 := true]. + x4 := true. return value. + ] valueWithExit + ] newProcess. + p resume. + Processor yield. + "make sure p is suspended and none of the unwind blocks has finished yet" + self assert: p isSuspended. + self deny: x1 | x2 | x3 | x4. + "now terminate the process and make sure all unwind blocks have finished" + [p terminate] forkAt: Processor activePriority + 1. + self assert: p isTerminated. + self assert: x1 & x2 & x3. + self deny: x4.! Item was added: + ----- Method: UnwindTest>>testTerminateRunnableInNestedEnsure1 (in category 'tests') ----- + testTerminateRunnableInNestedEnsure1 + "Terminate runnable process. + Test all nested unwind blocks are correctly executed; + all unwind blocks halfway through their execution should be completed." + + | p x1 x2 x3 x4 | + x1 := x2 := x3 := x4 := false. + p := + [ + [ + [ ] ensure: [ + [Processor yield] ensure: [ + x1 := true]. + x2 := true] + ] ensure: [ + x3 := true]. + x4 := true. + ] newProcess. + p resume. + Processor yield. + "make sure p is runnable and none of the unwind blocks has finished yet" + self assert: p isRunnable. + self deny: x1 | x2 | x3 | x4. + "now terminate the process and make sure all unwind blocks have finished" + [p terminate] forkAt: Processor activePriority + 1. + self assert: p isTerminated. + self assert: x1 & x2 & x3. + self deny: x4.! Item was added: + ----- Method: UnwindTest>>testTerminateRunnableInNestedEnsure2 (in category 'tests') ----- + testTerminateRunnableInNestedEnsure2 + "Terminate runnable process. + Test all nested unwind blocks are correctly executed; + all unwind blocks halfway through their execution should be completed." + + | p x1 x2 x3 x4 | + x1 := x2 := x3 := x4 := false. + p := + [ + [ + [ ] ensure: [ + [ ] ensure: [ + Processor yield. + x1 := true]. + x2 := true] + ] ensure: [ + x3 := true]. + x4 := true. + ] newProcess. + p resume. + Processor yield. + "make sure p is runnable and none of the unwind blocks has finished yet" + self assert: p isRunnable. + self deny: x1 | x2 | x3 | x4. + "now terminate the process and make sure all unwind blocks have finished" + [p terminate] forkAt: Processor activePriority + 1. + self assert: p isTerminated. + self assert: x1 & x2 & x3. + self deny: x4.! Item was added: + ----- Method: UnwindTest>>testTerminateSuspendedInNestedEnsure1 (in category 'tests') ----- + testTerminateSuspendedInNestedEnsure1 + "Terminate suspended process. + Test all nested unwind blocks are correctly executed; + all unwind blocks halfway through their execution should be completed." + + | p x1 x2 x3 x4 | + x1 := x2 := x3 := x4 := false. + p := + [ + [ + [ ] ensure: [ + [Processor activeProcess suspend] ensure: [ + x1 := true]. + x2 := true] + ] ensure: [ + x3 := true]. + x4 := true. + ] newProcess. + p resume. + Processor yield. + "make sure p is suspended and none of the unwind blocks has finished yet" + self assert: p isSuspended. + self deny: x1 | x2 | x3 | x4. + "now terminate the process and make sure all unwind blocks have finished" + [p terminate] forkAt: Processor activePriority + 1. + self assert: p isTerminated. + self assert: x1 & x2 & x3. + self deny: x4.! Item was added: + ----- Method: UnwindTest>>testTerminateSuspendedInNestedEnsure2 (in category 'tests') ----- + testTerminateSuspendedInNestedEnsure2 + "Terminate suspended process. + Test all nested unwind blocks are correctly executed; + all unwind blocks halfway through their execution should be completed." + + | p x1 x2 x3 x4 | + x1 := x2 := x3 := x4 := false. + p := + [ + [ + [ ] ensure: [ + [ ] ensure: [ + Processor activeProcess suspend. + x1 := true]. + x2 := true] + ] ensure: [ + x3 := true]. + x4 := true. + ] newProcess. + p resume. + Processor yield. + "make sure p is suspended and none of the unwind blocks has finished yet" + self assert: p isSuspended. + self deny: x1 | x2 | x3 | x4. + "now terminate the process and make sure all unwind blocks have finished" + [p terminate] forkAt: Processor activePriority + 1. + self assert: p isTerminated. + self assert: x1 & x2 & x3. + self deny: x4.!

1 0

The Trunk: 60Deprecated-ct.115.mcz
by commits＠source.squeak.org 30 May '22

30 May '22

Marcel Taeumel uploaded a new version of 60Deprecated to project The Trunk: http://source.squeak.org/trunk/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

The Treated Inbox: 60Deprecated-ct.112.mcz
by commits＠source.squeak.org 30 May '22

30 May '22

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

The Trunk: JSON-ul.56.mcz
by commits＠source.squeak.org 25 May '22

25 May '22

Tony Garnock-Jones uploaded a new version of JSON to project The Trunk: http://source.squeak.org/trunk/JSON-ul.56.mcz ==================== Summary ==================== Name: JSON-ul.56 Author: ul Time: 6 December 2020, 6:47:32.838453 pm UUID: 6c5f17b1-830e-45ba-90b0-3cd6d40cd35e Ancestors: JSON-ul.55 Implemented JsonObject >> #respondsTo: which returns true for all setters and getters of already defined fields. The code works the same way #doesNotUnderstand: does. ==================== Snapshot ==================== SystemOrganization addCategory: #JSON! ----- Method: Integer>>jsonWriteOn: (in category '*JSON-writing') ----- jsonWriteOn: aWriteStream ^ self printOn: aWriteStream base: 10 ! ----- Method: Association>>jsonWriteOn: (in category '*JSON-writing') ----- jsonWriteOn: aStream self key asString jsonWriteOn: aStream. aStream nextPut: $:; space. self value jsonWriteOn: aStream.! ----- Method: False>>jsonWriteOn: (in category '*JSON-writing') ----- jsonWriteOn: aStream aStream nextPutAll: 'false'! ----- Method: Number>>jsonWriteOn: (in category '*JSON-writing') ----- jsonWriteOn: aWriteStream self printOn: aWriteStream base: 10! OrderedDictionary subclass: #OrderedJsonObject instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'JSON'! ----- Method: OrderedJsonObject class>>fromAssociations: (in category 'as yet unclassified') ----- fromAssociations: collectionOfAssociations | result | result := self new. collectionOfAssociations do: [:each | result at: each key put: each value ]. ^ result! ----- Method: OrderedJsonObject>>at: (in category 'accessing') ----- at: aKey "make it work more like javascript objects" ^ self at: aKey ifAbsent: [nil]! ----- Method: OrderedJsonObject>>at:put: (in category 'accessing') ----- at: aString put: anObject aString isString ifFalse: [ self error: 'String expected' ]. super at: aString put: anObject. ^self! ----- Method: OrderedJsonObject>>doesNotUnderstand: (in category 'error handling') ----- doesNotUnderstand: aMessage | key precedence | key := aMessage selector. (precedence := key precedence) = 1 ifTrue: [ ^self at: key ifAbsent: nil ]. (precedence = 3 and: [ (key indexOf: $:) = key size ]) ifTrue: [ ^self at: key allButLast asSymbol put: aMessage arguments first ]. ^super doesNotUnderstand: aMessage! ----- Method: OrderedJsonObject>>name (in category 'accessing') ----- name "override 'cause Object defines this" ^self at: 'name'! ----- Method: OrderedJsonObject>>value (in category 'accessing') ----- value "override 'cause Object defines this" ^self at: 'value'! ----- Method: Time>>jsonWriteOn: (in category '*JSON') ----- jsonWriteOn: stream stream nextPut: $". self print24: true showSeconds: true on: stream. stream nextPut: $"! ----- Method: WriteStream>>jsonPrint: (in category '*json-printing') ----- jsonPrint: anObject anObject jsonWriteOn: self! ----- Method: Text>>jsonWriteOn: (in category '*json-printing') ----- jsonWriteOn: aStream self string jsonWriteOn: aStream! ----- Method: UndefinedObject>>jsonWriteOn: (in category '*JSON-writing') ----- jsonWriteOn: aWriteStream aWriteStream nextPutAll: 'null'! Error subclass: #JsonSyntaxError instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'JSON'! !JsonSyntaxError commentStamp: 'tonyg 4/29/2016 11:06' prior: 0! Class Json signals (possibly-indirect) instances of me when reading a JSON value from an input stream fails.! JsonSyntaxError subclass: #JsonIncompleteError instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'JSON'! !JsonIncompleteError commentStamp: 'tonyg 4/29/2016 11:37' prior: 0! I signal that reading a JSON value failed because more input is required, but that the input seen so far was not incorrect. Compare to JsonInvalidError. Be warned that reading numbers directly out of a stream can be ambiguous!! Consider reading from '1234'. Is the result intended to be 1234, or is there missing input, and the next character will be '5', making the result (possibly) 12345?! JsonSyntaxError subclass: #JsonInvalidError instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'JSON'! !JsonInvalidError commentStamp: 'tonyg 4/29/2016 11:06' prior: 0! I signal that reading a JSON value failed because the input didn't match the (extended)JSON grammar implemented by class Json.! ----- Method: Dictionary>>jsonWriteOn: (in category '*JSON-writing') ----- jsonWriteOn: aStream | needComma | needComma := false. aStream nextPut: ${. self associationsDo: [ :assoc | needComma ifTrue: [ aStream nextPut: $, ] ifFalse: [ needComma := true ]. assoc key jsonWriteOn: aStream. aStream nextPut: $:. assoc value jsonWriteOn: aStream ]. aStream nextPut: $}.! Dictionary subclass: #JsonObject instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'JSON'! ----- Method: JsonObject class>>fromAssociations: (in category 'as yet unclassified') ----- fromAssociations: collectionOfAssociations | result | result := self new. collectionOfAssociations do: [:each | result at: each key put: each value ]. ^ result! ----- Method: JsonObject>>at: (in category 'accessing') ----- at: aKey "make it work more like javascript objects" ^ self at: aKey ifAbsent: [nil]! ----- Method: JsonObject>>at:put: (in category 'accessing') ----- at: aString put: anObject aString isString ifFalse: [ self error: 'String expected' ]. super at: aString put: anObject. ^self! ----- Method: JsonObject>>doesNotUnderstand: (in category 'error handling') ----- doesNotUnderstand: aMessage | key precedence | key := aMessage selector. (precedence := key precedence) = 1 ifTrue: [ ^self at: key ifAbsent: nil ]. (precedence = 3 and: [ (key indexOf: $:) = key size ]) ifTrue: [ ^self at: key allButLast asSymbol put: aMessage arguments first ]. ^super doesNotUnderstand: aMessage! ----- Method: JsonObject>>name (in category 'accessing') ----- name "override 'cause Object defines this" ^self at: 'name'! ----- Method: JsonObject>>respondsTo: (in category 'error handling') ----- respondsTo: aSymbol | precedence | (super respondsTo: aSymbol) ifTrue: [ ^true ]. (precedence := aSymbol precedence) = 1 ifTrue: [ ^self includesKey: aSymbol ]. (precedence = 3 and: [ (aSymbol indexOf: $:) = aSymbol size ]) ifTrue: [ ^self includesKey: aSymbol allButLast ]. ^false! ----- Method: JsonObject>>value (in category 'accessing') ----- value "override 'cause Object defines this" ^self at: 'value'! ----- Method: True>>jsonWriteOn: (in category '*JSON-writing') ----- jsonWriteOn: aStream aStream nextPutAll: 'true'! NumberParser subclass: #JsonNumberParser instanceVariableNames: 'fraction leadingZeroesAllowed' classVariableNames: '' poolDictionaries: '' category: 'JSON'! ----- Method: JsonNumberParser>>allowPlusSign (in category 'accessing') ----- allowPlusSign ^false! ----- Method: JsonNumberParser>>allowPlusSignInExponent (in category 'accessing') ----- allowPlusSignInExponent ^true! ----- Method: JsonNumberParser>>error: (in category 'error') ----- error: aString JsonSyntaxError signal: aString! ----- Method: JsonNumberParser>>exponentLetters (in category 'accessing') ----- exponentLetters ^'eE'! ----- Method: JsonNumberParser>>fiveRaisedTo: (in category 'parsing-private') ----- fiveRaisedTo: anInteger anInteger >= 0 ifFalse: [ ^1 / (self fiveRaisedTo: 0 - anInteger) ]. anInteger >= 28 ifTrue: [ ^5 raisedToInteger: anInteger ]. ^#(1 5 25 125 625 3125 15625 78125 390625 1953125 9765625 48828125 244140625 1220703125 6103515625 30517578125 152587890625 762939453125 3814697265625 19073486328125 95367431640625 476837158203125 2384185791015625 11920928955078125 59604644775390625 298023223876953125 1490116119384765625 7450580596923828125) at: anInteger + 1! ----- Method: JsonNumberParser>>initialize (in category 'initialize-release') ----- initialize super initialize. base := 10. fraction := Fraction numerator: 0 denominator: 1. leadingZeroesAllowed := false! ----- Method: JsonNumberParser>>makeFloatFromMantissa:exponent: (in category 'parsing-private') ----- makeFloatFromMantissa: mantissa exponent: exponent "Return a Float equal to mantissa * 10 ^ exponent." exponent = 0 ifTrue: [ ^mantissa asFloat ]. exponent > 0 ifTrue: [ exponent <= 22 "Can 5 raisedToInteger: exponent be represented exactly as a Float? ((1 << Float precision - 1) log: 5) floor => 22" ifFalse: [ exponent > 324 ifTrue: [ "(Float emax + Float precision * (2 log: 10)) ceiling => 324" mantissa isZero ifTrue: [ ^0.0 ]. mantissa positive ifTrue: [ ^Float infinity ]. ^Float negativeInfinity ]. ^(mantissa * (self fiveRaisedTo: exponent)) asFloat timesTwoPower: exponent ] ifTrue: [ mantissa highBitOfMagnitude <= Float precision ifTrue: [ "Mantissa can also be represented as an exact Float. Float >> #* should be exact." ^mantissa asFloat * (self fiveRaisedTo: exponent) asFloat timesTwoPower: exponent ] ]. ^(mantissa * (self fiveRaisedTo: exponent)) asFloat timesTwoPower: exponent ]. "exponent < 0" exponent >= -22 "Can 5 raisedToInteger: 0 - exponent be represented exactly as a Float?" ifTrue: [ mantissa highBitOfMagnitude <= Float precision ifTrue: [ "Mantissa can also be represented as an exact Float. Float >> #/ should be exact." ^mantissa asFloat / (self fiveRaisedTo: 0 - exponent) asFloat timesTwoPower: exponent ] ] ifFalse: [ exponent < -324 ifTrue: [ "-1 * (Float precision - Float emin * (2 log: 10)) ceiling => -324" mantissa positive ifTrue: [ ^0.0 ]. ^-0.0 ] ]. "No luck. Let Fraction >> #asFloat do the heavy lifting." ^(fraction setNumerator: mantissa denominator: ((self fiveRaisedTo: 0 - exponent) bitShift: 0 - exponent)) asFloat "Can't use #timesTwoPower: here. No #reduced here, because there's none in NumberParser either"! ----- Method: JsonNumberParser>>nextElementaryLargeInteger (in category 'parsing-large int') ----- nextElementaryLargeInteger "Form an unsigned integer with incoming digits from sourceStream. Return this integer, or zero if no digits found. Stop reading if end of digits or if a LargeInteger is formed. Count the number of digits and the position of lastNonZero digit and store them in instVar." | digit value | value := 0. nDigits := 0. lastNonZero := 0. [ value isLarge ifTrue: [ ^value ]. ((digit := (sourceStream next ifNil: [ ^value ]) asInteger - 48 "$0 asInteger") < 0 or: [ digit >= 10 ]) ifTrue: [ sourceStream skip: -1. ^value ]. nDigits := nDigits + 1. digit = 0 ifFalse: [ (lastNonZero = 0 and: [ nDigits > 1 and: [ leadingZeroesAllowed not ] ]) ifTrue: [ self error: 'Leading zeroes are not allowed.' ]. lastNonZero := nDigits. value := value * 10 + digit ] ifTrue: [ value := value * 10 ] ] repeat! ----- Method: JsonNumberParser>>nextNumber: (in category 'parsing-public') ----- nextNumber: negative | numberOfTrailingZeroInIntegerPart oldLeadingZeroesAllowed numberOfTrailingZeroInFractionPart numberOfNonZeroFractionDigits mantissa value | integerPart := self nextUnsignedIntegerOrNil ifNil: [ ^self error: 'Missing integer part!!' ]. numberOfTrailingZeroInIntegerPart := nDigits - lastNonZero. (sourceStream peekFor: $.) ifFalse: [ "No fraction part" negative ifTrue: [ integerPart := integerPart negated ]. self readExponent ifFalse: [ ^integerPart ]. exponent > 0 ifTrue: [ ^integerPart * (self fiveRaisedTo: exponent) bitShift: exponent ]. ^self makeFloatFromMantissa: integerPart exponent: exponent ]. oldLeadingZeroesAllowed := leadingZeroesAllowed. leadingZeroesAllowed := true. fractionPart := self nextUnsignedIntegerOrNil. leadingZeroesAllowed := oldLeadingZeroesAllowed. fractionPart ifNil: [ self error: 'Missing fraction part!!' ]. fractionPart isZero ifTrue: [ self readExponent ifFalse: [ negative ifTrue: [ integerPart isZero ifTrue: [ ^Float negativeZero ]. ^integerPart negated ]. ^integerPart ]. exponent >= 0 ifTrue: [ negative ifTrue: [ integerPart := integerPart negated ]. ^integerPart * (self fiveRaisedTo: exponent) bitShift: exponent ]. value := self makeFloatFromMantissa: integerPart exponent: exponent. negative ifTrue: [ ^value negated ]. ^value ]. numberOfTrailingZeroInFractionPart := nDigits - lastNonZero. numberOfNonZeroFractionDigits := lastNonZero. self readExponent. exponent := exponent - numberOfNonZeroFractionDigits. mantissa := (integerPart * (self fiveRaisedTo: numberOfNonZeroFractionDigits) bitShift: numberOfNonZeroFractionDigits) + (fractionPart // (self fiveRaisedTo: numberOfTrailingZeroInFractionPart) bitShift: 0 - numberOfTrailingZeroInFractionPart). value := self makeFloatFromMantissa: mantissa exponent: exponent. negative ifTrue: [ ^value negated ]. ^value! ----- Method: JsonNumberParser>>nextUnsignedIntegerOrNil (in category 'parsing-public') ----- nextUnsignedIntegerOrNil "Form an unsigned integer with incoming digits from sourceStream. Answer this integer, or nil if no digit found. Count the number of digits and the position of lastNonZero digit and store them in instVar" | nPackets high nDigitsHigh lastNonZeroHigh low | "read no more digits than one elementary LargeInteger" high := self nextElementaryLargeInteger. nDigits = 0 ifTrue: [^nil]. "Not enough digits to form a LargeInteger, stop iteration" high isLarge ifFalse: [^high]. "We now have to engage arithmetic with LargeInteger Decompose the integer in a high and low packets of growing size:" nPackets := 1. nDigitsHigh := nDigits. lastNonZeroHigh := lastNonZero. [ low := self nextLargeIntegerBase: 10 nPackets: nPackets . high := (high * (self fiveRaisedTo: nDigits) bitShift: nDigits) + low. lastNonZero = 0 ifFalse: [lastNonZeroHigh := lastNonZero + nDigitsHigh]. nDigitsHigh := nDigitsHigh + nDigits. low isLarge] whileTrue: [nPackets := nPackets * 2]. nDigits := nDigitsHigh. lastNonZero := lastNonZeroHigh. ^high! ----- Method: ScaledDecimal>>jsonWriteOn: (in category '*JSON-writing') ----- jsonWriteOn: stream self printOn: stream showingDecimalPlaces: scale! ----- Method: Collection>>jsonWriteOn: (in category '*json') ----- jsonWriteOn: aStream "By default, use array braces " aStream nextPut: $[. self do: [:each | each jsonWriteOn: aStream ] separatedBy: [ aStream nextPut: $, ]. aStream nextPut: $]! TestCase subclass: #JsonTests instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'JSON'! !JsonTests commentStamp: '<historical>' prior: 0! I provide a number of test cases for class Json.! ----- Method: JsonTests>>assertIncompleteJson: (in category 'helpers') ----- assertIncompleteJson: aString self should: [self readFrom: aString] raise: JsonIncompleteError! ----- Method: JsonTests>>assertInvalidJson: (in category 'helpers') ----- assertInvalidJson: aString self should: [self readFrom: aString] raise: JsonInvalidError! ----- Method: JsonTests>>json:equals: (in category 'helpers') ----- json: aString equals: aValue | readValue | readValue := self readFrom: aString. self assert: aValue equals: readValue! ----- Method: JsonTests>>readFrom: (in category 'helpers') ----- readFrom: aString ^ (Json newWithConstructors: {JsonDummyTestObject.}) readFrom: aString readStream ! ----- Method: JsonTests>>render:equals: (in category 'helpers') ----- render: anObject equals: aString self assert: (Json render: anObject) = aString! ----- Method: JsonTests>>simpleDummyObject (in category 'helpers') ----- simpleDummyObject ^ JsonDummyTestObject new a: 1; b: 2; c: 3; yourself! ----- Method: JsonTests>>testArray (in category 'tests') ----- testArray self json: '[]' equals: #(). self json: '[[]]' equals: #(#()). self json: '[[], []]' equals: #(#() #()). self json: '["hi", "there"]' equals: #('hi' 'there'). self json: '[["a", "b", null]]' equals: #(('a' 'b' nil)).! ----- Method: JsonTests>>testAtomFalse (in category 'tests') ----- testAtomFalse self json: 'false' equals: false. self json: ' false' equals: false. self json: 'false ' equals: false. self json: ' false ' equals: false. ! ----- Method: JsonTests>>testAtomNull (in category 'tests') ----- testAtomNull self json: 'null' equals: nil. self json: ' null' equals: nil. self json: 'null ' equals: nil. self json: ' null ' equals: nil. ! ----- Method: JsonTests>>testAtomNumber (in category 'tests') ----- testAtomNumber self json: '1' equals: 1. self json: '123' equals: 123. self should: [ self json: '0123' equals: 123 ] raise: JsonSyntaxError. "No leading zeroes." self json: '1.23e2' equals: 123. self json: '-1' equals: -1. self json: '-0' equals: 0. self json: '[-1.2]' equals: #(-1.2).! ----- Method: JsonTests>>testAtomString (in category 'tests') ----- testAtomString self json: '"hi"' equals: 'hi'. self json: '"\""' equals: '"'. self json: '"\\"' equals: '\'. self json: '""' equals: ''. self json: '"a\u0004b"' equals: ({$a. Character value: 4. $b} as: String). self json: '"a\nb"' equals: ({$a. Character lf. $b} as: String). self json: '"a\uD834\uDD1Eb"' equals: ({$a. Character value: 16r1D11E. $b} as: String). ! ----- Method: JsonTests>>testAtomTrue (in category 'tests') ----- testAtomTrue self json: 'true' equals: true. self json: ' true' equals: true. self json: 'true ' equals: true. self json: ' true ' equals: true. ! ----- Method: JsonTests>>testCtor (in category 'tests') ----- testCtor self json: '@JsonDummyTestObject {"a": 1, "b": 2, "c": 3}' equals: self simpleDummyObject. self json: (Json render: self simpleDummyObject) equals: self simpleDummyObject.! ----- Method: JsonTests>>testDictionary (in category 'tests') ----- testDictionary self json: '{}' equals: (JsonObject new). self json: '{"a": "a"}' equals: (JsonObject new at: 'a' put: 'a'; yourself). self json: '{"a": [[]]}' equals: (JsonObject new at: 'a' put: #(#()); yourself). self json: '{"a":"b", "b":"a"}' equals: (JsonObject new add: 'a'->'b'; add: 'b'->'a';yourself).! ----- Method: JsonTests>>testDictionaryClass (in category 'tests') ----- testDictionaryClass | parser | parser := Json new. self assert: (parser readFrom: '{}' readStream) class == JsonObject. parser dictionaryClass: OrderedJsonObject. self assert: (parser readFrom: '{}' readStream) class == OrderedJsonObject. self assert: (parser readFrom: '{"x":{"y":{}}}' readStream) x y class == OrderedJsonObject! ----- Method: JsonTests>>testIncomplete (in category 'tests') ----- testIncomplete self assertIncompleteJson: ''. self assertIncompleteJson: ' '. self assertIncompleteJson: ' tr'. self assertIncompleteJson: 'tru'. self assertIncompleteJson: '['. self assertIncompleteJson: '[true'. self assertIncompleteJson: '[true,'. self assertIncompleteJson: '{'. self assertIncompleteJson: '{"hi"'. self assertIncompleteJson: '{"hi":'. self assertIncompleteJson: '{"hi":true'. self assertIncompleteJson: '{"hi":true,'. self assertIncompleteJson: '{"hi":true,"'. self assertIncompleteJson: '"hello'. self assertIncompleteJson: '"hello '. self assertIncompleteJson: '"hello\'. self assertIncompleteJson: '"\u26'.! ----- Method: JsonTests>>testInvalid (in category 'tests') ----- testInvalid self assertInvalidJson: 'x'. self assertInvalidJson: ' x'. self assertInvalidJson: ' trx'. self assertInvalidJson: 'trux'. self assertInvalidJson: '.'. self assertInvalidJson: ':'. self assertInvalidJson: ','. self assertInvalidJson: ']'. self assertInvalidJson: '}'. self assertInvalidJson: '[x'. self assertInvalidJson: '[true t'. self assertInvalidJson: '[true,]'. self assertInvalidJson: '{]'. self assertInvalidJson: '{,'. self assertInvalidJson: '{"hi",'. self assertInvalidJson: '{"hi":x'. self assertInvalidJson: '{"hi":,'. self assertInvalidJson: '{"hi":true "'. self assertInvalidJson: '{"hi":true,}'. self assertInvalidJson: '\u263A'.! ----- Method: JsonTests>>testInvalidUnicodeEscapes (in category 'tests') ----- testInvalidUnicodeEscapes self assertInvalidJson: '"\u26"'. "Note that naively reading four chars runs off the end here, so we might see JsonIncompleteError, which would be wrong." self assertInvalidJson: '"\u2Z"'. self assertInvalidJson: '"\u2Z44"'.! ----- Method: JsonTests>>testJsonObjectAtPutReturnsTheObject (in category 'tests') ----- testJsonObjectAtPutReturnsTheObject { JsonObject. OrderedJsonObject } do: [ :jsonObjectClass | | json | json := jsonObjectClass new. self assert: (json at: 'foo' put: 1) == json. self assert: (json foo: 1) == json ]! ----- Method: JsonTests>>testMissingCtor (in category 'tests') ----- testMissingCtor self assertInvalidJson: '@Missing[]'! ----- Method: JsonTests>>testMissingCtorNoMap (in category 'tests') ----- testMissingCtorNoMap self should: [Json new readFrom: '@Missing[]' readStream] raise: JsonInvalidError! ----- Method: JsonTests>>testNonStringKeysRaiseError (in category 'tests') ----- testNonStringKeysRaiseError { JsonObject. OrderedJsonObject } do: [ :jsonObjectClass | | json | json := jsonObjectClass new. self should: [ json at: 1 put: 1 ] raise: Error. self assert: json isEmpty. json at: '1' put: 1. self assert: 1 equals: (json at: '1') ]! ----- Method: JsonTests>>testStreaming (in category 'tests') ----- testStreaming | j | j := Json new stream: 'truefalsetrue[]{}1.234 5.678"A""B"nullnull' readStream. self assert: j readAny equals: true. self assert: j readAny equals: false. self assert: j readAny equals: true. self assert: j readAny equals: #(). self assert: j readAny equals: JsonObject new. self assert: j readAny equals: 1.234. self assert: j readAny equals: 5.678. self assert: j readAny equals: 'A'. self assert: j readAny equals: 'B'. self assert: j readAny equals: nil. self assert: j readAny equals: nil.! ----- Method: JsonTests>>testStringWithUnicode (in category 'tests') ----- testStringWithUnicode | unicodeString | unicodeString := (Unicode value: 16r263A) asString. self json: '"\u263A"' equals:unicodeString. self json: '"\u263a"' equals:unicodeString. self json: '"', unicodeString, '"' equals: unicodeString. self render: unicodeString equals: '"', unicodeString, '"'.! ----- Method: JsonTests>>testWriteAssociation (in category 'tests') ----- testWriteAssociation self render: 'key' -> 'value' equals: '"key": "value"'. self render: 'key' -> 2 equals: '"key": 2'. "keys should be strings" self render: 42 -> 2 equals: '"42": 2'. "try to do _something_ for more complex keys" self render: #(42 43 44) -> 2 equals: '"#(42 43 44)": 2'. ! ----- Method: JsonTests>>testWriteString (in category 'tests') ----- testWriteString self render: '"' equals: '"\""'. self render: '\' equals: '"\\"'. self render: 'hi' equals: '"hi"'. self render: ({$a. Character lf. $b} as: String) equals: '"a\nb"'. self render: ({$a. Character value: 4. $b} as: String) equals: '"a\u0004b"'.! ----- Method: String>>asSerializedJson (in category '*JSON') ----- asSerializedJson " Assume that the receiver is a valid serialized json string. Return an object that understands #jsonWriteOn: and will write this string on its argument. " ^SerializedJson on: self! ----- Method: String>>jsonWriteOn: (in category '*JSON-writing') ----- jsonWriteOn: aStream | index start | aStream nextPut: $". start := 1. [ (index := self indexOfAnyOf: Json escapeSet startingAt: start) = 0 ] whileFalse: [ aStream next: index - start putAll: self startingAt: start. aStream nextPutAll: (Json escapeForCharacter: (self at: index)). start := index + 1 ]. start <= self size ifTrue: [ aStream next: self size + 1 - start putAll: self startingAt: start ]. aStream nextPut: $". ! ----- Method: String>>parseAsJson (in category '*JSON') ----- parseAsJson "Convenience" ^Json readFrom: self readStream! ----- Method: String>>parseAsOrderedJson (in category '*JSON') ----- parseAsOrderedJson "Convenience" ^Json new dictionaryClass: OrderedJsonObject; readFrom: self readStream! Object subclass: #Json instanceVariableNames: 'stream currentCharacter arrayBufferStream stringBufferStream numberParser ctorMap dictionaryClass' classVariableNames: '' poolDictionaries: '' category: 'JSON'! Json class instanceVariableNames: 'escapeArray escapeSet'! !Json commentStamp: 'ul 3/29/2016 04:38' prior: 0! I support reading and writing JSON (see http://json.org) formatted data - strings, numbers, boolean, nil, arrays and dictionaries. The implementation is mainly based on RFC 7159 (https://www.ietf.org/rfc/rfc7159.txt). It has been extended with syntax for invoking a prearranged list of constructors on read objects. Character encoding is not handled here. That's something you have to do before reading or after writing. Mixed processing is possible, but it's entirely your responsibility to keep things correct. Instance Variables stream: <PositionableStream> currentCharacter: <Character> arrayBufferStream: <WriteStream> stringBufferStream: <ReadWriteStream> numberParser: <ExtendedNumberParser> ctorMap: <Dictionary> For parsing, stream has to be initialized by sending #readFrom: to my instance. The parser will pre-read one character, which will be stored in currentCharacter, so the stream is expected to support position manipulation, hence it should be a PositionableStream. arrayBufferStream is WriteStream on an Array, which holds the values during array parsing (see #readArray). When there's a recursive call, this stream is used as a stack to separate the elements parsed in the previous invocation from the current one. stringBufferStream is a ReadWriteStream on a String, which holds the currently parsed String (see #readString), the currently parsed number (see #readNumber) or the name of the currently parsed constructor (see #readConstructor). Recursion has no effect on this. numberParser is a cached instance of ExtendedNumberParser. It's initialized on stringBufferStream, so it can quickly parse the number stored in it. ctorMap is the Dictionary holding the constructor classes by name. arrayBufferStream, stringBufferStream and numberParser are initialized lazily, and should not be accessed externally. Since these are shared objects, along with stream and currentCharacter, holding state, therefore a single instance of me shouldn't be used to parse multiple streams at the same time. For writing, you can use the methods in the class-side rendering category. To convert individual objects to a string, you can use #asJsonString, to serialize it on a stream, you can use #jsonWriteOn:. ! Json class instanceVariableNames: 'escapeArray escapeSet'! ----- Method: Json class>>escapeForCharacter: (in category 'accessing') ----- escapeForCharacter: c | asciiValue | (asciiValue := c asciiValue) < 128 ifTrue: [ ^escapeArray at: asciiValue + 1 ]. ^nil! ----- Method: Json class>>escapeSet (in category 'accessing') ----- escapeSet ^escapeSet! ----- Method: Json class>>initialize (in category 'class initialization') ----- initialize "Json initialize." | newEscapeArray newEscapeSet | newEscapeArray := Array new: 128. newEscapeSet := CharacterSet new. (0 to: 31), #(127) do: [ :each | newEscapeArray at: each + 1 put: '\u', (each printStringHex padded: #left to: 4 with: $0). newEscapeSet add: (Character value: each) ]. { $" -> '\"'. $\ -> '\\'. $/ -> '\/'. "A hack, so the generated JSON will always be HTML+Javascript compatible, because the generated JSON will not contain the seqence </script>." Character backspace -> '\b'. Character lf -> '\n'. Character newPage -> '\f'. Character cr -> '\r'. Character tab -> '\t'. } do: [ :each | newEscapeArray at: each key asciiValue + 1 put: each value. newEscapeSet add: each key ]. escapeArray := newEscapeArray. escapeSet := newEscapeSet! ----- Method: Json class>>mimeType (in category 'accessing') ----- mimeType ^'application/json'! ----- Method: Json class>>newWithConstructors: (in category 'instance creation') ----- newWithConstructors: aCollection | m | m := Dictionary new. aCollection do: [:each | (each isKindOf: Association) ifTrue: [m add: each] ifFalse: [m at: each name asString put: each]]. ^ self new ctorMap: m; yourself.! ----- Method: Json class>>readFrom: (in category 'instance creation') ----- readFrom: aStream ^ self new readFrom: aStream.! ----- Method: Json class>>render: (in category 'rendering') ----- render: anObject ^String streamContents: [ :stream | anObject jsonWriteOn: stream ]! ----- Method: Json class>>render:withConstructor:on: (in category 'rendering') ----- render: anObject withConstructor: aConstructorName on: aStream aStream nextPutAll: '@', aConstructorName. anObject jsonWriteOn: aStream. ! ----- Method: Json class>>renderInstanceVariables:of:on: (in category 'rendering') ----- renderInstanceVariables: aCollection of: anObject on: aStream | map | map := Dictionary new. aCollection do: [:ivarName | map at: ivarName put: (anObject instVarNamed: ivarName)]. self render: map withConstructor: anObject class name asString on: aStream! ----- Method: Json>>arrayBufferStream (in category 'private') ----- arrayBufferStream ^arrayBufferStream ifNil: [ arrayBufferStream := (Array new: 10) writeStream ]! ----- Method: Json>>consume: (in category 'private') ----- consume: aString | message | 1 to: aString size do: [ :index | (currentCharacter := stream next) == (aString at: index) ifFalse: [ message := 'Expected ', (aString at: index) printString. currentCharacter ifNil: [ self incomplete: message ] ifNotNil: [ self invalid: message ] ] ]. currentCharacter := stream next! ----- Method: Json>>ctorMap (in category 'accessing') ----- ctorMap ^ ctorMap! ----- Method: Json>>ctorMap: (in category 'accessing') ----- ctorMap: m ctorMap := m! ----- Method: Json>>dictionaryClass: (in category 'accessing') ----- dictionaryClass: aClass "This method allows you to override the default dictionary class to be created while parsing a stream. Instances of aClass are expected to understand #at:put:." dictionaryClass := aClass! ----- Method: Json>>error: (in category 'error handling') ----- error: aString (currentCharacter isNil and: [ stream atEnd ]) ifTrue: [ self incomplete: aString ] ifFalse: [ self invalid: aString ]! ----- Method: Json>>incomplete: (in category 'error handling') ----- incomplete: aString JsonIncompleteError signal: aString! ----- Method: Json>>initialize (in category 'initialize-release') ----- initialize dictionaryClass := JsonObject ! ----- Method: Json>>interpretStringEscape: (in category 'private') ----- interpretStringEscape: aCharacter aCharacter == $b ifTrue: [ ^Character backspace ]. aCharacter == $n ifTrue: [ ^Character lf ]. aCharacter == $f ifTrue: [ ^Character newPage ]. aCharacter == $r ifTrue: [ ^Character cr ]. aCharacter == $t ifTrue: [ ^Character tab ]. aCharacter == $u ifTrue: [ ^self unescapeUnicode ]. aCharacter == $" ifTrue: [ ^aCharacter ]. aCharacter == $\ ifTrue: [ ^aCharacter ]. aCharacter == $/ ifTrue: [ ^aCharacter ]. self error: 'Unexpected escaped character: ', aCharacter asString ! ----- Method: Json>>invalid: (in category 'error handling') ----- invalid: aString JsonInvalidError signal: aString! ----- Method: Json>>readAny (in category 'private') ----- readAny self skipWhitespace. currentCharacter == ${ ifTrue: [ ^self readDictionary ]. currentCharacter == $[ ifTrue: [ ^self readArray ]. currentCharacter == $" ifTrue: [ ^self readString ]. currentCharacter == $t ifTrue: [ self consume: 'rue'. ^true ]. currentCharacter == $f ifTrue: [ self consume: 'alse'. ^false ]. currentCharacter == $n ifTrue: [ self consume: 'ull'. ^nil ]. currentCharacter == $- ifTrue: [ ^self readNumber: true ]. (#($0 $1 $2 $3 $4 $5 $6 $7 $8 $9) instVarsInclude: currentCharacter) ifTrue: [ ^self readNumber: false ]. currentCharacter == $@ ifTrue: [ ^self readConstructor ]. self invalid: 'Unknown Json input'! ----- Method: Json>>readArray (in category 'private') ----- readArray | initialPosition | currentCharacter := stream next. self skipWhitespace. currentCharacter == $] ifTrue: [ currentCharacter := stream next. ^#() ]. initialPosition := self arrayBufferStream position. [ arrayBufferStream nextPut: self readAny. self skipWhitespace. currentCharacter == $] ifTrue: [ | result | result := arrayBufferStream originalContents copyFrom: initialPosition + 1 to: arrayBufferStream position. arrayBufferStream position: initialPosition. currentCharacter := stream next. ^result ]. currentCharacter == $, ifFalse: [ self error: 'Unexpected character: ', currentCharacter asString ]. currentCharacter := stream next ] repeat. ! ----- Method: Json>>readConstructor (in category 'private') ----- readConstructor ctorMap ifNil: [ ^self error: 'No constructors were declared.' ]. self resetStringBufferStream. [ (currentCharacter := stream next) == $. or: [ currentCharacter isLetter ] ] whileTrue: [ stringBufferStream nextPut: currentCharacter ]. (ctorMap at: stringBufferStream contents ifAbsent: nil) ifNotNil: [ :constructor | ^constructor constructFromJson: self readAny ]. self error: 'Unknown constructor: ', stringBufferStream contents! ----- Method: Json>>readDictionary (in category 'private') ----- readDictionary | result key commaNeeded | result := dictionaryClass new. commaNeeded := false. currentCharacter := stream next. [ self skipWhitespace. currentCharacter == $} ifTrue: [ currentCharacter := stream next. ^result ]. commaNeeded ifFalse: [ commaNeeded := true ] ifTrue: [ currentCharacter == $, ifFalse: [ self error: 'Missing comma' ]. currentCharacter := stream next. self skipWhitespace ]. currentCharacter == $" ifFalse: [ self error: 'Key in dictionary must be string' ]. key := self readString. self skipWhitespace. currentCharacter == $: ifFalse: [ self error: 'Missing colon' ]. currentCharacter := stream next. result at: key put: self readAny ] repeat! ----- Method: Json>>readFrom: (in category 'parsing') ----- readFrom: aStream | result | stream := aStream. numberParser ifNotNil: [ numberParser on: stream ]. currentCharacter := stream next. result := self readAny. currentCharacter ifNotNil: [ stream skip: -1 ]. "Undo prereading." ^result! ----- Method: Json>>readNumber: (in category 'private') ----- readNumber: negative | result | negative ifFalse: [ stream skip: -1 ]. result := (numberParser ifNil: [ numberParser := JsonNumberParser new on: stream; failBlock: [ self error: 'Invalid number.' ]; yourself ]) nextNumber: negative. currentCharacter := stream next. ^result ! ----- Method: Json>>readString (in category 'private') ----- readString self resetStringBufferStream. [ currentCharacter := stream next ifNil: [self incomplete: 'Unexpected end of string' ]. currentCharacter == $" ifTrue: [ currentCharacter := stream next. ^stringBufferStream contents ]. currentCharacter == $\ ifTrue: [ stringBufferStream nextPut: (self interpretStringEscape: (stream next ifNil: [ self incomplete: 'Unexpected end of string' ])) ] ifFalse: [ stringBufferStream nextPut: currentCharacter ] ] repeat! ----- Method: Json>>resetStringBufferStream (in category 'private') ----- resetStringBufferStream stringBufferStream ifNil: [ stringBufferStream := ReadWriteStream on: (String new: 64) ] ifNotNil: [ stringBufferStream resetToStart ]! ----- Method: Json>>skipWhitespace (in category 'private') ----- skipWhitespace currentCharacter ifNil: [ self incomplete: 'Input stream is empty' ]. [ currentCharacter isSeparator ] whileTrue: [ currentCharacter := stream next ifNil: [ self incomplete: 'Input stream is empty' ]. ]! ----- Method: Json>>stream (in category 'accessing') ----- stream "Answer the value of stream" ^ stream! ----- Method: Json>>stream: (in category 'private') ----- stream: aStream "For testing purposes only" stream := aStream. numberParser ifNotNil: [ numberParser on: stream ]. currentCharacter := stream next! ----- Method: Json>>unescapeUnicode (in category 'private') ----- unescapeUnicode | code digitValue lowSurrogateCode | code := 0. 1 to: 4 do: [ :index | (digitValue := (stream next ifNil: [ self incomplete: 'Unexpected end of stream' ]) digitValue) < 0 ifTrue: [ self invalid: 'Invalid hexadecimal digit' ]. digitValue < 16 ifTrue: [ code := code * 16 + digitValue ] ifFalse: [ self invalid: 'Invalid hexadecimal digit' ] ]. code < 16rD800 ifTrue: [ ^code asCharacter ]. code > 16rDFFF ifTrue: [ ^code asCharacter ]. code <= 16rDBFF ifFalse: [ self invalid: 'High surrogate value expected' ]. "Parse the escaped low surrogate" (stream next ifNil: [ self incomplete: 'Unexpected end of string' ]) == $\ ifFalse: [ self invalid: 'Escaped low surrogate expected.' ]. (stream next ifNil: [ self incomplete: 'Unexpected end of string' ]) == $u ifFalse: [ self invalid: 'Escaped low surrogate expected.' ]. lowSurrogateCode := 0. 1 to: 4 do: [ :index | (digitValue := (stream next ifNil: [ self incomplete: 'Unexpected end of stream' ]) digitValue) < 0 ifTrue: [ self invalid: 'Invalid hexadecimal digit' ]. digitValue < 16 ifTrue: [ lowSurrogateCode := lowSurrogateCode * 16 + digitValue ] ifFalse: [ self invalid: 'Invalid hexadecimal digit' ] ]. (lowSurrogateCode >= 16rDC00 and: [ lowSurrogateCode <= 16rDFFF ]) ifFalse: [ ^self invalid: 'Escaped low surrogate expected.' ]. ^((code - 16rD800 bitShift: 10) + lowSurrogateCode + '16r2400') asCharacter! Object subclass: #JsonDummyTestObject instanceVariableNames: 'a b c' classVariableNames: '' poolDictionaries: '' category: 'JSON'! ----- Method: JsonDummyTestObject class>>constructFromJson: (in category 'as yet unclassified') ----- constructFromJson: j ^ self new a: (j at: 'a'); b: (j at: 'b'); c: (j at: 'c'); yourself! ----- Method: JsonDummyTestObject>>= (in category 'as yet unclassified') ----- = other ^ other class == self class and: [ a = other a and: [ b = other b and: [ c = other c]]]! ----- Method: JsonDummyTestObject>>a (in category 'accessing') ----- a "Answer the value of a" ^ a! ----- Method: JsonDummyTestObject>>a: (in category 'accessing') ----- a: anObject "Set the value of a" a := anObject! ----- Method: JsonDummyTestObject>>b (in category 'accessing') ----- b "Answer the value of b" ^ b! ----- Method: JsonDummyTestObject>>b: (in category 'accessing') ----- b: anObject "Set the value of b" b := anObject! ----- Method: JsonDummyTestObject>>c (in category 'accessing') ----- c "Answer the value of c" ^ c! ----- Method: JsonDummyTestObject>>c: (in category 'accessing') ----- c: anObject "Set the value of c" c := anObject! ----- Method: JsonDummyTestObject>>jsonWriteOn: (in category 'as yet unclassified') ----- jsonWriteOn: s Json renderInstanceVariables: {#a. #b. #c} of: self on: s ! ----- Method: Object>>asJsonString (in category '*JSON') ----- asJsonString ^ String streamContents: [:str | self jsonWriteOn: str ]! Object subclass: #SerializedJson instanceVariableNames: 'jsonString' classVariableNames: '' poolDictionaries: '' category: 'JSON'! ----- Method: SerializedJson class>>on: (in category 'instance creation') ----- on: aString ^self new jsonString: aString; yourself! ----- Method: SerializedJson>>jsonString (in category 'accessing') ----- jsonString ^jsonString ! ----- Method: SerializedJson>>jsonString: (in category 'accessing') ----- jsonString: aString jsonString := aString ! ----- Method: SerializedJson>>jsonWriteOn: (in category 'json-writing') ----- jsonWriteOn: stream stream nextPutAll: jsonString!

1 0

The Trunk: Morphic-tonyg.1997.mcz
by commits＠source.squeak.org 24 May '22

24 May '22

Tony Garnock-Jones uploaded a new version of Morphic to project The Trunk: http://source.squeak.org/trunk/Morphic-tonyg.1997.mcz ==================== Summary ==================== Name: Morphic-tonyg.1997 Author: tonyg Time: 24 May 2022, 9:56:56.627629 am UUID: ea8cb549-5895-4ad8-8fde-4fcb6ea5594e Ancestors: Morphic-ct.1996 Repair bug that caused unconditional clearing of the #mouseOverForKeyboardFocus preference whenever the host window was de/reactivated. Symptoms: switching away from Squeak and back (or save-and-quit followed by reopen) while #mouseOverForKeyboardFocus enabled would cause it to become disabled. Cause: PasteUpMorph>>#windowEvent: was clearing the preference and then restoring it from state in a WindowHostFocusMorph. However, when #windowDeactivated occurred twice in a row (which happens), it would correctly store #mouseOverForKeyboardFocus in the first WindowHostFocusMorph instance, but then would deactivate and replace that instance with a fresh one, which would then receive the incorrect (false) value of #mouseOverForKeyboardFocus. Later, when the window was activated again, the incorrect value would be restored, because the correct value had already been forgotten (as it was contained in the first, rather than the second-and-current, WindowHostFocusMorph instance). Change: Alter WindowHostFocusMorph>>#active: to not only set the active instvar but to save or restore the #mouseOverForKeyboardFocus preference. This way, any time a WindowHostFocusMorph is activated, the preference is saved, and any time it is deactivated, the preference is restored. This works with the current logic in PasteUpMorph>>#windowEvent:. One drawback is that it repeatedly toggles the preference, depending on how many redundant de/reactivation events the host sends us in a row, but the final value of the preference is at least correct now (I hope!). =============== Diff against Morphic-ct.1996 =============== Item was changed: ----- Method: PasteUpMorph>>windowEvent: (in category 'event handling') ----- windowEvent: anEvent self windowEventHandler ifNotNil: [^self windowEventHandler windowEvent: anEvent]. anEvent type caseOf: { [#windowClose] -> [ Preferences eToyFriendly ifTrue: [ProjectNavigationMorph basicNew quitSqueak] ifFalse: [TheWorldMenu basicNew quitSession]]. [#windowDeactivated] -> [ + "The host window has been deactivated. Until it regains the focus, honor the fact that we will not receive keyboard events again by changing the current keyboard focus morph. windowHostFocusMorph represents the host system which now holds the keyboard focus instead of the previousFocus." - "The host window has been deactivated. Until it regains the focus, honor the fact that we will not receive keyboard events again by changing the current keyboard focus morph. windowHostFocusMorph represents the host system which now holds the keyboard focus instead of the previousFocus. If enabled, disable #mouseOverForKeyboardFocus temporarily because when inactive, we *can't* set the externally controlled keyboard focus." (self valueOfProperty: #windowHostFocusMorph) ifNotNil: [:hostFocus | "There is currently no exact-once guarantee for this event type from the VM. Mark any older host focus morph as inactive, it will be held as the previousFocus of the next host focus morph." hostFocus active: false]. self setProperty: #windowHostFocusMorph toValue: (WindowHostFocusMorph new in: [:hostFocus | hostFocus previousFocus: anEvent hand keyboardFocus. + anEvent hand newKeyboardFocus: hostFocus.]; - anEvent hand newKeyboardFocus: hostFocus. - Preferences mouseOverForKeyboardFocus ifTrue: [ - hostFocus previousMouseOverForKeyboardFocus: true. - Preferences setPreference: #mouseOverForKeyboardFocus toValue: false]]; yourself)]. [#windowActivated] -> [ + "Alright, the spook is over!! We have back control over the keyboard focus, delete the windowHostFocusMorph and restore the previous focus holder." - "Alright, the spook is over!! We have back control over the keyboard focus, delete the windowHostFocusMorph and restore the previous focus holder and the #mouseOverForKeyboardFocus preference." (self removeProperty: #windowHostFocusMorph) ifNotNil: [:hostFocus | hostFocus active: false. (anEvent hand keyboardFocus == hostFocus and: [hostFocus previousFocus notNil]) ifTrue: + [anEvent hand newKeyboardFocus: hostFocus previousFocus]]]. } - [anEvent hand newKeyboardFocus: hostFocus previousFocus]. - hostFocus previousMouseOverForKeyboardFocus ifNotNil: [:value | - Preferences setPreference: #mouseOverForKeyboardFocus toValue: value]]]. } otherwise: []! Item was changed: ----- Method: WindowHostFocusMorph>>active: (in category 'accessing') ----- active: aBoolean + active := aBoolean. + active + ifTrue: [ + "If #mouseOverForKeyboardFocus is enabled, disable it temporarily because when WindowHostFocusMorph 'has the focus', Squeak as a whole *doesn't*, and we *can't* set the externally controlled keyboard focus." + self saveMouseOverForKeyboardFocus] + ifFalse: [ + "Restore the #mouseOverForKeyboardFocus preference that we (maybe) saved when we were activated." + self restoreMouseOverForKeyboardFocus]! - active := aBoolean.! Item was removed: - ----- Method: WindowHostFocusMorph>>previousMouseOverForKeyboardFocus (in category 'accessing') ----- - previousMouseOverForKeyboardFocus - - ^ previousMouseOverForKeyboardFocus! Item was removed: - ----- Method: WindowHostFocusMorph>>previousMouseOverForKeyboardFocus: (in category 'accessing') ----- - previousMouseOverForKeyboardFocus: aBoolean - - previousMouseOverForKeyboardFocus := aBoolean.! Item was added: + ----- Method: WindowHostFocusMorph>>restoreMouseOverForKeyboardFocus (in category 'accessing') ----- + restoreMouseOverForKeyboardFocus + previousMouseOverForKeyboardFocus ifNotNil: [:value | + previousMouseOverForKeyboardFocus := nil. + Preferences setPreference: #mouseOverForKeyboardFocus toValue: value].! Item was added: + ----- Method: WindowHostFocusMorph>>saveMouseOverForKeyboardFocus (in category 'accessing') ----- + saveMouseOverForKeyboardFocus + Preferences mouseOverForKeyboardFocus ifTrue: [ + previousMouseOverForKeyboardFocus := true. + Preferences setPreference: #mouseOverForKeyboardFocus toValue: false].!

1 0

The Trunk: Kernel-dtl.1468.mcz
by commits＠source.squeak.org 20 May '22

20 May '22

David T. Lewis uploaded a new version of Kernel to project The Trunk: http://source.squeak.org/trunk/Kernel-dtl.1468.mcz ==================== Summary ==================== Name: Kernel-dtl.1468 Author: dtl Time: 19 May 2022, 9:00:06.652582 pm UUID: 2a84fd00-259d-40ea-b8f4-a979ce108064 Ancestors: Kernel-dtl.1467 Sista bytecode set was activated in trunk as of Kernel-dtl.1310 (Mar 2020) which called a then-unimplemented primitive to inform the VM to update the image format number. The VM support is present now, and this package postscript updates the image format number, which will now be 68533 (64 bit image) or 7033 (32 bit image). Also add a missing #primitiveFailed to CompiledCode class>>multipleBytecodeSetsActive =============== Diff against Kernel-dtl.1467 =============== Item was changed: ----- Method: CompiledCode class>>multipleBytecodeSetsActive (in category 'method encoding') ----- multipleBytecodeSetsActive "Answer if the VM supports multiple bytecode sets, typically the Sista bytecodes in addition to the traditional V3 bytecode set." <primitive: 'primitiveMultipleBytecodeSetsActive'> + self primitiveFailed ! Item was changed: + (PackageInfo named: 'Kernel') postscript: '"Inform the VM that it should update its image format number for multiple bytecode sets" + [CompiledCode byteCodeSetsKnownToTheVM. + CompiledCode preferredBytecodeSetEncoderClass = EncoderForSistaV1 + ifTrue: [CompiledCode multipleBytecodeSetsActive: true]] + on: Error do: ["missing VM support, do nothing"]'! - (PackageInfo named: 'Kernel') postscript: 'Smalltalk removeClassNamed: #ExceptionAboutToReturn.'!

1 0

The Trunk: System-ct.1353.mcz
by commits＠source.squeak.org 20 May '22

20 May '22

Christoph Thiede uploaded a new version of System to project The Trunk: http://source.squeak.org/trunk/System-ct.1353.mcz ==================== Summary ==================== Name: System-ct.1353 Author: ct Time: 20 May 2022, 6:33:48.570152 pm UUID: 987f867b-8119-0a4a-afa0-1802d8d33678 Ancestors: System-mt.1352 Moves extension method into the 60Deprecated package it belongs to. FYO: When deprecating a class, all extension categories need to be renamed so that the extension methods actually go into the deprecated package as well, if that is desired. =============== Diff against System-mt.1352 =============== Item was removed: - ----- Method: TTFileDescription>>profileAll (in category '*System-Tools-profiling') ----- - profileAll - "Profile reading all the glyphs" - MessageTally spyOn:[ - 1 to: numGlyphs do:[:glyphIndex| self readGlyphAt: glyphIndex-1]. - ].!

1 0

Jump to page:

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

Packages May 2022