Packages February 2024

packages@lists.squeakfoundation.org

1 participants
58 discussions

The Trunk: Kernel-ct.1449.mcz
by commits＠source.squeak.org 25 Feb '24

25 Feb '24

Christoph Thiede uploaded a new version of Kernel to project The Trunk: http://source.squeak.org/trunk/Kernel-ct.1449.mcz ==================== Summary ==================== Name: Kernel-ct.1449 Author: ct Time: 12 March 2022, 1:51:11.452359 am UUID: 75c8b415-7b05-854e-a772-0412e6a1fd60 Ancestors: Kernel-ct.1448 Fixes handling of objects as methods in Object>>#withArgs:executeMethods:. Complements KernelTests-ct.421. There were actually two issues: 1. The fallback code in Object>>#withArgs:executeMethod: had multiple unexpected side effects because Behavior>>#basicAddSelector:withMethod: would modify the state (selector+methodClass) of the compiledMethod. If compiledMethod was not a valid CompiledMethod or object as method and did not understand #methodClass: and #selector: correctly, the #addSelectorSilently:withMethod: would have failed non-atomatically and left the method dictionary of the receiver class with a dangling auxiliary symbol key that would never be cleaned up. 2. primitive 83 (primitivePerform) and primitive 84 (primitivePerformWithArgs) must not check the arity of the selector but only the arity of the resolved method if that is not an object as method. This patch aligns the simulation of these primitives to the VM behavior so that the fallback code in Object>>#withArgs:executeMethod: also works in the simulator. =============== Diff against Kernel-nice.1447 =============== Item was changed: ----- Method: Context>>doPrimitive:method:receiver:args: (in category 'private') ----- doPrimitive: primitiveIndex method: meth receiver: receiver args: arguments "Simulate a primitive method whose index is primitiveIndex. The simulated receiver and arguments are given as arguments to this message. If successful, push result and return resuming context, else ^ {errCode, PrimitiveFailToken}. Any primitive which provokes execution needs to be intercepted and simulated to avoid execution running away." | value | "Judicious use of primitive 19 (a null primitive that doesn't do anything) prevents the debugger from entering various run-away activities such as spawning a new process, etc. Injudicious use results in the debugger not being able to debug interesting code, such as the debugger itself. Hence use primitive 19 with care :-)" "SystemNavigation new browseAllSelect: [:m| m primitive = 19]" primitiveIndex = 19 ifTrue: [ [self notify: ('The code being simulated is trying to control a process ({1}). Process controlling cannot be simulated. If you proceed, things may happen outside the observable area of the simulator.' translated format: {meth reference})] ifCurtailed: [self push: nil "Cheap fix of the context's internal state"]]. ((primitiveIndex between: 201 and: 222) and: [(self objectClass: receiver) includesBehavior: BlockClosure]) ifTrue: [(primitiveIndex = 206 or: [primitiveIndex = 208]) ifTrue: "[Full]BlockClosure>>valueWithArguments:" [^receiver simulateValueWithArguments: arguments first caller: self]. ((primitiveIndex between: 201 and: 209) "[Full]BlockClosure>>value[:value:...]" or: [primitiveIndex between: 221 and: 222]) ifTrue: "[Full]BlockClosure>>valueNoContextSwitch[:]" [^receiver simulateValueWithArguments: arguments caller: self]]. primitiveIndex = 83 ifTrue: "afr 9/11/1998 19:50" "Object>>perform:[with:...]" [| selector | selector := arguments at: 1 ifAbsent: [^ self class primitiveFailTokenFor: #'bad argument']. + ((self objectClass: receiver) lookupSelector: selector) ifNotNil: [:methodArg | + ((self objectClass: methodArg) isCompiledCodeClass and: [arguments size - 1 ~= methodArg numArgs]) + ifTrue: [^ self class primitiveFailTokenFor: #'bad number of arguments']]. - arguments size - 1 = selector numArgs ifFalse: - [^ self class primitiveFailTokenFor: #'bad number of arguments']. ^self send: selector to: receiver with: arguments allButFirst]. primitiveIndex = 84 ifTrue: "afr 9/11/1998 19:50 & eem 8/18/2009 17:04" "Object>>perform:withArguments:" [| selector args | arguments size = 2 ifFalse: [^ self class primitiveFailTokenFor: #'bad argument']. selector := arguments first. args := arguments second. args isArray ifFalse: [^ self class primitiveFailTokenFor: #'bad argument']. + ((self objectClass: receiver) lookupSelector: selector) ifNotNil: [:methodArg | + ((self objectClass: methodArg) isCompiledCodeClass and: [args size ~= methodArg numArgs]) + ifTrue: [^ self class primitiveFailTokenFor: #'bad number of arguments']]. - args size = selector numArgs ifFalse: - [^ self class primitiveFailTokenFor: #'bad number of arguments']. ^self send: selector to: receiver with: args]. primitiveIndex = 100 ifTrue: "eem 8/18/2009 16:57" "Object>>perform:withArguments:inSuperclass:" [| rcvr selector args superclass | arguments size caseOf: { [3] -> [ rcvr := receiver. selector := arguments first. args := arguments second. superclass := arguments third]. [4] -> ["mirror primitive" rcvr := arguments first. selector := arguments second. args := arguments third. superclass := arguments fourth] } otherwise: [^ self class primitiveFailTokenFor: #'bad argument']. args isArray ifFalse: [^ self class primitiveFailTokenFor: #'bad argument']. args size = selector numArgs ifFalse: [^ self class primitiveFailTokenFor: #'bad number of arguments']. ((self objectClass: rcvr) includesBehavior: superclass) ifFalse: [^ self class primitiveFailTokenFor: #'bad argument']. ^self send: selector to: rcvr with: args lookupIn: superclass]. "Mutex>>primitiveEnterCriticalSection Mutex>>primitiveTestAndSetOwnershipOfCriticalSection" (primitiveIndex = 186 or: [primitiveIndex = 187]) ifTrue: [| effective | effective := Processor activeProcess effectiveProcess. "active == effective" value := primitiveIndex = 186 ifTrue: [receiver primitiveEnterCriticalSectionOnBehalfOf: effective] ifFalse: [receiver primitiveTestAndSetOwnershipOfCriticalSectionOnBehalfOf: effective]. ^(self isPrimFailToken: value) ifTrue: [value] ifFalse: [self push: value]]. + + (primitiveIndex = 188 or: [primitiveIndex = 189]) ifTrue: - - primitiveIndex = 188 ifTrue: "Object>>withArgs:executeMethod: - CompiledMethod class>>receiver:withArguments:executeMethod: - VMMirror>>ifFail:object:with:executeMethod: et al" [| n args methodArg thisReceiver | + primitiveIndex caseOf: + {[188 "primitiveExecuteMethodArgsArray"] -> + ["Object>>withArgs:executeMethod: + CompiledMethod class>>receiver:withArguments:executeMethod: + VMMirror>>ifFail:object:with:executeMethod: et al" + ((n := arguments size) between: 2 and: 4) ifFalse: + [^self class primitiveFailTokenFor: #'unsupported operation']. + ((self objectClass: (args := arguments at: n - 1)) == Array + and: [(self objectClass: (methodArg := arguments at: n)) includesBehavior: CompiledMethod]) ifFalse: + [^self class primitiveFailTokenFor: #'bad argument']. + thisReceiver := arguments at: n - 2 ifAbsent: [receiver]]. + [189 "primitiveExecuteMethod"] -> + ["Object>>executeMethod: + Object>>with:...executeMethod:" + (arguments size > 0) ifFalse: + [^self class primitiveFailTokenFor: #'bad argument']. + ((self objectClass: (methodArg := arguments atLast: 1)) includesBehavior: CompiledMethod) ifFalse: + [^self class primitiveFailTokenFor: #'bad argument']. + args := arguments allButLast. + thisReceiver := receiver]}. - ((n := arguments size) between: 2 and: 4) ifFalse: - [^self class primitiveFailTokenFor: #'unsupported operation']. - ((self objectClass: (args := arguments at: n - 1)) == Array - and: [(self objectClass: (methodArg := arguments at: n)) includesBehavior: CompiledMethod]) ifFalse: - [^self class primitiveFailTokenFor: #'bad argument']. methodArg numArgs = args size ifFalse: [^self class primitiveFailTokenFor: #'bad number of arguments']. - thisReceiver := arguments at: n - 2 ifAbsent: [receiver]. methodArg primitive > 0 ifTrue: [methodArg isQuick ifTrue: [^self push: (methodArg valueWithReceiver: thisReceiver arguments: args)]. ^self doPrimitive: methodArg primitive method: meth receiver: thisReceiver args: args]. ^self activateMethod: methodArg withArgs: args receiver: thisReceiver]. primitiveIndex = 118 ifTrue: "[receiver:]tryPrimitive:withArgs:; avoid recursing in the VM" [(arguments size = 3 and: [(self objectClass: arguments second) == SmallInteger and: [(self objectClass: arguments last) == Array]]) ifTrue: [^self doPrimitive: arguments second method: meth receiver: arguments first args: arguments last]. (arguments size = 2 and: [(self objectClass: arguments first) == SmallInteger and: [(self objectClass: arguments last) == Array]]) ifFalse: [^self class primitiveFailTokenFor: nil]. ^self doPrimitive: arguments first method: meth receiver: receiver args: arguments last]. value := primitiveIndex = 120 "FFI method" ifTrue: [(meth literalAt: 1) tryInvokeWithArguments: arguments] ifFalse: [primitiveIndex = 117 "named primitives" ifTrue: [self tryNamedPrimitiveIn: meth for: receiver withArgs: arguments] ifFalse: "should use self receiver: receiver tryPrimitive: primitiveIndex withArgs: arguments but this is only in later VMs (and appears to be broken)" [receiver tryPrimitive: primitiveIndex withArgs: arguments]]. ^(self isPrimFailToken: value) ifTrue: [value] ifFalse: [self push: value]! Item was changed: ----- Method: Object>>withArgs:executeMethod: (in category 'message handling') ----- withArgs: argArray executeMethod: compiledMethod "Execute compiledMethod against the receiver and args in argArray" | selector | <primitive: 188> selector := Symbol new. + self class methodDict at: selector put: compiledMethod. + ^ [self perform: selector flushCache withArguments: argArray] - self class addSelectorSilently: selector withMethod: compiledMethod. - ^ [self perform: selector withArguments: argArray] ensure: [self class basicRemoveSelector: selector]!

1 0

The Trunk: Kernel-ct.1451.mcz
by commits＠source.squeak.org 25 Feb '24

25 Feb '24

Christoph Thiede uploaded a new version of Kernel to project The Trunk: http://source.squeak.org/trunk/Kernel-ct.1451.mcz ==================== Summary ==================== Name: Kernel-ct.1451 Author: ct Time: 25 March 2022, 6:47:25.617514 pm UUID: 94732d1b-58e4-9f4b-a1b3-c950af711c77 Ancestors: Kernel-nice.1447 Revises fallback code for primitive 188 (primitiveExecuteMethodArgsArray) in Object>>#withArgs:executeMethod: and eliminates any side-effects to the method dictionary. This also adds support for Objects as Methods (OaM) in this place. To achieve this, extract and reuse the simulation of method execution from Context>>#send:to:with:lookupIn:. Thanks to Eliot for the idea! This is the next iteration of Kernel-ct.1449 (inbox). The second part of that version (arity checks in sim of primitivePerform[WithArgs]) still remains relevant, though. =============== Diff against Kernel-nice.1447 =============== Item was added: + ----- Method: Context>>executeMethod:forSelector:withArgs:receiver: (in category 'controlling') ----- + executeMethod: meth forSelector: selector withArgs: arguments receiver: rcvr + + | primIndex val ctxt | + (self objectClass: meth) isCompiledCodeClass ifFalse: + ["Object as Methods (OaM) protocol: 'The contract is that, when the VM encounters an ordinary object (rather than a compiled method) in the method dictionary during lookup, it sends it the special selector #run:with:in: providing the original selector, arguments, and receiver.'. DOI: 10.1145/2991041.2991062." + ^self send: #run:with:in: + to: meth + with: {selector. arguments. rcvr}]. + + meth numArgs = arguments size ifFalse: + [^ self error: ('Wrong number of arguments in simulated method {1}' translated format: {meth})]. + (primIndex := meth primitive) > 0 ifTrue: + [val := self doPrimitive: primIndex method: meth receiver: rcvr args: arguments. + (self isPrimFailToken: val) ifFalse: + [^val]]. + + ctxt := self activateMethod: meth withArgs: arguments receiver: rcvr. + (primIndex isInteger and: [primIndex > 0]) ifTrue: + [ctxt failPrimitiveWith: val]. + + ^ctxt! Item was changed: ----- Method: Context>>send:to:with:lookupIn: (in category 'controlling') ----- send: selector to: rcvr with: arguments lookupIn: lookupClass "Simulate the action of sending a message with selector and arguments to rcvr. The argument, lookupClass, is the class in which to lookup the message. This is the receiver's class for normal messages, but for super messages it will be some specific class related to the source method." + | meth | - | meth primIndex val ctxt | (meth := lookupClass lookupSelector: selector) ifNil: [selector == #doesNotUnderstand: ifTrue: [self error: 'Recursive message not understood!!' translated]. ^self send: #doesNotUnderstand: to: rcvr with: {(Message selector: selector arguments: arguments) lookupClass: lookupClass} lookupIn: lookupClass]. + ^ self + executeMethod: meth + forSelector: selector + withArgs: arguments + receiver: rcvr! - (self objectClass: meth) isCompiledCodeClass ifFalse: - ["Object as Methods (OaM) protocol: 'The contract is that, when the VM encounters an ordinary object (rather than a compiled method) in the method dictionary during lookup, it sends it the special selector #run:with:in: providing the original selector, arguments, and receiver.'. DOI: 10.1145/2991041.2991062." - ^self send: #run:with:in: - to: meth - with: {selector. arguments. rcvr}]. - - meth numArgs = arguments size ifFalse: - [^ self error: ('Wrong number of arguments in simulated message {1}' translated format: {selector})]. - (primIndex := meth primitive) > 0 ifTrue: - [val := self doPrimitive: primIndex method: meth receiver: rcvr args: arguments. - (self isPrimFailToken: val) ifFalse: - [^val]]. - - ctxt := self activateMethod: meth withArgs: arguments receiver: rcvr. - (primIndex isInteger and: [primIndex > 0]) ifTrue: - [ctxt failPrimitiveWith: val]. - - ^ctxt! Item was changed: ----- Method: Object>>withArgs:executeMethod: (in category 'message handling') ----- withArgs: argArray executeMethod: compiledMethod "Execute compiledMethod against the receiver and args in argArray" + | context | - | selector | <primitive: 188> + context := thisContext + executeMethod: compiledMethod + forSelector: Symbol new + withArgs: argArray + receiver: self. + ^ context == thisContext + ifTrue: ["quick return" thisContext top] + ifFalse: [context jump]! - selector := Symbol new. - self class addSelectorSilently: selector withMethod: compiledMethod. - ^ [self perform: selector withArguments: argArray] - ensure: [self class basicRemoveSelector: selector]!

1 0

The Trunk: Kernel-ct.1420.mcz
by commits＠source.squeak.org 25 Feb '24

25 Feb '24

Christoph Thiede uploaded a new version of Kernel to project The Trunk: http://source.squeak.org/trunk/Kernel-ct.1420.mcz ==================== Summary ==================== Name: Kernel-ct.1420 Author: ct Time: 10 November 2021, 1:47:10.350242 am UUID: 8f2e7a27-2c7b-534a-9c78-a90c968e45c5 Ancestors: Kernel-eem.1418 Aligns the error code for primitive 118 during simulation with what the VM returns. See KernelTests-ct.409/#testPrimitive118/{6. 'not a primitive'. {7}},{6. 9. 'not an array'}. =============== Diff against Kernel-eem.1418 =============== Item was changed: ----- Method: Context>>doPrimitive:method:receiver:args: (in category 'private') ----- doPrimitive: primitiveIndex method: meth receiver: receiver args: arguments "Simulate a primitive method whose index is primitiveIndex. The simulated receiver and arguments are given as arguments to this message. If successful, push result and return resuming context, else ^ {errCode, PrimitiveFailToken}. Any primitive which provokes execution needs to be intercepted and simulated to avoid execution running away." | value | "Judicious use of primitive 19 (a null primitive that doesn't do anything) prevents the debugger from entering various run-away activities such as spawning a new process, etc. Injudicious use results in the debugger not being able to debug interesting code, such as the debugger itself. Hence use primitive 19 with care :-)" "SystemNavigation new browseAllSelect: [:m| m primitive = 19]" primitiveIndex = 19 ifTrue: [ [self notify: ('The code being simulated is trying to control a process ({1}). Process controlling cannot be simulated. If you proceed, things may happen outside the observable area of the simulator.' translated format: {meth reference})] ifCurtailed: [self push: nil "Cheap fix of the context's internal state"]]. ((primitiveIndex between: 201 and: 222) and: [(self objectClass: receiver) includesBehavior: BlockClosure]) ifTrue: [(primitiveIndex = 206 or: [primitiveIndex = 208]) ifTrue: "[Full]BlockClosure>>valueWithArguments:" [^receiver simulateValueWithArguments: arguments first caller: self]. ((primitiveIndex between: 201 and: 209) "[Full]BlockClosure>>value[:value:...]" or: [primitiveIndex between: 221 and: 222]) ifTrue: "[Full]BlockClosure>>valueNoContextSwitch[:]" [^receiver simulateValueWithArguments: arguments caller: self]]. primitiveIndex = 83 ifTrue: "afr 9/11/1998 19:50" "Object>>perform:[with:...]" [| selector | selector := arguments at: 1 ifAbsent: [^ self class primitiveFailTokenFor: #'bad argument']. arguments size - 1 = selector numArgs ifFalse: [^ self class primitiveFailTokenFor: #'bad number of arguments']. ^self send: selector to: receiver with: arguments allButFirst]. primitiveIndex = 84 ifTrue: "afr 9/11/1998 19:50 & eem 8/18/2009 17:04" "Object>>perform:withArguments:" [| selector args | arguments size = 2 ifFalse: [^ self class primitiveFailTokenFor: #'bad argument']. selector := arguments first. args := arguments second. args isArray ifFalse: [^ self class primitiveFailTokenFor: #'bad argument']. args size = selector numArgs ifFalse: [^ self class primitiveFailTokenFor: #'bad number of arguments']. ^self send: selector to: receiver with: args]. primitiveIndex = 100 ifTrue: "eem 8/18/2009 16:57" "Object>>perform:withArguments:inSuperclass:" [| rcvr selector args superclass | arguments size caseOf: { [3] -> [ rcvr := receiver. selector := arguments first. args := arguments second. superclass := arguments third]. [4] -> ["mirror primitive" rcvr := arguments first. selector := arguments second. args := arguments third. superclass := arguments fourth] } otherwise: [^ self class primitiveFailTokenFor: #'bad argument']. args isArray ifFalse: [^ self class primitiveFailTokenFor: #'bad argument']. args size = selector numArgs ifFalse: [^ self class primitiveFailTokenFor: #'bad number of arguments']. ((self objectClass: rcvr) includesBehavior: superclass) ifFalse: [^ self class primitiveFailTokenFor: #'bad argument']. ^self send: selector to: rcvr with: args lookupIn: superclass]. "Mutex>>primitiveEnterCriticalSection Mutex>>primitiveTestAndSetOwnershipOfCriticalSection" (primitiveIndex = 186 or: [primitiveIndex = 187]) ifTrue: [| effective | effective := Processor activeProcess effectiveProcess. "active == effective" value := primitiveIndex = 186 ifTrue: [receiver primitiveEnterCriticalSectionOnBehalfOf: effective] ifFalse: [receiver primitiveTestAndSetOwnershipOfCriticalSectionOnBehalfOf: effective]. ^(self isPrimFailToken: value) ifTrue: [value] ifFalse: [self push: value]]. primitiveIndex = 188 ifTrue: "Object>>withArgs:executeMethod: CompiledMethod class>>receiver:withArguments:executeMethod: VMMirror>>ifFail:object:with:executeMethod: et al" [| n args methodArg thisReceiver | ((n := arguments size) between: 2 and: 4) ifFalse: [^self class primitiveFailTokenFor: #'unsupported operation']. ((self objectClass: (args := arguments at: n - 1)) == Array and: [(self objectClass: (methodArg := arguments at: n)) includesBehavior: CompiledMethod]) ifFalse: [^self class primitiveFailTokenFor: #'bad argument']. methodArg numArgs = args size ifFalse: [^self class primitiveFailTokenFor: #'bad number of arguments']. thisReceiver := arguments at: n - 2 ifAbsent: [receiver]. methodArg primitive > 0 ifTrue: [methodArg isQuick ifTrue: [^self push: (methodArg valueWithReceiver: thisReceiver arguments: args)]. ^self doPrimitive: methodArg primitive method: meth receiver: thisReceiver args: args]. ^Context sender: self receiver: thisReceiver method: methodArg arguments: args]. primitiveIndex = 118 ifTrue: "[receiver:]tryPrimitive:withArgs:; avoid recursing in the VM" [(arguments size = 3 and: [(self objectClass: arguments second) == SmallInteger and: [(self objectClass: arguments last) == Array]]) ifTrue: [^self doPrimitive: arguments second method: meth receiver: arguments first args: arguments last]. (arguments size = 2 and: [(self objectClass: arguments first) == SmallInteger and: [(self objectClass: arguments last) == Array]]) ifFalse: + [^self class primitiveFailTokenFor: -3]. - [^self class primitiveFailTokenFor: nil]. ^self doPrimitive: arguments first method: meth receiver: receiver args: arguments last]. value := primitiveIndex = 120 "FFI method" ifTrue: [(meth literalAt: 1) tryInvokeWithArguments: arguments] ifFalse: [primitiveIndex = 117 "named primitives" ifTrue: [self tryNamedPrimitiveIn: meth for: receiver withArgs: arguments] ifFalse: "should use self receiver: receiver tryPrimitive: primitiveIndex withArgs: arguments but this is only in later VMs (and appears to be broken)" [receiver tryPrimitive: primitiveIndex withArgs: arguments]]. ^(self isPrimFailToken: value) ifTrue: [value] ifFalse: [self push: value]!

1 0

The Trunk: Kernel-ct.1556.mcz
by commits＠source.squeak.org 25 Feb '24

25 Feb '24

Christoph Thiede uploaded a new version of Kernel to project The Trunk: http://source.squeak.org/trunk/Kernel-ct.1556.mcz ==================== Summary ==================== Name: Kernel-ct.1556 Author: ct Time: 25 February 2024, 8:26:48.901593 pm UUID: 929047e6-a708-3540-97c5-aec212d87203 Ancestors: Kernel-ct.1555, Kernel-ct.1420, Kernel-ct.1451, Kernel-ct.1449, Kernel-ct.1490, Kernel-ct.1546, Kernel-ct.1547, Kernel-ct.1548 Merges several simulation fixes from the inbox. As always, please refer to the original versions to read their full messages. Kernel-ct.1420: Aligns the error code for primitive 118 (primitiveDoPrimitiveWithArgs) during simulation with what the VM returns. Kernel-ct.1451: Revises fallback code for primitive 188 (primitiveExecuteMethodArgsArray) in Object>>#withArgs:executeMethod: to eliminate any side effects to the method dictionary and add support for Objects as Methods. Kernel-ct.1449: Fixes arity checks for objects as methods in simulation of primitive 83 (primitivePerform) and primitive 84 (primitivePerformWithArgs). Kernel-ct.1490: In code simulation of perform primitives (primitive 83 (primitivePerform) and primitive 84 (primitivePerformWithArgs)), do not check numArgs of the selector or method to align behavior with VM. Revision: Remove the same check from simulation of primitive 100 (primitivePerformInSuperclass) as well. Kernel-ct.1546: In the debugger/simulator, fixes stepping through #mustBeBoolean errors and restarting from primitive methods that no longer fail. Kernel-ct.1547: When simulating #mustBeBoolean errors, send #mustBeBoolean instead of #mustBeBooleanIn: just like the VM. Kernel-ct.1548: Resolves #mustBeBoolean errors for copies or proxies of true and false. Revision: Improve documentation. =============== Diff against Kernel-ct.1555 =============== Item was changed: ----- Method: Context>>doPrimitive:method:receiver:args: (in category 'private') ----- doPrimitive: primitiveIndex method: meth receiver: receiver args: arguments "Simulate a primitive method whose index is primitiveIndex. The simulated receiver and arguments are given as arguments to this message. If successful, push result and return resuming context, else ^ {errCode, PrimitiveFailToken}. Any primitive which provokes execution needs to be intercepted and simulated to avoid execution running away." | value | "Judicious use of primitive 19 (a null primitive that doesn't do anything) prevents the debugger from entering various run-away activities such as spawning a new process, etc. Injudicious use results in the debugger not being able to debug interesting code, such as the debugger itself. Hence use primitive 19 with care :-)" "SystemNavigation new browseAllSelect: [:m| m primitive = 19]" primitiveIndex = 19 ifTrue: [ [self notify: ('The code being simulated is trying to control a process ({1}). Process controlling cannot be simulated. If you proceed, things may happen outside the observable area of the simulator.' translated format: {meth reference})] ifCurtailed: [self push: nil "Cheap fix of the context's internal state"]]. ((primitiveIndex between: 201 and: 222) and: [(self objectClass: receiver) includesBehavior: BlockClosure]) ifTrue: [(primitiveIndex = 206 or: [primitiveIndex = 208]) ifTrue: "[Full]BlockClosure>>valueWithArguments:" [^receiver simulateValueWithArguments: arguments first caller: self]. ((primitiveIndex between: 201 and: 209) "[Full]BlockClosure>>value[:value:...]" or: [primitiveIndex between: 221 and: 222]) ifTrue: "[Full]BlockClosure>>valueNoContextSwitch[:]" [^receiver simulateValueWithArguments: arguments caller: self]]. primitiveIndex = 83 ifTrue: "afr 9/11/1998 19:50" "Object>>perform:[with:...]" [| selector | selector := arguments at: 1 ifAbsent: [^ self class primitiveFailTokenFor: #'bad argument']. - (selector isSymbol and: [arguments size - 1 ~= selector numArgs]) ifTrue: - [^ self class primitiveFailTokenFor: #'bad number of arguments']. ^self send: selector to: receiver with: arguments allButFirst]. primitiveIndex = 84 ifTrue: "afr 9/11/1998 19:50 & eem 8/18/2009 17:04" "Object>>perform:withArguments:" [| selector args | arguments size = 2 ifFalse: [^ self class primitiveFailTokenFor: #'bad argument']. selector := arguments first. args := arguments second. args isArray ifFalse: [^ self class primitiveFailTokenFor: #'bad argument']. - (selector isSymbol and: [args size ~= selector numArgs]) ifTrue: - [^ self class primitiveFailTokenFor: #'bad number of arguments']. ^self send: selector to: receiver with: args]. primitiveIndex = 100 ifTrue: "eem 8/18/2009 16:57" "Object>>perform:withArguments:inSuperclass:" [| rcvr selector args superclass | arguments size caseOf: { [3] -> [ rcvr := receiver. selector := arguments first. args := arguments second. superclass := arguments third]. [4] -> ["mirror primitive" rcvr := arguments first. selector := arguments second. args := arguments third. superclass := arguments fourth] } otherwise: [^ self class primitiveFailTokenFor: #'bad number of arguments']. args isArray ifFalse: [^ self class primitiveFailTokenFor: #'bad argument']. - (selector isSymbol and: [args size ~= selector numArgs]) ifTrue: - [^ self class primitiveFailTokenFor: #'bad number of arguments']. ((self objectClass: rcvr) includesBehavior: superclass) ifFalse: [^ self class primitiveFailTokenFor: #'bad argument']. ^self send: selector to: rcvr with: args lookupIn: superclass]. "Mutex>>primitiveEnterCriticalSection Mutex>>primitiveTestAndSetOwnershipOfCriticalSection" (primitiveIndex = 186 or: [primitiveIndex = 187]) ifTrue: [| effective | effective := Processor activeProcess effectiveProcess. "active == effective" value := primitiveIndex = 186 ifTrue: [receiver primitiveEnterCriticalSectionOnBehalfOf: effective] ifFalse: [receiver primitiveTestAndSetOwnershipOfCriticalSectionOnBehalfOf: effective]. ^(self isPrimFailToken: value) ifTrue: [value] ifFalse: [self push: value]]. + + (primitiveIndex = 188 or: [primitiveIndex = 189]) ifTrue: - - primitiveIndex = 188 ifTrue: "Object>>withArgs:executeMethod: - CompiledMethod class>>receiver:withArguments:executeMethod: - VMMirror>>ifFail:object:with:executeMethod: et al" [| n args methodArg thisReceiver | + primitiveIndex caseOf: + {[188 "primitiveExecuteMethodArgsArray"] -> + ["Object>>withArgs:executeMethod: + CompiledMethod class>>receiver:withArguments:executeMethod: + VMMirror>>ifFail:object:with:executeMethod: et al" + ((n := arguments size) between: 2 and: 4) ifFalse: + [^self class primitiveFailTokenFor: #'unsupported operation']. + ((self objectClass: (args := arguments at: n - 1)) == Array + and: [(self objectClass: (methodArg := arguments at: n)) includesBehavior: CompiledMethod]) ifFalse: + [^self class primitiveFailTokenFor: #'bad argument']. + thisReceiver := arguments at: n - 2 ifAbsent: [receiver]]. + [189 "primitiveExecuteMethod"] -> + ["Object>>executeMethod: + Object>>with:...executeMethod:" + (arguments size > 0) ifFalse: + [^self class primitiveFailTokenFor: #'bad argument']. + ((self objectClass: (methodArg := arguments atLast: 1)) includesBehavior: CompiledMethod) ifFalse: + [^self class primitiveFailTokenFor: #'bad argument']. + args := arguments allButLast. + thisReceiver := receiver]}. - ((n := arguments size) between: 2 and: 4) ifFalse: - [^self class primitiveFailTokenFor: #'unsupported operation']. - ((self objectClass: (args := arguments at: n - 1)) == Array - and: [(self objectClass: (methodArg := arguments at: n)) includesBehavior: CompiledMethod]) ifFalse: - [^self class primitiveFailTokenFor: #'bad argument']. methodArg numArgs = args size ifFalse: [^self class primitiveFailTokenFor: #'bad number of arguments']. - thisReceiver := arguments at: n - 2 ifAbsent: [receiver]. methodArg primitive > 0 ifTrue: [methodArg isQuick ifTrue: [^self push: (methodArg valueWithReceiver: thisReceiver arguments: args)]. ^self doPrimitive: methodArg primitive method: methodArg receiver: thisReceiver args: args]. ^self activateMethod: methodArg withArgs: args receiver: thisReceiver]. primitiveIndex = 118 ifTrue: "[receiver:]tryPrimitive:withArgs:; avoid recursing in the VM" [(arguments size = 3 and: [(self objectClass: arguments second) == SmallInteger and: [(self objectClass: arguments last) == Array]]) ifTrue: [^self doPrimitive: arguments second method: meth receiver: arguments first args: arguments last]. (arguments size = 2 and: [(self objectClass: arguments first) == SmallInteger and: [(self objectClass: arguments last) == Array]]) ifFalse: + [^self class primitiveFailTokenFor: -3]. - [^self class primitiveFailTokenFor: nil]. ^self doPrimitive: arguments first method: meth receiver: receiver args: arguments last]. value := primitiveIndex = 120 "FFI method" ifTrue: [(meth literalAt: 1) tryInvokeWithArguments: arguments] ifFalse: [primitiveIndex = 117 "named primitives" ifTrue: [self tryNamedPrimitiveIn: meth for: receiver withArgs: arguments] ifFalse: "should use self receiver: receiver tryPrimitive: primitiveIndex withArgs: arguments but this is only in later VMs (and appears to be broken)" [receiver tryPrimitive: primitiveIndex withArgs: arguments]]. ^(self isPrimFailToken: value) ifTrue: [value] ifFalse: [self push: value]! Item was added: + ----- Method: Context>>executeMethod:forSelector:withArgs:receiver: (in category 'controlling') ----- + executeMethod: meth forSelector: selector withArgs: arguments receiver: rcvr + + | primIndex val ctxt | + (self objectClass: meth) isCompiledCodeClass ifFalse: + ["Object as Methods (OaM) protocol: 'The contract is that, when the VM encounters an ordinary object (rather than a compiled method) in the method dictionary during lookup, it sends it the special selector #run:with:in: providing the original selector, arguments, and receiver.'. DOI: 10.1145/2991041.2991062." + ^self send: #run:with:in: + to: meth + with: {selector. arguments. rcvr}]. + + meth numArgs = arguments size ifFalse: + [^ self class primitiveFailTokenFor: #'bad number of arguments']. + (primIndex := meth primitive) > 0 ifTrue: + [val := self doPrimitive: primIndex method: meth receiver: rcvr args: arguments. + (self isPrimFailToken: val) ifFalse: + [^val]]. + + ctxt := self activateMethod: meth withArgs: arguments receiver: rcvr. + (primIndex isInteger and: [primIndex > 0]) ifTrue: + [ctxt failPrimitiveWith: val]. + + ^ctxt! Item was changed: ----- Method: Context>>jump:if: (in category 'instruction decoding') ----- jump: distance if: condition "Simulate the action of a 'conditional jump' bytecode whose offset is the argument, distance, and whose condition is the argument, condition." | bool | bool := self pop. condition == bool ifTrue: [self jump: distance] ifFalse: [(true == bool or: [false == bool]) ifFalse: + [^self send: #mustBeBoolean to: bool with: #()]]! - [^self send: #mustBeBooleanIn: to: bool with: {self}]]! Item was changed: ----- Method: Context>>send:to:with:lookupIn: (in category 'controlling') ----- send: selector to: rcvr with: arguments lookupIn: lookupClass "Simulate the action of sending a message with selector and arguments to rcvr. The argument, lookupClass, is the class in which to lookup the message. This is the receiver's class for normal messages, but for super messages it will be some specific class related to the source method." + | meth | - | meth primIndex val ctxt | (meth := lookupClass lookupSelector: selector) ifNil: [selector == #doesNotUnderstand: ifTrue: [self error: 'Recursive message not understood!!' translated]. ^self send: #doesNotUnderstand: to: rcvr with: {(Message selector: selector arguments: arguments) lookupClass: lookupClass} lookupIn: lookupClass]. + ^ self + executeMethod: meth + forSelector: selector + withArgs: arguments + receiver: rcvr! - (self objectClass: meth) isCompiledCodeClass ifFalse: - ["Object as Methods (OaM) protocol: 'The contract is that, when the VM encounters an ordinary object (rather than a compiled method) in the method dictionary during lookup, it sends it the special selector #run:with:in: providing the original selector, arguments, and receiver.'. DOI: 10.1145/2991041.2991062." - ^self send: #run:with:in: - to: meth - with: {selector. arguments. rcvr}]. - - meth numArgs = arguments size ifFalse: - [^ self error: ('Wrong number of arguments in simulated message {1}' translated format: {selector})]. - (primIndex := meth primitive) > 0 ifTrue: - [val := self doPrimitive: primIndex method: meth receiver: rcvr args: arguments. - (self isPrimFailToken: val) ifFalse: - [^val]]. - - ctxt := self activateMethod: meth withArgs: arguments receiver: rcvr. - (primIndex isInteger and: [primIndex > 0]) ifTrue: - [ctxt failPrimitiveWith: val]. - - ^ctxt! Item was changed: ----- Method: Context>>stepToSendOrReturn (in category 'system simulation') ----- stepToSendOrReturn "Simulate the execution of bytecodes until either sending a message or returning a value to the receiver (that is, until switching contexts)." | ctxt | [self willReallySend or: [self willReturn or: [self willReallyStore]]] whileFalse: [ctxt := self step. ctxt == self ifFalse: + ["Caused by mustBeBoolean handling or callPrimitive:" + ^ctxt stepToSendOrReturn]]! - [self halt. - "Caused by mustBeBoolean handling" - ^ctxt]]! Item was added: + ----- Method: False>>mustBeBooleanIn: (in category 'converting') ----- + mustBeBooleanIn: aContext + "Overwritten to support conditional jumps (ifTrue:/ifFalse:) based on a proxy to true/false. The jump will first fail, send #mustBeBoolean to the proxy, which will forward hither. Here, we correct the context by replacing the proxy on the stack through the canonical instance of ourselves and reattempting the jump. See ObjectTracer>>mustBeBoolean for an example." + + aContext skipBackBeforeJump. + ^ false! Item was changed: ----- Method: Object>>withArgs:executeMethod: (in category 'message handling') ----- withArgs: argArray executeMethod: compiledMethod "Execute compiledMethod against the receiver and args in argArray" + | context | - | selector | <primitive: 188> + context := thisContext + executeMethod: compiledMethod + forSelector: Symbol new + withArgs: argArray + receiver: self. + ^ context == thisContext + ifTrue: ["quick return" thisContext top] + ifFalse: [context jump]! - selector := Symbol new. - self class addSelectorSilently: selector withMethod: compiledMethod. - ^ [self perform: selector withArguments: argArray] - ensure: [self class basicRemoveSelector: selector]! Item was added: + ----- Method: ObjectTracer>>mustBeBoolean (in category 'very few messages') ----- + mustBeBoolean + "Overwritten to preserve original sender context. + + This is required to support conditional jumps (ifTrue:/ifFalse:) based on traced booleans, e.g.: + (ObjectTracer on: false) ifTrue: [1] ifFalse: [2]." + + ^ self mustBeBooleanIn: thisContext sender! Item was added: + ----- Method: True>>mustBeBooleanIn: (in category 'converting') ----- + mustBeBooleanIn: aContext + "Overwritten to support conditional jumps (ifTrue:/ifFalse:) based on a proxy to true/false. The jump will first fail, send #mustBeBoolean to the proxy, which will forward hither. Here, we correct the context by replacing the proxy on the stack through the canonical instance of ourselves and reattempting the jump. See ObjectTracer>>mustBeBoolean for an example." + + aContext skipBackBeforeJump. + ^ true!

1 0

The Trunk: Kernel-ct.1455.mcz
by commits＠source.squeak.org 25 Feb '24

25 Feb '24

Christoph Thiede uploaded a new version of Kernel to project The Trunk: http://source.squeak.org/trunk/Kernel-ct.1455.mcz ==================== Summary ==================== Name: Kernel-ct.1455 Author: ct Time: 2 April 2022, 6:03:46.669052 pm UUID: d86c9223-8db7-e541-96bd-cde0c9b7fb92 Ancestors: Kernel-ul.1454 Proposal: Adds basic support for #acceptsLoggingOfCompilation to class comments by allowing strings in BasicClassOrganizer.classComment. With this change, installing updates in a read-only image becomes more feasible. Please review. =============== Diff against Kernel-ul.1454 =============== Item was changed: ----- Method: BasicClassOrganizer>>classComment (in category 'accessing') ----- classComment classComment ifNil: [^ '']. + (classComment isString + or: [classComment isText]) + ifTrue: [^ classComment]. + ^ classComment text + ifNil: ['']! - ^ classComment text ifNil: ['']! Item was changed: ----- Method: BasicClassOrganizer>>classComment:stamp: (in category 'accessing') ----- classComment: aString stamp: aStamp + "Store the comment, aString, associated with the object that refers to the receiver. PRIVATE!! Clients should use aClass classComment: instead." - "Store the comment, aString, associated with the object that refers to the receiver." self commentStamp: aStamp. (aString isKindOf: RemoteString) ifTrue: [classComment := aString] ifFalse: [(aString == nil or: [aString size = 0]) ifTrue: [classComment := nil] ifFalse: + [classComment := aString]] - [self error: 'use aClass classComment:'. - classComment := RemoteString newString: aString onFileNumber: 2]] "Later add priorSource and date and initials?"! Item was changed: ----- Method: BasicClassOrganizer>>commentRemoteStr (in category 'accessing') ----- commentRemoteStr + ^ (classComment isKindOf: RemoteString) + ifTrue: [classComment]! - ^ classComment! Item was changed: ----- Method: BasicClassOrganizer>>fileOutCommentOn:moveSource:toFile: (in category 'fileIn/Out') ----- fileOutCommentOn: aFileStream moveSource: moveSource toFile: fileIndex "Copy the class comment to aFileStream. If moveSource is true (as in compressChanges or compressSources, then update classComment to point to the new file." | fileComment | + self hasNoComment ifTrue: [^ self]. + + aFileStream cr. + fileComment := RemoteString + newString: self classComment + onFileNumber: fileIndex + toFile: aFileStream. + moveSource ifTrue: [classComment := fileComment].! - classComment ifNotNil: - [aFileStream cr. - fileComment := RemoteString newString: classComment text - onFileNumber: fileIndex toFile: aFileStream. - moveSource ifTrue: [classComment := fileComment]]! Item was changed: ----- Method: BasicClassOrganizer>>moveChangedCommentToFile:numbered: (in category 'fileIn/Out') ----- moveChangedCommentToFile: aFileStream numbered: fileIndex "If the comment is in the changes file, then move it to a new file." + (self commentRemoteStr ~~ nil and: [classComment sourceFileNumber > 1]) ifTrue: - (classComment ~~ nil and: [classComment sourceFileNumber > 1]) ifTrue: [self fileOutCommentOn: aFileStream moveSource: true toFile: fileIndex]! Item was changed: ----- Method: ClassDescription>>classComment:stamp: (in category 'fileIn/Out') ----- classComment: aString stamp: aStamp "Store the comment, aString or Text or RemoteString, associated with the class we are organizing. Empty string gets stored only if had a non-empty one before." - | ptr header file oldCommentRemoteStr | (aString isKindOf: RemoteString) ifTrue: [SystemChangeNotifier uniqueInstance classCommented: self. ^ self organization classComment: aString stamp: aStamp]. + self acceptsLoggingOfCompilation + ifTrue: + [| ptr header file oldCommentRemoteStr | + oldCommentRemoteStr := self organization commentRemoteStr. + (aString size = 0) & (oldCommentRemoteStr == nil) ifTrue: + ["never had a class comment, no need to write empty string out" + ^ self organization classComment: nil]. + + ptr := oldCommentRemoteStr ifNil: [0] ifNotNil: [oldCommentRemoteStr sourcePointer]. + SourceFiles ifNotNil: [(file := SourceFiles at: 2) ifNotNil: + [file setToEnd; cr; nextPut: $!!. "directly" + "Should be saying (file command: ''H3'') for HTML, but ignoring it here" + header := String streamContents: [:strm | strm nextPutAll: self name; + nextPutAll: ' commentStamp: '. + aStamp storeOn: strm. + strm nextPutAll: ' prior: '; nextPutAll: ptr printString]. + file nextChunkPut: header]]. + self organization classComment: (RemoteString newString: aString onFileNumber: 2) stamp: aStamp. + file ifNotNil: [ InMidstOfFileinNotification signal ifFalse: [ file flush ] ]] + ifFalse: + [self organization classComment: aString stamp: aStamp]. + + SystemChangeNotifier uniqueInstance classCommented: self.! - oldCommentRemoteStr := self organization commentRemoteStr. - (aString size = 0) & (oldCommentRemoteStr == nil) ifTrue: [^ self organization classComment: nil]. - "never had a class comment, no need to write empty string out" - - ptr := oldCommentRemoteStr ifNil: [0] ifNotNil: [oldCommentRemoteStr sourcePointer]. - SourceFiles ifNotNil: [(file := SourceFiles at: 2) ifNotNil: - [file setToEnd; cr; nextPut: $!!. "directly" - "Should be saying (file command: 'H3') for HTML, but ignoring it here" - header := String streamContents: [:strm | strm nextPutAll: self name; - nextPutAll: ' commentStamp: '. - aStamp storeOn: strm. - strm nextPutAll: ' prior: '; nextPutAll: ptr printString]. - file nextChunkPut: header]]. - self organization classComment: (RemoteString newString: aString onFileNumber: 2) stamp: aStamp. - file ifNotNil: [ InMidstOfFileinNotification signal ifFalse: [ file flush ] ]. - SystemChangeNotifier uniqueInstance classCommented: self. - !

1 0

The Trunk: Kernel-ct.1450.mcz
by commits＠source.squeak.org 25 Feb '24

25 Feb '24

Christoph Thiede uploaded a new version of Kernel to project The Trunk: http://source.squeak.org/trunk/Kernel-ct.1450.mcz ==================== Summary ==================== Name: Kernel-ct.1450 Author: ct Time: 25 March 2022, 12:03:45.256465 am UUID: 484c3944-1ae9-fa4b-888c-bacd59152bc5 Ancestors: Kernel-nice.1447 Updates comment in TimedOut. =============== Diff against Kernel-nice.1447 =============== Item was changed: Notification subclass: #TimedOut instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Exceptions'! + !TimedOut commentStamp: 'ct 3/25/2022 00:01' prior: 0! + I am signalled by BlockClosure>>#valueWithin:onTimeout: if the receiving block takes too long to execute. - !TimedOut commentStamp: 'brp 10/21/2004 17:47' prior: 0! - I am signalled by #duration:timeoutDo: if the receiving block takes too long to execute. - I am signalled by a watchdog process spawned by #duration:timeoutDo: and caught in the same method. - I am not intended to be used elsewhere.!

1 0

The Trunk: Kernel-ct.1408.mcz
by commits＠source.squeak.org 25 Feb '24

25 Feb '24

Christoph Thiede uploaded a new version of Kernel to project The Trunk: http://source.squeak.org/trunk/Kernel-ct.1408.mcz ==================== Summary ==================== Name: Kernel-ct.1408 Author: ct Time: 17 July 2021, 8:21:02.006197 pm UUID: 0b59b2d7-2dfe-6640-bc29-63e35699bc53 Ancestors: Kernel-mt.1406 Proposal: Show nested exception in the description of BrokenPromise. =============== Diff against Kernel-mt.1406 =============== Item was changed: + ----- Method: BrokenPromise>>defaultAction (in category 'priv handling') ----- - ----- Method: BrokenPromise>>defaultAction (in category 'as yet unclassified') ----- defaultAction self messageText: 'Promise was rejected'. ^super defaultAction! Item was added: + ----- Method: BrokenPromise>>description (in category 'accessing') ----- + description + + ^ String streamContents: [:stream | + stream nextPutAll: super description. + self exception ifNotNil: [:ex | + stream + nextPutAll: ': '; + nextPutAll: ex description]]! Item was added: + ----- Method: BrokenPromise>>exception (in category 'accessing') ----- + exception + + ^ promise ifNotNil: [promise error]! Item was changed: + ----- Method: BrokenPromise>>isResumable (in category 'priv handling') ----- - ----- Method: BrokenPromise>>isResumable (in category 'as yet unclassified') ----- isResumable ^ true! Item was changed: + ----- Method: BrokenPromise>>promise (in category 'accessing') ----- - ----- Method: BrokenPromise>>promise (in category 'as yet unclassified') ----- promise ^ promise! Item was changed: + ----- Method: BrokenPromise>>promise: (in category 'accessing') ----- - ----- Method: BrokenPromise>>promise: (in category 'as yet unclassified') ----- promise: aPromise promise := aPromise!

1 0

The Trunk: Kernel-ct.1356.mcz
by commits＠source.squeak.org 25 Feb '24

25 Feb '24

Christoph Thiede uploaded a new version of Kernel to project The Trunk: http://source.squeak.org/trunk/Kernel-ct.1356.mcz ==================== Summary ==================== Name: Kernel-ct.1356 Author: ct Time: 28 October 2020, 9:05:21.976652 pm UUID: 27e8ca85-1191-5b4b-aa8c-92b65e01af50 Ancestors: Kernel-eem.1354 Fixes and refactors ClassBuilder cleanupAndCheckClassHierarchy which was broken due to a missing #informUserDuring: implementation. Also adds progress bars during the operation. =============== Diff against Kernel-eem.1354 =============== Item was changed: ----- Method: ClassBuilder class>>checkClassHierarchyConsistency (in category 'cleanup obsolete classes') ----- checkClassHierarchyConsistency "Check the consistency of the class hierarchy. The class hierarchy is consistent if the following two logical equivalences hold for classes A and B: - B is obsolete and 'B superclass' yields A <--> 'A obsoleteSubclasses' contains B - B is not obsolete and 'B superclass' yields A <--> 'A subclasses' contains B" + + Transcript cr; show: 'Start checking the class hierarchy...'. + Smalltalk garbageCollect. + + Metaclass allInstances + do: [:meta | + meta allInstances do: [:each | self checkClassHierarchyConsistencyFor: each]. + self checkClassHierarchyConsistencyFor: meta] + displayingProgress: 'Validating class hierarchy' translated. + + Transcript show: 'OK'.! - self informUserDuring:[:bar| - self checkClassHierarchyConsistency: bar. - ].! Item was removed: - ----- Method: ClassBuilder class>>checkClassHierarchyConsistency: (in category 'cleanup obsolete classes') ----- - checkClassHierarchyConsistency: informer - "Check the consistency of the class hierarchy. The class hierarchy is consistent if the following - two logical equivalences hold for classes A and B: - - B is obsolete and 'B superclass' yields A <--> 'A obsoleteSubclasses' contains B - - B is not obsolete and 'B superclass' yields A <--> 'A subclasses' contains B" - | classes | - Transcript cr; show: 'Start checking the class hierarchy...'. - Smalltalk garbageCollect. - classes := Metaclass allInstances. - classes keysAndValuesDo: [:index :meta | - informer value:'Validating class hierarchy ', (index * 100 // classes size) printString,'%'. - meta allInstances do: [:each | self checkClassHierarchyConsistencyFor: each]. - self checkClassHierarchyConsistencyFor: meta. - ]. - Transcript show: 'OK'.! Item was changed: ----- Method: ClassBuilder class>>cleanupAndCheckClassHierarchy (in category 'cleanup obsolete classes') ----- cleanupAndCheckClassHierarchy "Makes the class hierarchy consistent and removes obsolete classes from the SystemDictionary. Afterwards it checks whether the hierarchy is really consistent." + + Project uiManager informUser: 'Cleaning up class hierarchy...' translated during: [ + Transcript cr; show: '*** Before cleaning up ***'. + self countReallyObsoleteClassesAndMetaclasses. + self cleanupClassHierarchy. + self checkClassHierarchyConsistency. + Transcript cr; cr; show: '*** After cleaning up ***'. + self countReallyObsoleteClassesAndMetaclasses].! - self informUserDuring:[:bar| - self cleanupAndCheckClassHierarchy: bar. - ]. - ! Item was removed: - ----- Method: ClassBuilder class>>cleanupAndCheckClassHierarchy: (in category 'cleanup obsolete classes') ----- - cleanupAndCheckClassHierarchy: informer - "Makes the class hierarchy consistent and removes obsolete classes from the SystemDictionary. - Afterwards it checks whether the hierarchy is really consistent." - - Transcript cr; show: '*** Before cleaning up ***'. - self countReallyObsoleteClassesAndMetaclasses. - self cleanupClassHierarchy: informer. - self checkClassHierarchyConsistency: informer. - Transcript cr; cr; show: '*** After cleaning up ***'. - self countReallyObsoleteClassesAndMetaclasses.! Item was changed: ----- Method: ClassBuilder class>>cleanupClassHierarchy (in category 'cleanup obsolete classes') ----- cleanupClassHierarchy "Makes the class hierarchy consistent and removes obsolete classes from the SystemDictionary." + + Transcript cr; show: 'Start fixing the class hierarchy and cleaning up...'. + Smalltalk garbageCollect. + + Metaclass allInstances + do: [:meta | + "Check classes before metaclasses (because Metaclass>>isObsolete checks whether the related class is obsolete)" + meta allInstances do: [:each | self cleanupClassHierarchyFor: each]. + self cleanupClassHierarchyFor: meta] + displayingProgress: 'Fixing class hierarchy' translated. + + Transcript show: 'DONE'.! - self informUserDuring:[:bar| - self cleanupClassHierarchy: bar. - ].! Item was removed: - ----- Method: ClassBuilder class>>cleanupClassHierarchy: (in category 'cleanup obsolete classes') ----- - cleanupClassHierarchy: informer - "Makes the class hierarchy consistent and removes obsolete classes from the SystemDictionary." - | classes | - Transcript cr; show: 'Start fixing the class hierarchy and cleaning up...'. - Smalltalk garbageCollect. - classes := Metaclass allInstances. - classes keysAndValuesDo: [:index :meta | - informer value:'Fixing class hierarchy ', (index * 100 // classes size) printString,'%'. - "Check classes before metaclasses (because Metaclass>>isObsolete - checks whether the related class is obsolete)" - meta allInstances do: [:each | self cleanupClassHierarchyFor: each]. - self cleanupClassHierarchyFor: meta. - ]. - Transcript show: 'DONE'.!

1 0

The Trunk: Kernel-ct.1555.mcz
by commits＠source.squeak.org 25 Feb '24

25 Feb '24

Christoph Thiede uploaded a new version of Kernel to project The Trunk: http://source.squeak.org/trunk/Kernel-ct.1555.mcz ==================== Summary ==================== Name: Kernel-ct.1555 Author: ct Time: 25 February 2024, 7:56:23.908593 pm UUID: 45f6b27d-e825-c34b-a540-5c173c78c951 Ancestors: Kernel-ct.1554, Kernel-ct.1356, Kernel-ct.1408, Kernel-ct.1450, Kernel-ct.1455 Merge commit. Kernel-ct.1301: Documents the small but essential difference between #sendTo: and #sentTo:. Kernel-ct.1356: Fixes and refactors ClassBuilder cleanupAndCheckClassHierarchy which was broken due to a missing #informUserDuring: implementation. Also adds progress bars during the operation. Kernel-ct.1408: Proposal: Show nested exception in the description of BrokenPromise. Revision: Honor the fact that Promise errors are not necessarily exceptions. Reuse #messageText rather than overriding #description. Kernel-ct.1450: Updates comment in TimedOut. Kernel-ct.1455: Adds basic support for #acceptsLoggingOfCompilation to class comments by allowing strings in BasicClassOrganizer classComment. =============== Diff against Kernel-ct.1554 =============== Item was changed: ----- Method: BasicClassOrganizer>>classComment (in category 'accessing') ----- classComment classComment ifNil: [^ '']. + (classComment isString + or: [classComment isText]) + ifTrue: [^ classComment]. + ^ classComment text + ifNil: ['']! - ^ classComment text ifNil: ['']! Item was changed: ----- Method: BasicClassOrganizer>>classComment:stamp: (in category 'accessing') ----- classComment: aString stamp: aStamp + "Store the comment, aString, associated with the object that refers to the receiver. PRIVATE!! Clients should use aClass classComment: instead." - "Store the comment, aString, associated with the object that refers to the receiver." self commentStamp: aStamp. (aString isKindOf: RemoteString) ifTrue: [classComment := aString] ifFalse: [(aString == nil or: [aString size = 0]) ifTrue: [classComment := nil] ifFalse: + [classComment := aString]] - [self error: 'use aClass classComment:'. - classComment := RemoteString newString: aString onFileNumber: 2]] "Later add priorSource and date and initials?"! Item was changed: ----- Method: BasicClassOrganizer>>commentRemoteStr (in category 'accessing') ----- commentRemoteStr + ^ (classComment isKindOf: RemoteString) + ifTrue: [classComment]! - ^ classComment! Item was changed: ----- Method: BasicClassOrganizer>>fileOutCommentOn:moveSource:toFile: (in category 'fileIn/Out') ----- fileOutCommentOn: aFileStream moveSource: moveSource toFile: fileIndex "Copy the class comment to aFileStream. If moveSource is true (as in compressChanges or compressSources, then update classComment to point to the new file." | fileComment | + self hasNoComment ifTrue: [^ self]. + + aFileStream cr. + fileComment := RemoteString + newString: self classComment + onFileNumber: fileIndex + toFile: aFileStream. + moveSource ifTrue: [classComment := fileComment].! - classComment ifNotNil: - [aFileStream cr. - fileComment := RemoteString newString: classComment text - onFileNumber: fileIndex toFile: aFileStream. - moveSource ifTrue: [classComment := fileComment]]! Item was changed: ----- Method: BasicClassOrganizer>>moveChangedCommentToFile:numbered: (in category 'fileIn/Out') ----- moveChangedCommentToFile: aFileStream numbered: fileIndex "If the comment is in the changes file, then move it to a new file." + (self commentRemoteStr ~~ nil and: [classComment sourceFileNumber > 1]) ifTrue: - (classComment ~~ nil and: [classComment sourceFileNumber > 1]) ifTrue: [self fileOutCommentOn: aFileStream moveSource: true toFile: fileIndex]! Item was added: + ----- Method: BrokenPromise>>error (in category 'accessing') ----- + error + + ^ promise ifNotNil: [promise error]! Item was added: + ----- Method: BrokenPromise>>messageText (in category 'accessing') ----- + messageText + + ^ messageText ifNil: + [self error ifNotNil: [:error | + error asString]]! Item was changed: ----- Method: ClassBuilder class>>checkClassHierarchyConsistency (in category 'cleanup obsolete classes') ----- checkClassHierarchyConsistency "Check the consistency of the class hierarchy. The class hierarchy is consistent if the following two logical equivalences hold for classes A and B: - B is obsolete and 'B superclass' yields A <--> 'A obsoleteSubclasses' contains B - B is not obsolete and 'B superclass' yields A <--> 'A subclasses' contains B" + + Transcript cr; show: 'Start checking the class hierarchy...'. + Smalltalk garbageCollect. + + Metaclass allInstances + do: [:meta | + meta allInstances do: [:each | self checkClassHierarchyConsistencyFor: each]. + self checkClassHierarchyConsistencyFor: meta] + displayingProgress: 'Validating class hierarchy' translated. + + Transcript show: 'OK'.! - self informUserDuring:[:bar| - self checkClassHierarchyConsistency: bar. - ].! Item was removed: - ----- Method: ClassBuilder class>>checkClassHierarchyConsistency: (in category 'cleanup obsolete classes') ----- - checkClassHierarchyConsistency: informer - "Check the consistency of the class hierarchy. The class hierarchy is consistent if the following - two logical equivalences hold for classes A and B: - - B is obsolete and 'B superclass' yields A <--> 'A obsoleteSubclasses' contains B - - B is not obsolete and 'B superclass' yields A <--> 'A subclasses' contains B" - | classes | - Transcript cr; show: 'Start checking the class hierarchy...'. - Smalltalk garbageCollect. - classes := Metaclass allInstances. - classes keysAndValuesDo: [:index :meta | - informer value:'Validating class hierarchy ', (index * 100 // classes size) printString,'%'. - meta allInstances do: [:each | self checkClassHierarchyConsistencyFor: each]. - self checkClassHierarchyConsistencyFor: meta. - ]. - Transcript show: 'OK'.! Item was changed: ----- Method: ClassBuilder class>>cleanupAndCheckClassHierarchy (in category 'cleanup obsolete classes') ----- cleanupAndCheckClassHierarchy "Makes the class hierarchy consistent and removes obsolete classes from the SystemDictionary. Afterwards it checks whether the hierarchy is really consistent." + + Project uiManager informUser: 'Cleaning up class hierarchy...' translated during: [ + Transcript cr; show: '*** Before cleaning up ***'. + self countReallyObsoleteClassesAndMetaclasses. + self cleanupClassHierarchy. + self checkClassHierarchyConsistency. + Transcript cr; cr; show: '*** After cleaning up ***'. + self countReallyObsoleteClassesAndMetaclasses].! - self informUserDuring:[:bar| - self cleanupAndCheckClassHierarchy: bar. - ]. - ! Item was removed: - ----- Method: ClassBuilder class>>cleanupAndCheckClassHierarchy: (in category 'cleanup obsolete classes') ----- - cleanupAndCheckClassHierarchy: informer - "Makes the class hierarchy consistent and removes obsolete classes from the SystemDictionary. - Afterwards it checks whether the hierarchy is really consistent." - - Transcript cr; show: '*** Before cleaning up ***'. - self countReallyObsoleteClassesAndMetaclasses. - self cleanupClassHierarchy: informer. - self checkClassHierarchyConsistency: informer. - Transcript cr; cr; show: '*** After cleaning up ***'. - self countReallyObsoleteClassesAndMetaclasses.! Item was changed: ----- Method: ClassBuilder class>>cleanupClassHierarchy (in category 'cleanup obsolete classes') ----- cleanupClassHierarchy "Makes the class hierarchy consistent and removes obsolete classes from the SystemDictionary." + + Transcript cr; show: 'Start fixing the class hierarchy and cleaning up...'. + Smalltalk garbageCollect. + + Metaclass allInstances + do: [:meta | + "Check classes before metaclasses (because Metaclass>>isObsolete checks whether the related class is obsolete)" + meta allInstances do: [:each | self cleanupClassHierarchyFor: each]. + self cleanupClassHierarchyFor: meta] + displayingProgress: 'Fixing class hierarchy' translated. + + Transcript show: 'DONE'.! - self informUserDuring:[:bar| - self cleanupClassHierarchy: bar. - ].! Item was removed: - ----- Method: ClassBuilder class>>cleanupClassHierarchy: (in category 'cleanup obsolete classes') ----- - cleanupClassHierarchy: informer - "Makes the class hierarchy consistent and removes obsolete classes from the SystemDictionary." - | classes | - Transcript cr; show: 'Start fixing the class hierarchy and cleaning up...'. - Smalltalk garbageCollect. - classes := Metaclass allInstances. - classes keysAndValuesDo: [:index :meta | - informer value:'Fixing class hierarchy ', (index * 100 // classes size) printString,'%'. - "Check classes before metaclasses (because Metaclass>>isObsolete - checks whether the related class is obsolete)" - meta allInstances do: [:each | self cleanupClassHierarchyFor: each]. - self cleanupClassHierarchyFor: meta. - ]. - Transcript show: 'DONE'.! Item was changed: ----- Method: ClassDescription>>classComment:stamp: (in category 'fileIn/Out') ----- classComment: aString stamp: aStamp "Store the comment, aString or Text or RemoteString, associated with the class we are organizing. Empty string gets stored only if had a non-empty one before." - | ptr header file oldCommentRemoteStr | (aString isKindOf: RemoteString) ifTrue: [SystemChangeNotifier uniqueInstance classCommented: self. ^ self organization classComment: aString stamp: aStamp]. + self acceptsLoggingOfCompilation + ifTrue: + [| ptr header file oldCommentRemoteStr | + oldCommentRemoteStr := self organization commentRemoteStr. + (aString size = 0) & (oldCommentRemoteStr == nil) ifTrue: + ["never had a class comment, no need to write empty string out" + ^ self organization classComment: nil]. + + ptr := oldCommentRemoteStr ifNil: [0] ifNotNil: [oldCommentRemoteStr sourcePointer]. + SourceFiles ifNotNil: [(file := SourceFiles at: 2) ifNotNil: + [file setToEnd; cr; nextPut: $!!. "directly" + "Should be saying (file command: ''H3'') for HTML, but ignoring it here" + header := String streamContents: [:strm | strm nextPutAll: self name; + nextPutAll: ' commentStamp: '. + aStamp storeOn: strm. + strm nextPutAll: ' prior: '; nextPutAll: ptr printString]. + file nextChunkPut: header]]. + self organization classComment: (RemoteString newString: aString onFileNumber: 2) stamp: aStamp. + file ifNotNil: [ InMidstOfFileinNotification signal ifFalse: [ file flush ] ]] + ifFalse: + [self organization classComment: aString stamp: aStamp]. + + SystemChangeNotifier uniqueInstance classCommented: self.! - oldCommentRemoteStr := self organization commentRemoteStr. - (aString size = 0) & (oldCommentRemoteStr == nil) ifTrue: [^ self organization classComment: nil]. - "never had a class comment, no need to write empty string out" - - ptr := oldCommentRemoteStr ifNil: [0] ifNotNil: [oldCommentRemoteStr sourcePointer]. - SourceFiles ifNotNil: [(file := SourceFiles at: 2) ifNotNil: - [file setToEnd; cr; nextPut: $!!. "directly" - "Should be saying (file command: 'H3') for HTML, but ignoring it here" - header := String streamContents: [:strm | strm nextPutAll: self name; - nextPutAll: ' commentStamp: '. - aStamp storeOn: strm. - strm nextPutAll: ' prior: '; nextPutAll: ptr printString]. - file nextChunkPut: header]]. - self organization classComment: (RemoteString newString: aString onFileNumber: 2) stamp: aStamp. - file ifNotNil: [ InMidstOfFileinNotification signal ifFalse: [ file flush ] ]. - SystemChangeNotifier uniqueInstance classCommented: self. - ! Item was changed: ----- Method: Message>>sendTo: (in category 'sending') ----- + sendTo: receiverObject + "Answer the result of sending this message to receiverObject" - sendTo: receiver - "answer the result of sending this message to receiver" + ^ receiverObject perform: selector withArguments: args! - ^ receiver perform: selector withArguments: args! Item was changed: ----- Method: Message>>sentTo: (in category 'sending') ----- + sentTo: receiverObject + "Answer the result of sending this message to receiver. Kind of private!! To send the message to a different receiver (for example, via #doesNotUnderstand:), use #sendTo: instead." - sentTo: receiver - "answer the result of sending this message to receiver" + ^ lookupClass == nil + ifTrue: [receiverObject perform: selector withArguments: args] + ifFalse: [receiverObject perform: selector withArguments: args inSuperclass: lookupClass]! - lookupClass == nil - ifTrue: [^ receiver perform: selector withArguments: args] - ifFalse: [^ receiver perform: selector withArguments: args inSuperclass: lookupClass]! Item was changed: Notification subclass: #TimedOut instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Exceptions'! + !TimedOut commentStamp: 'ct 3/25/2022 00:01' prior: 0! + I am signalled by BlockClosure>>#valueWithin:onTimeout: if the receiving block takes too long to execute. - !TimedOut commentStamp: 'brp 10/21/2004 17:47' prior: 0! - I am signalled by #duration:timeoutDo: if the receiving block takes too long to execute. - I am signalled by a watchdog process spawned by #duration:timeoutDo: and caught in the same method. - I am not intended to be used elsewhere.!

1 0

The Treated Inbox: Kernel-ct.1409.mcz
by commits＠source.squeak.org 24 Feb '24

24 Feb '24

Christoph Thiede uploaded a new version of Kernel to project The Treated Inbox: http://source.squeak.org/treated/Kernel-ct.1409.mcz ==================== Summary ==================== Name: Kernel-ct.1409 Author: ct Time: 22 August 2021, 6:18:06.141465 pm UUID: 003f761f-f99d-c245-a431-dcf1cb8405ba Ancestors: Kernel-eem.1408 Fixes a simulation bug when returning from a sender that is a bottom context. Examples to reproduce: - sender := thisContext swapSender: nil. ^1 - sender := thisContext swapSender: nil. true ifTrue: [^ 1]. - [sender := thisContext swapSender: nil. true ifTrue: [^ 1]] value. Without this patch, #return:from: would return nil instead of activating #cannotReturn: so simulating instead of executing e.g. the first example would not open the expected "computation terminated" debugger. See http://lists.squeakfoundation.org/pipermail/squeak-dev/2021-May/215762.html for more information. Thanks to Jaromir (jar) for pointing to this bug! =============== Diff against Kernel-eem.1408 =============== Item was changed: ----- Method: Context>>return:from: (in category 'instruction decoding') ----- return: value from: aSender "For simulation. Roll back self to aSender and return value from it. Execute any unwind blocks on the way. ASSUMES aSender is a sender of self" | newTop | aSender isDead ifTrue: [^self send: #cannotReturn: to: self with: {value}]. newTop := aSender sender. + newTop ifNil: + [^self send: #cannotReturn: to: self with: {value}]. (self findNextUnwindContextUpTo: newTop) ifNotNil: [:unwindProtectCtxt| ^self send: #aboutToReturn:through: to: self with: {value. unwindProtectCtxt}]. self releaseTo: newTop. newTop ifNotNil: [newTop push: value]. ^newTop!

1 0

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

Packages February 2024