Packages March 2017

packages@lists.squeakfoundation.org

1 participants
168 discussions

The Trunk: Kernel-eem.1074.mcz
by commits＠source.squeak.org 29 Mar '17

29 Mar '17

Eliot Miranda uploaded a new version of Kernel to project The Trunk: http://source.squeak.org/trunk/Kernel-eem.1074.mcz ==================== Summary ==================== Name: Kernel-eem.1074 Author: eem Time: 29 March 2017, 2:29:14.46683 pm UUID: d3593a9c-0922-461c-8ce6-bf562c397ef5 Ancestors: Kernel-ul.1073 Compile all methods inherited from ContextPart by MethodContext in MethodContext, prior to eliminating ContextPart. Eliminate some obsolete methods: hideFromDebugger Add a convenience for scanForInstructionSequence: to CompiledMethod. Update the comments in howToModifyPrimitives, & Object>>instVarAt:[put:] to reflect reality. =============== Diff against Kernel-ul.1073 =============== Item was removed: - ----- Method: BlockContext>>hideFromDebugger (in category 'private') ----- - hideFromDebugger - - ^home ~~ nil and: [home hideFromDebugger]! Item was added: + ----- Method: CompiledMethod>>scanForInstructionSequence: (in category 'scanning') ----- + scanForInstructionSequence: naryBlock + "naryBlock is a block taking one or more arguments. + Evaluate it for each sequence of instructions of length + n in the receiver until naryBlock evaluates to true. + Answer if naryBlock evaluated to true." + ^(InstructionStream on: self) scanForInstructionSequence: naryBlock + " + self systemNavigation browseAllSelect: [:m | m scanForInstructionSequence: [:msg| msg selector = #send:super:numArgs: and: [msg arguments second]]] localTo: thisContext class + "! Item was removed: - ----- Method: ContextPart>>cachesStack (in category 'private-debugger') ----- - cachesStack - - ^false! Item was added: + ----- Method: MethodContext class>>basicNew: (in category 'instance creation') ----- + basicNew: size + ^ (size = CompiledMethod smallFrameSize or: [ size = CompiledMethod fullFrameSize ]) + ifTrue: [ super basicNew: size ] + ifFalse: [ self error: 'Contexts must be ' , CompiledMethod smallFrameSize , ' or ' , CompiledMethod fullFrameSize , ' bytes.' ]! Item was added: + ----- Method: MethodContext class>>carefullyPrint:on: (in category 'private') ----- + carefullyPrint: anObject on: aStream + aStream nextPutAll: ([anObject printString] + on: Error + do: ['unprintable ' , anObject class name])! Item was added: + ----- Method: MethodContext class>>contextEnsure: (in category 'special context creation') ----- + contextEnsure: block + "Create an #ensure: context that is ready to return from executing its receiver" + + | ctxt chain | + ctxt := thisContext. + [chain := thisContext sender cut: ctxt. ctxt jump] ensure: block. + "jump above will resume here without unwinding chain" + ^ chain! Item was added: + ----- Method: MethodContext class>>contextOn:do: (in category 'special context creation') ----- + contextOn: exceptionClass do: block + "Create an #on:do: context that is ready to return from executing its receiver" + + | ctxt chain | + ctxt := thisContext. + [chain := thisContext sender cut: ctxt. ctxt jump] on: exceptionClass do: block. + "jump above will resume here without unwinding chain" + ^ chain! Item was added: + ----- Method: MethodContext class>>initialize (in category 'class initialization') ----- + initialize + ValueIndex := 2. + self assert: (Association instVarNameForIndex:ValueIndex) = 'value'. + PrimitiveFailToken class ~~ Object ifTrue: + [PrimitiveFailToken := Object new]! Item was added: + ----- Method: MethodContext class>>initializedInstance (in category 'instance creation') ----- + initializedInstance + ^ nil! Item was added: + ----- Method: MethodContext class>>isContextClass (in category 'private') ----- + isContextClass + ^true! Item was added: + ----- Method: MethodContext class>>maxLengthForASingleDebugLogReport (in category 'preferences') ----- + maxLengthForASingleDebugLogReport + <preference: 'Max. Debug Report Length' + category: 'debug' + description: 'The description of an Exception stack will be truncated so as to not exceed this value' + type: #Number> + ^MaxLengthForASingleDebugLogReport ifNil: [40000]! Item was added: + ----- Method: MethodContext class>>maxLengthForASingleDebugLogReport: (in category 'preferences') ----- + maxLengthForASingleDebugLogReport: anInteger + MaxLengthForASingleDebugLogReport := anInteger! Item was added: + ----- Method: MethodContext class>>maxStackDepthForASingleDebugLogReport (in category 'preferences') ----- + maxStackDepthForASingleDebugLogReport + <preference: 'Max. Debug Report Stack Depth' + category: 'debug' + description: 'In an exception stack, any sender deeper than this value will not be logged.' + type: #Number> + ^MaxStackDepthForASingleDebugLogReport ifNil: [60]! Item was added: + ----- Method: MethodContext class>>maxStackDepthForASingleDebugLogReport: (in category 'preferences') ----- + maxStackDepthForASingleDebugLogReport: anInteger + MaxStackDepthForASingleDebugLogReport := anInteger! Item was removed: - ----- Method: MethodContext class>>myEnvFieldIndex (in category 'closure support') ----- - myEnvFieldIndex - - ^ self allInstVarNames indexOf: 'receiverMap'! Item was added: + ----- Method: MethodContext class>>new (in category 'instance creation') ----- + new + + self error: 'Contexts must only be created with newForMethod:'! Item was added: + ----- Method: MethodContext class>>new: (in category 'instance creation') ----- + new: size + + self error: 'Contexts must only be created with newForMethod:'! Item was added: + ----- Method: MethodContext class>>newForMethod: (in category 'instance creation') ----- + newForMethod: aMethod + "This is the only method for creating new contexts, other than primitive cloning. + Any other attempts, such as inherited methods like shallowCopy, should be + avoided or must at least be rewritten to determine the proper size from the + method being activated. This is because asking a context its size (even basicSize!!) + will not return the real object size but only the number of fields currently + accessible, as determined by stackp." + + ^ super basicNew: aMethod frameSize! Item was added: + ----- Method: MethodContext class>>primitiveFailToken (in category 'simulation') ----- + primitiveFailToken + + ^ PrimitiveFailToken! Item was added: + ----- Method: MethodContext class>>primitiveFailTokenFor: (in category 'simulation') ----- + primitiveFailTokenFor: errorCode + + ^{PrimitiveFailToken. errorCode}! Item was added: + ----- Method: MethodContext class>>runSimulated: (in category 'simulation') ----- + runSimulated: aBlock + "Simulate the execution of the argument, current. Answer the result it + returns." + + ^ thisContext sender + runSimulated: aBlock + contextAtEachStep: [:ignored] + + "Context runSimulated: [Pen new defaultNib: 5; go: 100]"! Item was added: + ----- Method: MethodContext class>>tallyInstructions: (in category 'examples') ----- + tallyInstructions: aBlock + "This method uses the simulator to count the number of occurrences of + each of the Smalltalk instructions executed during evaluation of aBlock. + Results appear in order of the byteCode set." + | tallies | + tallies := Bag new. + thisContext sender + runSimulated: aBlock + contextAtEachStep: + [:current | tallies add: current nextByte]. + ^tallies sortedElements + + "Context tallyInstructions: [3.14159 printString]"! Item was added: + ----- Method: MethodContext class>>tallyMethods: (in category 'examples') ----- + tallyMethods: aBlock + "This method uses the simulator to count the number of calls on each method + invoked in evaluating aBlock. Results are given in order of decreasing counts." + | prev tallies | + tallies := Bag new. + prev := aBlock. + thisContext sender + runSimulated: aBlock + contextAtEachStep: + [:current | + current == prev ifFalse: "call or return" + [prev sender == nil ifFalse: "call only" + [tallies add: current printString]. + prev := current]]. + ^tallies sortedCounts + + "Context tallyMethods: [3.14159 printString]"! Item was added: + ----- Method: MethodContext class>>theReturnMethod (in category 'special context creation') ----- + theReturnMethod + + | meth | + meth := self lookupSelector: #return:. + meth primitive = 0 ifFalse: [^ self error: 'expected #return: to not be a primitive']. + ^ meth! Item was added: + ----- Method: MethodContext class>>trace: (in category 'examples') ----- + trace: aBlock "Context trace: [3 factorial]" + "This method uses the simulator to print calls and returned values in the Transcript." + + Transcript clear. + ^ self trace: aBlock on: Transcript! Item was added: + ----- Method: MethodContext class>>trace:on: (in category 'examples') ----- + trace: aBlock on: aStream "Context trace: [3 factorial]" + "This method uses the simulator to print calls to a file." + | prev | + prev := aBlock. + ^ thisContext sender + runSimulated: aBlock + contextAtEachStep: + [:current | + Sensor anyButtonPressed ifTrue: [^ nil]. + current == prev + ifFalse: + [prev sender ifNil: + [aStream space; nextPut: $^. + self carefullyPrint: current top on: aStream]. + aStream cr. + (current depthBelow: aBlock) timesRepeat: [aStream space]. + self carefullyPrint: current receiver on: aStream. + aStream space; nextPutAll: current selector; flush. + prev := current]]! Item was added: + ----- Method: MethodContext class>>trace:onFileNamed: (in category 'examples') ----- + trace: aBlock onFileNamed: fileName + "Context trace: [3 factorial] onFileNamed: 'trace'" + "This method uses the simulator to print calls to a file." + + ^FileStream fileNamed: fileName do: [ :file | + self trace: aBlock on: file ]! Item was added: + ----- Method: MethodContext>>activateMethod:withArgs:receiver:class: (in category 'controlling') ----- + activateMethod: newMethod withArgs: args receiver: rcvr class: class + "Answer a ContextPart initialized with the arguments." + + ^MethodContext + sender: self + receiver: rcvr + method: newMethod + arguments: args! Item was added: + ----- Method: MethodContext>>activateReturn:value: (in category 'private') ----- + activateReturn: aContext value: value + "Activate 'aContext return: value' in place of self, so execution will return to aContext's sender" + + ^MethodContext + sender: self + receiver: aContext + method: MethodContext theReturnMethod + arguments: {value}! Item was added: + ----- Method: MethodContext>>arguments (in category 'accessing') ----- + arguments + + ^ Array new: self numArgs streamContents: [:args | + 1 to: self numArgs do: [: i | + args nextPut: (self tempAt: i)]]! Item was added: + ----- Method: MethodContext>>asMessage (in category 'converting') ----- + asMessage + | selector args | + selector := sender method selector. + args := Array new: selector numArgs. + 1 to: selector numArgs do: [ :i | args at: i put: (sender tempAt: i)]. + ^ Message selector: selector arguments: args.! Item was added: + ----- Method: MethodContext>>at: (in category 'accessing') ----- + at: index + "Primitive. Assumes receiver is indexable. Answer the value of an + indexable element in the receiver. Fail if the argument index is not an + Integer or is out of bounds. Essential. See Object documentation + whatIsAPrimitive. Override the default primitive to give latitude to + the VM in context management." + + <primitive: 210> + index isInteger ifTrue: + [self errorSubscriptBounds: index]. + index isNumber + ifTrue: [^self at: index asInteger] + ifFalse: [self errorNonIntegerIndex]! Item was added: + ----- Method: MethodContext>>at:put: (in category 'accessing') ----- + at: index put: value + "Primitive. Assumes receiver is indexable. Answer the value of an + indexable element in the receiver. Fail if the argument index is not + an Integer or is out of bounds. Essential. See Object documentation + whatIsAPrimitive. Override the default primitive to give latitude to + the VM in context management." + + <primitive: 211> + index isInteger ifTrue: + [self errorSubscriptBounds: index]. + index isNumber + ifTrue: [^self at: index asInteger put: value] + ifFalse: [self errorNonIntegerIndex]! Item was added: + ----- Method: MethodContext>>basicAt: (in category 'accessing') ----- + basicAt: index + "Primitive. Assumes receiver is indexable. Answer the value of an + indexable element in the receiver. Fail if the argument index is not an + Integer or is out of bounds. Essential. See Object documentation + whatIsAPrimitive. Override the default primitive to give latitude to + the VM in context management." + + <primitive: 210> + index isInteger ifTrue: + [self errorSubscriptBounds: index]. + index isNumber + ifTrue: [^self at: index asInteger] + ifFalse: [self errorNonIntegerIndex]! Item was added: + ----- Method: MethodContext>>basicAt:put: (in category 'accessing') ----- + basicAt: index put: value + "Primitive. Assumes receiver is indexable. Answer the value of an + indexable element in the receiver. Fail if the argument index is not + an Integer or is out of bounds. Essential. See Object documentation + whatIsAPrimitive. Override the default primitive to give latitude to + the VM in context management." + + <primitive: 211> + index isInteger ifTrue: + [self errorSubscriptBounds: index]. + index isNumber + ifTrue: [^self at: index asInteger put: value] + ifFalse: [self errorNonIntegerIndex]! Item was added: + ----- Method: MethodContext>>basicSize (in category 'accessing') ----- + basicSize + "Primitive. Answer the number of indexable variables in the receiver. + This value is the same as the largest legal subscript. Essential. Do not + override in any subclass. See Object documentation whatIsAPrimitive. Override the default primitive to give latitude to + the VM in context management." + + <primitive: 212> + "The number of indexable fields of fixed-length objects is 0" + ^self primitiveFailed! Item was added: + ----- Method: MethodContext>>blockCopy: (in category 'controlling') ----- + blockCopy: numArgs + "Primitive. Distinguish a block of code from its enclosing method by + creating a new BlockContext for that block. The compiler inserts into all + methods that contain blocks the bytecodes to send the message + blockCopy:. Do not use blockCopy: in code that you write!! Only the + compiler can decide to send the message blockCopy:. Fail if numArgs is + not a SmallInteger. Optional. No Lookup. See Object documentation + whatIsAPrimitive." + + <primitive: 80> + ^ (BlockContext newForMethod: self method) + home: self home + startpc: pc + 2 + nargs: numArgs! Item was added: + ----- Method: MethodContext>>bottomContext (in category 'query') ----- + bottomContext + "Return the last context (the first context invoked) in my sender chain" + + ^ self findContextSuchThat: [:c | c sender isNil]! Item was removed: - ----- Method: MethodContext>>cachesStack (in category 'private-debugger') ----- - cachesStack - - ^ false - "^self selector == #valueUninterruptably - and: [self receiver class == BlockContext]"! Item was added: + ----- Method: MethodContext>>canHandleSignal: (in category 'private-exceptions') ----- + canHandleSignal: exception + "Sent to handler (on:do:) contexts only. If my exception class (first arg) handles exception then return true, otherwise forward this message to the next handler context. If none left, return false (see nil>>canHandleSignal:)" + + ^ (((self tempAt: 1) handles: exception) and: [self tempAt: 3]) + or: [self nextHandlerContext canHandleSignal: exception]. + ! Item was added: + ----- Method: MethodContext>>cannotReturn:to: (in category 'private') ----- + cannotReturn: result to: homeContext + "The receiver tried to return result to homeContext that no longer exists." + + ^ BlockCannotReturn new + result: result; + deadHome: homeContext; + signal! Item was added: + ----- Method: MethodContext>>client (in category 'accessing') ----- + client + "Answer the client, that is, the object that sent the message that created this context." + + ^sender receiver! Item was added: + ----- Method: MethodContext>>closureCopy:copiedValues: (in category 'controlling') ----- + closureCopy: numArgs copiedValues: anArray + "Distinguish a block of code from its enclosing method by + creating a BlockClosure for that block. The compiler inserts into all + methods that contain blocks the bytecodes to send the message + closureCopy:copiedValues:. Do not use closureCopy:copiedValues: in code that you write!! Only the + compiler can decide to send the message closureCopy:copiedValues:. Fail if numArgs is + not a SmallInteger. Optional. No Lookup. See Object documentation + whatIsAPrimitive." + + <primitive: 200> + ^BlockClosure outerContext: self startpc: pc + 2 numArgs: numArgs copiedValues: anArray! Item was added: + ----- Method: MethodContext>>completeCallee: (in category 'system simulation') ----- + completeCallee: aContext + "Simulate the execution of bytecodes until a return to the receiver." + | ctxt current ctxt1 | + ctxt := aContext. + [ctxt == current or: [ctxt hasSender: self]] + whileTrue: + [current := ctxt. + ctxt1 := ctxt quickStep. + ctxt1 ifNil: [self halt]. + ctxt := ctxt1]. + ^self stepToSendOrReturn! Item was changed: ----- Method: MethodContext>>contextForLocalVariables (in category 'accessing') ----- contextForLocalVariables "Answer the context in which local variables (temporaries) are stored." + self subclassResponsibility! - ^self! Item was added: + ----- Method: MethodContext>>contextStack (in category 'debugger access') ----- + contextStack + "Answer an Array of the contexts on the receiver's sender chain." + + ^self stackOfSize: 100000! Item was added: + ----- Method: MethodContext>>copyStack (in category 'query') ----- + copyStack + + ^ self copyTo: nil! Item was added: + ----- Method: MethodContext>>copyTo: (in category 'query') ----- + copyTo: aContext + "Copy self and my sender chain down to, but not including, aContext. End of copied chain will have nil sender." + + | copy | + self == aContext ifTrue: [ ^nil ]. + copy := self copy. + sender ifNotNil: [ copy privSender: (sender copyTo: aContext) ]. + ^copy! Item was added: + ----- Method: MethodContext>>copyTo:bottomContextDo: (in category 'query') ----- + copyTo: aContext bottomContextDo: aBlock + "Copy self and my sender chain down to, but not including, aContext. End of copied chain will have nil sender. Evaluate aBlock with the copy of bottom context when it still points to the original sender." + + | copy | + self == aContext ifTrue: [ ^nil ]. + copy := self copy. + sender + ifNil: [ aBlock value: copy ] + ifNotNil: [ + sender == aContext ifTrue: [ aBlock value: copy ]. + copy privSender: (sender copyTo: aContext bottomContextDo: aBlock) ]. + ^copy! Item was added: + ----- Method: MethodContext>>cut: (in category 'private') ----- + cut: aContext + "Cut aContext and its senders from my sender chain" + + | ctxt callee | + ctxt := self. + [ctxt == aContext] whileFalse: [ + callee := ctxt. + ctxt := ctxt sender. + ctxt ifNil: [aContext ifNotNil: [self error: 'aContext not a sender']]. + ]. + callee privSender: nil. + ! Item was added: + ----- Method: MethodContext>>depthBelow: (in category 'debugger access') ----- + depthBelow: aContext + "Answer how many calls there are between this and aContext." + + | this depth | + this := self. + depth := 0. + [this == aContext or: [this == nil]] + whileFalse: + [this := this sender. + depth := depth + 1]. + ^depth! Item was added: + ----- Method: MethodContext>>doDup (in category 'instruction decoding') ----- + doDup + "Simulate the action of a 'duplicate top of stack' bytecode." + + self push: self top! Item was added: + ----- Method: MethodContext>>doPop (in category 'instruction decoding') ----- + doPop + "Simulate the action of a 'remove top of stack' bytecode." + + self pop! Item was added: + ----- Method: MethodContext>>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: + [ToolSet + debugContext: self + label:'Code simulation error' + contents: nil]. + + ((primitiveIndex between: 201 and: 222) + and: [(self objectClass: receiver) includesBehavior: BlockClosure]) ifTrue: + [((primitiveIndex between: 201 and: 205) "BlockClosure>>value[:value:...]" + or: [primitiveIndex between: 221 and: 222]) ifTrue: "BlockClosure>>valueNoContextSwitch[:]" + [^receiver simulateValueWithArguments: arguments caller: self]. + primitiveIndex = 206 ifTrue: "BlockClosure>>valueWithArguments:" + [^receiver simulateValueWithArguments: arguments first caller: self]]. + + primitiveIndex = 83 ifTrue: "afr 9/11/1998 19:50" "Object>>perform:[with:...]" + [^self send: arguments first to: receiver with: arguments allButFirst super: false]. + primitiveIndex = 84 ifTrue: "afr 9/11/1998 19:50 & eem 8/18/2009 17:04" "Object>>perform:withArguments:" + [^self send: arguments first to: receiver with: (arguments at: 2) lookupIn: (self objectClass: receiver)]. + primitiveIndex = 100 ifTrue: "eem 8/18/2009 16:57" "Object>>perform:withArguments:inSuperclass:" + [^self send: arguments first to: receiver with: (arguments at: 2) lookupIn: (arguments at: 3)]. + + "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: "eem 5/27/2008 11:10 Object>>withArgs:executeMethod:" + [((self objectClass: (arguments at: 1)) == Array + and: [(self objectClass: (arguments at: 2)) includesBehavior: CompiledMethod]) ifFalse: + [^ContextPart primitiveFailTokenFor: #'bad argument']. + (arguments at: 2) numArgs = (arguments at: 1) size ifFalse: + [^ContextPart primitiveFailTokenFor: #'bad number of arguments']. + (arguments at: 2) primitive > 0 ifTrue: + [(arguments at: 2) isQuick ifTrue: + [^self push: (receiver withArgs: (arguments at: 1) executeMethod: (arguments at: 2))]. + ^self doPrimitive: (arguments at: 2) primitive method: (arguments at: 2) receiver: receiver args: (arguments at: 1)]. + ^MethodContext + sender: self + receiver: receiver + method: (arguments at: 2) + arguments: (arguments at: 1)]. + + "Closure primitives" + (primitiveIndex = 200 and: [self == receiver]) ifTrue: + "ContextPart>>closureCopy:copiedValues:; simulated to get startpc right" + [^self push: (BlockClosure + outerContext: receiver + startpc: pc + 2 + numArgs: arguments first + copiedValues: arguments last)]. + + 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: + [^ContextPart 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" + receiver tryPrimitive: primitiveIndex withArgs: arguments]]. + + ^(self isPrimFailToken: value) + ifTrue: [value] + ifFalse: [self push: value]! Item was added: + ----- Method: MethodContext>>exceptionMessage (in category 'accessing') ----- + exceptionMessage + ^ self selector caseOf: { + [#doesNotUnderstand:] -> [self tempAt: 1]. + [#notYetImplemented] -> [self asMessage]. + [#shouldBeImplemented] -> [self asMessage]. + [#subclassResponsibility] -> [self asMessage]} + otherwise: [self error: 'This context is not the result of a message exception.'].! Item was added: + ----- Method: MethodContext>>findContextSuchThat: (in category 'query') ----- + findContextSuchThat: testBlock + "Search self and my sender chain for first one that satisfies testBlock. Return nil if none satisfy" + + | ctxt | + ctxt := self. + [ctxt isNil] whileFalse: [ + (testBlock value: ctxt) ifTrue: [^ ctxt]. + ctxt := ctxt sender. + ]. + ^ nil! Item was added: + ----- Method: MethodContext>>findNextHandlerContextStarting (in category 'private-exceptions') ----- + findNextHandlerContextStarting + "Return the next handler marked context, returning nil if there is none. Search starts with self and proceeds up to nil." + + | ctx | + <primitive: 197> + ctx := self. + [ctx isHandlerContext ifTrue:[^ctx]. + (ctx := ctx sender) == nil ] whileFalse. + ^nil! Item was added: + ----- Method: MethodContext>>findNextUnwindContextUpTo: (in category 'private-exceptions') ----- + findNextUnwindContextUpTo: aContext + "Return the next unwind marked above the receiver, returning nil if there is none. Search proceeds up to but not including aContext." + + | ctx | + <primitive: 195> + ctx := self. + [(ctx := ctx sender) == nil or: [ctx == aContext]] whileFalse: + [ ctx isUnwindContext ifTrue: [^ctx]]. + ^nil! Item was added: + ----- Method: MethodContext>>findSecondToOldestSimilarSender (in category 'query') ----- + findSecondToOldestSimilarSender + "Search the stack for the second-to-oldest occurance of self's method. Very useful for an infinite recursion. Gets back to the second call so you can see one complete recursion cycle, and how it was called at the beginning." + + | sec ctxt bot | + sec := self. + ctxt := self. + [ bot := ctxt findSimilarSender. + bot isNil + ] whileFalse: [ + sec := ctxt. + ctxt := bot. + ]. + ^ sec + ! Item was added: + ----- Method: MethodContext>>findSimilarSender (in category 'query') ----- + findSimilarSender + "Return the closest sender with the same method, return nil if none found" + + | meth | + meth := self method. + ^ self sender findContextSuchThat: [:c | c method == meth]! Item was added: + ----- Method: MethodContext>>handleSignal: (in category 'private-exceptions') ----- + handleSignal: exception + "Sent to handler (on:do:) contexts only. If my exception class (first arg) handles exception + and the handler is active then execute my handle block (second arg), otherwise forward + this message to the next handler context. If none left, execute exception's defaultAction + (see nil>>handleSignal:)." + + | handlerActive val | + "If the context has been returned from the handlerActive temp var may not be accessible." + handlerActive := stackp >= 3 and: [(self tempAt: 3) == true]. + (((self tempAt: 1) handles: exception) and: [handlerActive]) ifFalse: + [^self nextHandlerContext handleSignal: exception]. + + exception privHandlerContext: self contextTag. + self tempAt: 3 put: false. "disable self while executing handle block" + val := [(self tempAt: 2) cull: exception] + ensure: [self tempAt: 3 put: true]. + self return: val "return from self if not otherwise directed in handle block" + ! Item was added: + ----- Method: MethodContext>>hasContext: (in category 'query') ----- + hasContext: aContext + "Answer whether aContext is me or one of my senders" + + ^ (self findContextSuchThat: [:c | c == aContext]) notNil! Item was added: + ----- Method: MethodContext>>hasSender: (in category 'controlling') ----- + hasSender: context + "Answer whether the receiver is strictly above context on the stack." + + | s | + self == context ifTrue: [^false]. + s := sender. + [s == nil] + whileFalse: + [s == context ifTrue: [^true]. + s := s sender]. + ^false! Item was removed: - ----- Method: MethodContext>>hideFromDebugger (in category 'private-debugger') ----- - hideFromDebugger - - | sndr sndrHome | - ^self cachesStack - or: [(sndr := self sender) ~~ nil - and: [(sndrHome := sndr home) ~~ nil - and: [sndrHome cachesStack]]]! Item was added: + ----- Method: MethodContext>>insertSender: (in category 'private') ----- + insertSender: aContext + "Insert aContext and its sender chain between me and my sender. Return new callee of my original sender." + + | ctxt | + ctxt := aContext bottomContext. + ctxt privSender: self sender. + self privSender: aContext. + ^ ctxt! Item was added: + ----- Method: MethodContext>>isBottomContext (in category 'query') ----- + isBottomContext + "Answer if this is the last context (the first context invoked) in my sender chain" + + ^sender isNil! Item was added: + ----- Method: MethodContext>>isContext (in category 'query') ----- + isContext + ^true! Item was added: + ----- Method: MethodContext>>isDead (in category 'query') ----- + isDead + "Has self finished" + + ^ pc isNil! Item was added: + ----- Method: MethodContext>>isPrimFailToken: (in category 'private') ----- + isPrimFailToken: anObject + ^(self objectClass: anObject) == Array + and: [anObject size = 2 + and: [anObject first == PrimitiveFailToken]]! Item was added: + ----- Method: MethodContext>>jump (in category 'controlling') ----- + jump + "Abandon thisContext and resume self instead (using the same current process). You may want to save thisContext's sender before calling this so you can jump back to it. + Self MUST BE a top context (ie. a suspended context or a abandoned context that was jumped out of). A top context already has its return value on its stack (see Interpreter>>primitiveSuspend and other suspending primitives). + thisContext's sender is converted to a top context (by pushing a nil return value on its stack) so it can be jump back to." + + | top | + "Make abandoned context a top context (has return value (nil)) so it can be jumped back to" + thisContext sender push: nil. + + "Pop self return value then return it to self (since we jump to self by returning to it)" + stackp = 0 ifTrue: [self stepToSendOrReturn]. + stackp = 0 ifTrue: [self push: nil]. "must be quick return self/constant" + top := self pop. + thisContext privSender: self. + ^ top! Item was added: + ----- Method: MethodContext>>jump: (in category 'instruction decoding') ----- + jump: distance + "Simulate the action of a 'unconditional jump' bytecode whose offset is + the argument, distance." + + pc := pc + distance! Item was added: + ----- Method: MethodContext>>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. + (bool == true or: [bool == false]) ifFalse: [ + ^self + send: #mustBeBooleanIn: + to: bool + with: {self} + super: false]. + (bool eqv: condition) ifTrue: [self jump: distance]! Item was added: + ----- Method: MethodContext>>longStack (in category 'debugger access') ----- + longStack + "Answer a String showing the top 100 contexts on my sender chain." + + ^ String streamContents: + [:strm | + (self stackOfSize: 100) + do: [:item | strm print: item; cr]]! Item was added: + ----- Method: MethodContext>>methodClass (in category 'debugger access') ----- + methodClass + "Answer the class in which the receiver's method was found." + + ^self method methodClass ifNil: [self objectClass: self receiver].! Item was added: + ----- Method: MethodContext>>methodNode (in category 'accessing') ----- + methodNode + ^ self method methodNode.! Item was added: + ----- Method: MethodContext>>methodNodeFormattedAndDecorated: (in category 'accessing') ----- + methodNodeFormattedAndDecorated: decorate + "Answer a method node made from pretty-printed (and colorized, if decorate is true) + source text." + + ^ self method methodNodeFormattedAndDecorated: decorate.! Item was added: + ----- Method: MethodContext>>methodReturnConstant: (in category 'instruction decoding') ----- + methodReturnConstant: value + "Simulate the action of a 'return constant' bytecode whose value is the + argument, value. This corresponds to a source expression like '^0'." + + ^self return: value from: self methodReturnContext! Item was added: + ----- Method: MethodContext>>methodReturnReceiver (in category 'instruction decoding') ----- + methodReturnReceiver + "Simulate the action of a 'return receiver' bytecode. This corresponds to + the source expression '^self'." + + ^self return: self receiver from: self methodReturnContext! Item was added: + ----- Method: MethodContext>>methodReturnTop (in category 'instruction decoding') ----- + methodReturnTop + "Simulate the action of a 'return top of stack' bytecode. This corresponds + to source expressions like '^something'." + + ^self return: self pop from: self methodReturnContext! Item was added: + ----- Method: MethodContext>>namedTempAt: (in category 'debugger access') ----- + namedTempAt: index + "Answer the value of the temp at index in the receiver's sequence of tempNames." + ^self debuggerMap namedTempAt: index in: self! Item was added: + ----- Method: MethodContext>>namedTempAt:put: (in category 'debugger access') ----- + namedTempAt: index put: aValue + "Set the value of the temp at index in the receiver's sequence of tempNames. + (Note that if the value is a copied value it is also set out along the lexical chain, + but alas not in along the lexical chain.)." + ^self debuggerMap namedTempAt: index put: aValue in: self! Item was added: + ----- Method: MethodContext>>nextHandlerContext (in category 'private-exceptions') ----- + nextHandlerContext + + ^ self sender findNextHandlerContextStarting! Item was added: + ----- Method: MethodContext>>object:basicAt: (in category 'mirror primitives') ----- + object: anObject basicAt: index + "Answer the value of an indexable element in the argument anObject without sending + it a message. Fail if the argument index is not an Integer or is out of bounds, or if + anObject is not indexable. This mimics the action of the VM when it indexes an object. + Used to simulate the execution machinery by, for example, the debugger. + Primitive. See Object documentation whatIsAPrimitive." + + <primitive: 60> + index isInteger ifTrue: [self errorSubscriptBounds: index]. + index isNumber + ifTrue: [^self object: anObject basicAt: index asInteger] + ifFalse: [self errorNonIntegerIndex]! Item was added: + ----- Method: MethodContext>>object:basicAt:put: (in category 'mirror primitives') ----- + object: anObject basicAt: index put: value + "Store the last argument + value in the indexable element of the argument anObject indicated by index without sending + anObject a message. Fail if the argument index is not an Integer or is out of bounds, or if + anObject is not indexable, or if value is an inappropriate value for anObject's indexable slots. + This mimics the action of the VM when it indexes an object. + Used to simulate the execution machinery by, for example, the debugger. + Primitive. See Object documentation whatIsAPrimitive." + + <primitive: 61> + index isInteger + ifTrue: [(index >= 1 and: [index <= (self objectSize: anObject)]) + ifTrue: [self errorImproperStore] + ifFalse: [self errorSubscriptBounds: index]]. + index isNumber + ifTrue: [^self object: anObject basicAt: index asInteger put: value] + ifFalse: [self errorNonIntegerIndex]! Item was added: + ----- Method: MethodContext>>object:eqeq: (in category 'mirror primitives') ----- + object: anObject eqeq: anOtherObject + "Answer whether the first and second arguments are the same object (have the + same object pointer) without sending a message to the first argument. This + mimics the action of the VM when it compares two object pointers. Used to + simulate the execution machinery by, for example, the debugger. + Primitive. See Object documentation whatIsAPrimitive." + + <primitive: 110> + self primitiveFailed! Item was added: + ----- Method: MethodContext>>object:instVarAt: (in category 'mirror primitives') ----- + object: anObject instVarAt: anIndex + "Primitive. Answer a fixed variable in an object. The numbering of the + variables corresponds to the named instance variables. Fail if the index + is not an Integer or is not the index of a fixed variable. Essential for the + debugger. See Object documentation whatIsAPrimitive." + + <primitive: 73> + "Access beyond fixed variables." + ^self object: anObject basicAt: anIndex - (self objectClass: anObject) instSize! Item was added: + ----- Method: MethodContext>>object:instVarAt:put: (in category 'mirror primitives') ----- + object: anObject instVarAt: anIndex put: aValue + "Primitive. Store a value into a fixed variable in the argument anObject. + The numbering of the variables corresponds to the named instance + variables. Fail if the index is not an Integer or is not the index of a + fixed variable. Answer the value stored as the result. Using this + message violates the principle that each object has sovereign control + over the storing of values into its instance variables. Essential for the + debugger. See Object documentation whatIsAPrimitive." + + <primitive: 74> + "Access beyond fixed fields" + ^self object: anObject basicAt: anIndex - (self objectClass: anObject) instSize put: aValue! Item was added: + ----- Method: MethodContext>>object:perform:withArguments:inClass: (in category 'mirror primitives') ----- + object: anObject perform: selector withArguments: argArray inClass: lookupClass + "Send the selector, aSymbol, to anObject with arguments in argArray. + Fail if the number of arguments expected by the selector + does not match the size of argArray, or if lookupClass + cannot be found among the anObject's superclasses. + Primitive. Essential for the debugger." + + <primitive: 100 error: error> + (selector isSymbol) ifFalse: + [^self error: 'selector argument must be a Symbol']. + (argArray isMemberOf: Array) ifFalse: + [^self error: 'argArray must be an Array']. + (selector numArgs = argArray size) + ifFalse: [^self error: 'incorrect number of arguments']. + ((self objectClass: anObject) == lookupClass + or: [(self objectClass: anObject) inheritsFrom: lookupClass]) ifFalse: + [^self error: 'lookupClass is not in anObject''s inheritance chain']. + self primitiveFailed! Item was added: + ----- Method: MethodContext>>objectClass: (in category 'mirror primitives') ----- + objectClass: anObject + "Answer the class of the argument anObject without sending it a message. + This mimics the action of the VM when it fetches an object's class. Used to + simulate the execution machinery by, for example, the debugger. + Primitive. See Object documentation whatIsAPrimitive." + + <primitive: 111> + self primitiveFailed! Item was added: + ----- Method: MethodContext>>objectSize: (in category 'mirror primitives') ----- + objectSize: anObject + "Answer the number of indexable variables in the argument anObject without sending + it a message. This mimics the action of the VM when it fetches an object's variable size. + Used to simulate the execution machinery by, for example, the debugger. + Primitive. See Object documentation whatIsAPrimitive." + + <primitive: 62> + "The number of indexable fields of fixed-length objects is 0" + ^0! Item was changed: ----- Method: MethodContext>>outerContext (in category 'accessing') ----- outerContext "Answer the context within which the receiver is nested." + ^closureOrNil ifNotNil: - ^closureOrNil == nil ifFalse: [closureOrNil outerContext]! Item was added: + ----- Method: MethodContext>>pc (in category 'debugger access') ----- + pc + "Answer the index of the next bytecode to be executed." + + ^pc! Item was added: + ----- Method: MethodContext>>pop (in category 'controlling') ----- + pop + "Answer the top of the receiver's stack and remove the top of the stack." + | val | + val := self at: stackp. + self stackp: stackp - 1. + ^ val! Item was added: + ----- Method: MethodContext>>popIntoLiteralVariable: (in category 'instruction decoding') ----- + popIntoLiteralVariable: value + "Simulate the action of bytecode that removes the top of the stack and + stores it into a literal variable of my method." + + self object: value instVarAt: ValueIndex put: self pop! Item was added: + ----- Method: MethodContext>>popIntoReceiverVariable: (in category 'instruction decoding') ----- + popIntoReceiverVariable: offset + "Simulate the action of bytecode that removes the top of the stack and + stores it into an instance variable of my receiver." + + self object: self receiver instVarAt: offset + 1 put: self pop! Item was added: + ----- Method: MethodContext>>popIntoRemoteTemp:inVectorAt: (in category 'instruction decoding') ----- + popIntoRemoteTemp: remoteTempIndex inVectorAt: tempVectorIndex + "Simulate the action of bytecode that removes the top of the stack and stores + it into an offset in one of my local variables being used as a remote temp vector." + + self object: (self at: tempVectorIndex + 1) basicAt: remoteTempIndex + 1 put: self pop! Item was added: + ----- Method: MethodContext>>popIntoTemporaryVariable: (in category 'instruction decoding') ----- + popIntoTemporaryVariable: offset + "Simulate the action of bytecode that removes the top of the stack and + stores it into one of my temporary variables." + + self at: offset + 1 put: self pop! Item was added: + ----- Method: MethodContext>>print:on: (in category 'debugger access') ----- + print: anObject on: aStream + "Safely print anObject in the face of direct ProtoObject subclasses." + | objClass title | + objClass := self objectClass: anObject. + (objClass canUnderstand: #printOn:) ifTrue: + [^anObject printOn: aStream]. + title := objClass name. + aStream + nextPutAll: (title first isVowel ifTrue: ['an '] ifFalse: ['a ']); + nextPutAll: title! Item was changed: ----- Method: MethodContext>>printOn: (in category 'printing') ----- printOn: aStream + | class mclass selector | + method ifNil: + [^super printOn: aStream]. + closureOrNil ifNotNil: + [aStream nextPutAll: '[] in '. + closureOrNil outerContext printOn: aStream]. + + class := self objectClass: self receiver. + mclass := method methodClass. + selector := method selector ifNil: [method defaultSelector]. + + aStream nextPutAll: class name. + mclass ~~ class ifTrue: + [aStream nextPut: $(; nextPutAll: mclass name; nextPut: $)]. + aStream nextPutAll: '>>'; nextPutAll: selector. + + (selector == #doesNotUnderstand: + and: [(self objectClass: (self tempAt: 1)) == Message]) ifTrue: + [aStream space. + (self tempAt: 1) selector printOn: aStream]! - self outerContext - ifNil: [super printOn: aStream] - ifNotNil: - [:outerContext| - aStream nextPutAll: '[] in '. - outerContext printOn: aStream]! Item was added: + ----- Method: MethodContext>>privSender: (in category 'private') ----- + privSender: aContext + + sender := aContext! Item was added: + ----- Method: MethodContext>>push: (in category 'controlling') ----- + push: val + "Push val on the receiver's stack." + + self stackp: stackp + 1. + self at: stackp put: val! Item was added: + ----- Method: MethodContext>>push:fromIndexable: (in category 'private') ----- + push: numObjects fromIndexable: anIndexableCollection + "Push the elements of anIndexableCollection onto the receiver's stack. + Do not call directly. Called indirectly by {1. 2. 3} constructs." + + 1 to: numObjects do: + [:i | self push: (anIndexableCollection at: i)]! Item was added: + ----- Method: MethodContext>>pushActiveContext (in category 'instruction decoding') ----- + pushActiveContext + "Simulate the action of bytecode that pushes the the active context on the + top of its own stack." + + self push: self! Item was added: + ----- Method: MethodContext>>pushClosureCopyNumCopiedValues:numArgs:blockSize: (in category 'instruction decoding') ----- + pushClosureCopyNumCopiedValues: numCopied numArgs: numArgs blockSize: blockSize + "Simulate the action of a 'closure copy' bytecode whose result is the + new BlockClosure for the following code" + | copiedValues | + numCopied > 0 + ifTrue: + [copiedValues := Array new: numCopied. + numCopied to: 1 by: -1 do: + [:i| + copiedValues at: i put: self pop]] + ifFalse: + [copiedValues := nil]. + self push: (BlockClosure + outerContext: self + startpc: pc + numArgs: numArgs + copiedValues: copiedValues). + self jump: blockSize! Item was added: + ----- Method: MethodContext>>pushConstant: (in category 'instruction decoding') ----- + pushConstant: value + "Simulate the action of bytecode that pushes the constant, value, on the + top of the stack." + + self push: value! Item was added: + ----- Method: MethodContext>>pushLiteralVariable: (in category 'instruction decoding') ----- + pushLiteralVariable: value + "Simulate the action of bytecode that pushes the contents of the literal + variable whose index is the argument, index, on the top of the stack." + + self push: (self object: value instVarAt: ValueIndex)! Item was added: + ----- Method: MethodContext>>pushNewArrayOfSize: (in category 'instruction decoding') ----- + pushNewArrayOfSize: arraySize + self push: (Array new: arraySize)! Item was added: + ----- Method: MethodContext>>pushReceiver (in category 'instruction decoding') ----- + pushReceiver + "Simulate the action of bytecode that pushes the active context's receiver + on the top of the stack." + + self push: self receiver! Item was added: + ----- Method: MethodContext>>pushReceiverVariable: (in category 'instruction decoding') ----- + pushReceiverVariable: offset + "Simulate the action of bytecode that pushes the contents of the receiver's + instance variable whose index is the argument, index, on the top of the + stack." + + self push: (self object: self receiver instVarAt: offset + 1)! Item was added: + ----- Method: MethodContext>>pushRemoteTemp:inVectorAt: (in category 'instruction decoding') ----- + pushRemoteTemp: remoteTempIndex inVectorAt: tempVectorIndex + "Simulate the action of bytecode that pushes the value at remoteTempIndex + in one of my local variables being used as a remote temp vector." + self push: (self object: (self at: tempVectorIndex + 1) basicAt: remoteTempIndex + 1)! Item was added: + ----- Method: MethodContext>>pushTemporaryVariable: (in category 'instruction decoding') ----- + pushTemporaryVariable: offset + "Simulate the action of bytecode that pushes the contents of the + temporary variable whose index is the argument, index, on the top of + the stack." + + self push: (self at: offset + 1)! Item was added: + ----- Method: MethodContext>>quickSend:to:with:super: (in category 'controlling') ----- + quickSend: selector to: rcvr with: arguments super: superFlag + "Send the given selector with arguments in an environment which closely resembles + the non-simulating environment, with an interjected unwind-protected block to catch + nonlocal returns. Attention: don't get lost!! This beautiful method is due to + Hans-Martin Mosner. Eliot Miranda merely added the mirror primitive code." + | oldSender contextToReturnTo result lookupClass | + contextToReturnTo := self. + lookupClass := superFlag + ifTrue: [self method methodClassAssociation value superclass] + ifFalse: [self objectClass: rcvr]. + [oldSender := thisContext sender swapSender: self. + result := self object: rcvr perform: selector withArguments: arguments inClass: lookupClass. + thisContext sender swapSender: oldSender] ifCurtailed: + [contextToReturnTo := thisContext sender receiver. "The block context returning nonlocally" + contextToReturnTo pc: contextToReturnTo previousPc. "skip to front of return bytecode causing this unwind" + contextToReturnTo willReturnTopFromMethod ifTrue: + "If it was a returnTop, push the value to be returned. + Otherwise the value is implicit in the bytecode" + [contextToReturnTo push: (thisContext sender tempAt: 1)]. + thisContext swapSender: thisContext home sender. "Make this block return to the method's sender" + contextToReturnTo]. + contextToReturnTo push: result. + ^contextToReturnTo! Item was added: + ----- Method: MethodContext>>quickStep (in category 'system simulation') ----- + quickStep + "If the next instruction is a send, just perform it. + Otherwise, do a normal step." + + self willReallySend ifTrue: [QuickStep := self]. + ^self step! Item was added: + ----- Method: MethodContext>>readDataFrom:size: (in category 'objects from disk') ----- + readDataFrom: aDataStream size: varsOnDisk + "Fill in the fields of self based on the contents of aDataStream. Answer self. + Read in the instance-variables written by Object>>storeDataOn:. + NOTE: This method must send beginReference: before reading any objects from aDataStream that might reference it. + Allow aDataStream to have fewer inst vars. See SmartRefStream. + Override to not store nil stack contents beyond stack pointer." + | cntInstVars cntIndexedVars | + + cntInstVars := self class instSize. + cntIndexedVars := varsOnDisk - cntInstVars. + cntIndexedVars < 0 ifTrue: + [self error: 'Class has changed too much. Define a convertxxx method']. + + aDataStream beginReference: self. + 1 to: cntInstVars do: + [:i | self instVarAt: i put: aDataStream next]. + 1 to: stackp do: + [:i | self basicAt: i put: aDataStream next]. + stackp + 1 to: cntIndexedVars do: + [:i | aDataStream next ~~ nil ifTrue: + [self error: 'Reading a Context''s contents expects only nil beyond top of stack']]. + "Total number read MUST be equal to varsOnDisk!!" + ^self "If we ever answer something other than self, fix calls + on (super readDataFrom: aDataStream size: anInteger)"! Item was added: + ----- Method: MethodContext>>rearmHandlerDuring: (in category 'private-exceptions') ----- + rearmHandlerDuring: aBlock + "Sent to handler (on:do:) contexts only. Makes me re-entrant for the duration of aBlock. Only works in a closure-enabled image" + + ^ [self tempAt: 3 put: true. aBlock value] + ensure: [self tempAt: 3 put: false]! Item was added: + ----- Method: MethodContext>>release (in category 'debugger access') ----- + release + "Remove information from the receiver and all of the contexts on its + sender chain in order to break circularities." + + self releaseTo: nil! Item was added: + ----- Method: MethodContext>>releaseTo: (in category 'debugger access') ----- + releaseTo: caller + "Remove information from the receiver and the contexts on its sender + chain up to caller in order to break circularities." + + | c s | + c := self. + [c == nil or: [c == caller]] + whileFalse: + [s := c sender. + c singleRelease. + c := s]! Item was added: + ----- Method: MethodContext>>restart (in category 'controlling') ----- + restart + "Unwind thisContext to self and resume from beginning. Execute unwind blocks when unwinding. ASSUMES self is a sender of thisContext" + + | ctxt unwindBlock | + self isDead ifTrue: [self cannotReturn: nil to: self]. + self privRefresh. + ctxt := thisContext. + [ ctxt := ctxt findNextUnwindContextUpTo: self. + ctxt isNil + ] whileFalse: [ + (ctxt tempAt: 2) ifNil:[ + ctxt tempAt: 2 put: true. + unwindBlock := ctxt tempAt: 1. + thisContext terminateTo: ctxt. + unwindBlock value]. + ]. + thisContext terminateTo: self. + self jump. + ! Item was added: + ----- Method: MethodContext>>resume (in category 'controlling') ----- + resume + "Roll back thisContext to self and resume. Execute unwind blocks when rolling back. ASSUMES self is a sender of thisContext" + + self resume: nil! Item was added: + ----- Method: MethodContext>>resume: (in category 'controlling') ----- + resume: value + "Unwind thisContext to self and resume with value as result of last send. Execute unwind blocks when unwinding. ASSUMES self is a sender of thisContext" + + | ctxt unwindBlock | + self isDead ifTrue: [self cannotReturn: value to: self]. + ctxt := thisContext. + [ ctxt := ctxt findNextUnwindContextUpTo: self. + ctxt isNil + ] whileFalse: [ + (ctxt tempAt: 2) ifNil:[ + ctxt tempAt: 2 put: true. + unwindBlock := ctxt tempAt: 1. + thisContext terminateTo: ctxt. + unwindBlock value]. + ]. + thisContext terminateTo: self. + ^ value + ! Item was added: + ----- Method: MethodContext>>resume:through: (in category 'controlling') ----- + resume: value through: firstUnwindCtxt + "Unwind thisContext to self and resume with value as result of last send. + Execute any unwind blocks while unwinding. + ASSUMES self is a sender of thisContext." + + | ctxt unwindBlock | + self isDead ifTrue: [self cannotReturn: value to: self]. + ctxt := firstUnwindCtxt. + [ctxt isNil] whileFalse: + [(ctxt tempAt: 2) ifNil: + [ctxt tempAt: 2 put: true. + unwindBlock := ctxt tempAt: 1. + thisContext terminateTo: ctxt. + unwindBlock value]. + ctxt := ctxt findNextUnwindContextUpTo: self]. + thisContext terminateTo: self. + ^value + ! Item was added: + ----- Method: MethodContext>>return (in category 'controlling') ----- + return + "Unwind until my sender is on top" + + self return: self receiver! Item was added: + ----- Method: MethodContext>>return: (in category 'controlling') ----- + return: value + "Unwind thisContext to self and return value to self's sender. Execute any unwind blocks while unwinding. ASSUMES self is a sender of thisContext" + + sender ifNil: [self cannotReturn: value to: sender]. + sender resume: value! Item was added: + ----- Method: MethodContext>>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 ctxt | + aSender isDead ifTrue: [ + ^ self send: #cannotReturn: to: self with: {value} super: false]. + newTop := aSender sender. + ctxt := self findNextUnwindContextUpTo: newTop. + ctxt ifNotNil: [ + ^ self send: #aboutToReturn:through: to: self with: {value. ctxt} super: false]. + self releaseTo: newTop. + newTop ifNotNil: [newTop push: value]. + ^ newTop + ! Item was added: + ----- Method: MethodContext>>return:through: (in category 'controlling') ----- + return: value through: firstUnwindContext + "Unwind thisContext to self and return value to self's sender. + Execute any unwind blocks while unwinding. + ASSUMES self is a sender of thisContext." + + sender ifNil: [self cannotReturn: value to: sender]. + sender resume: value through: firstUnwindContext! Item was added: + ----- Method: MethodContext>>return:to: (in category 'controlling') ----- + return: value to: sendr + "Simulate the return of value to sendr." + + self releaseTo: sendr. + sendr ifNil: [^ nil]. + ^ sendr push: value! Item was added: + ----- Method: MethodContext>>runSimulated:contextAtEachStep: (in category 'system simulation') ----- + runSimulated: aBlock contextAtEachStep: block2 + "Simulate the execution of the argument, aBlock, until it ends. aBlock + MUST NOT contain an '^'. Evaluate block2 with the current context + prior to each instruction executed. Answer the simulated value of aBlock." + | current | + aBlock hasMethodReturn + ifTrue: [self error: 'simulation of blocks with ^ can run loose']. + current := aBlock asContext. + current pushArgs: Array new from: self. + [current == self] + whileFalse: + [block2 value: current. + current := current step]. + ^self pop! Item was added: + ----- Method: MethodContext>>runUntilErrorOrReturnFrom: (in category 'controlling') ----- + runUntilErrorOrReturnFrom: aSender + "ASSUMES aSender is a sender of self. Execute self's stack until aSender returns or an unhandled exception is raised. Return a pair containing the new top context and a possibly nil exception. The exception is not nil if it was raised before aSender returned and it was not handled. The exception is returned rather than openning the debugger, giving the caller the choice of how to handle it." + "Self is run by jumping directly to it (the active process abandons thisContext and executes self). However, before jumping to self we insert an ensure block under aSender that jumps back to thisContext when evaluated. We also insert an exception handler under aSender that jumps back to thisContext when an unhandled exception is raised. In either case, the inserted ensure and exception handler are removed once control jumps back to thisContext." + + | error ctxt here topContext | + here := thisContext. + + "Insert ensure and exception handler contexts under aSender" + error := nil. + ctxt := aSender insertSender: (ContextPart + contextOn: UnhandledError do: [:ex | + error ifNil: [ + error := ex exception. + topContext := thisContext. + ex resumeUnchecked: here jump] + ifNotNil: [ex pass] + ]). + ctxt := ctxt insertSender: (ContextPart + contextEnsure: [error ifNil: [ + topContext := thisContext. + here jump] + ]). + self jump. "Control jumps to self" + + "Control resumes here once above ensure block or exception handler is executed" + ^ error ifNil: [ + "No error was raised, remove ensure context by stepping until popped" + [ctxt isDead] whileFalse: [topContext := topContext stepToCallee]. + {topContext. nil} + + ] ifNotNil: [ + "Error was raised, remove inserted above contexts then return signaler context" + aSender terminateTo: ctxt sender. "remove above ensure and handler contexts" + {topContext. error} + ]. + ! Item was added: + ----- Method: MethodContext>>secondFromBottom (in category 'query') ----- + secondFromBottom + "Return the second from bottom of my sender chain" + + self sender ifNil: [^ nil]. + ^ self findContextSuchThat: [:c | c sender sender isNil]! Item was added: + ----- Method: MethodContext>>selector (in category 'debugger access') ----- + selector + "Answer the selector of the method that created the receiver." + + ^self method selector ifNil: [self method defaultSelector].! Item was added: + ----- Method: MethodContext>>selectorCategory (in category 'accessing') ----- + selectorCategory + "Answer the category to which this message belongs (relative to the receiver). + If no superclass categorises this message, use the default." + | rcvrClass organizers | + rcvrClass := self objectClass: self receiver. + organizers := rcvrClass withAllSuperclasses collect: [:ea | ea organization]. + organizers addFirst: rcvrClass organization. + ^(organizers collect: [ :org | org categoryOfElement: self selector]) + detect: [:ea | ea ~= ClassOrganizer default and: [ea ~= nil]] + ifNone: [ClassOrganizer default]! Item was added: + ----- Method: MethodContext>>send:super:numArgs: (in category 'instruction decoding') ----- + send: selector super: superFlag numArgs: numArgs + "Simulate the action of bytecodes that send a message with selector, + selector. The argument, superFlag, tells whether the receiver of the + message was specified with 'super' in the source method. The arguments + of the message are found in the top numArgs locations on the stack and + the receiver just below them." + + | receiver arguments | + arguments := Array new: numArgs. + numArgs to: 1 by: -1 do: [ :i | arguments at: i put: self pop]. + receiver := self pop. + QuickStep == self ifTrue: + [QuickStep := nil. + ^self quickSend: selector to: receiver with: arguments super: superFlag]. + ^self send: selector to: receiver with: arguments super: superFlag! Item was added: + ----- Method: MethodContext>>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 primIndex val ctxt | + (meth := lookupClass lookupSelector: selector) ifNil: + [^self send: #doesNotUnderstand: + to: rcvr + with: {Message selector: selector arguments: arguments} + lookupIn: lookupClass]. + meth numArgs ~= arguments size ifTrue: + [^self error: 'Wrong number of arguments in simulated message ', selector printString]. + (primIndex := meth primitive) > 0 ifTrue: + [val := self doPrimitive: primIndex method: meth receiver: rcvr args: arguments. + (self isPrimFailToken: val) ifFalse: + [^val]]. + (selector == #doesNotUnderstand: and: [lookupClass == ProtoObject]) ifTrue: + [^self error: 'Simulated message ', arguments first selector, ' not understood']. + ctxt := MethodContext sender: self receiver: rcvr method: meth arguments: arguments. + primIndex > 0 ifTrue: + [ctxt failPrimitiveWith: val]. + ^ctxt! Item was added: + ----- Method: MethodContext>>send:to:with:startClass: (in category 'controlling') ----- + send: selector to: rcvr with: args startClass: startClassOrNil + "Simulate the action of sending a message with selector, selector, and + arguments, args, to receiver. The argument, startClassOrNil, tells whether + the selector should be looked up in startClassOrNil or the class of the receiver." + + | class meth val ctxt | + class := startClassOrNil ifNil: [self objectClass: rcvr]. + meth := class lookupSelector: selector. + meth == nil ifTrue: + [^self + send: #doesNotUnderstand: + to: rcvr + with: (Array with: (Message selector: selector arguments: args)) + startClass: class]. + (args isArray + and: [args size = meth numArgs]) ifFalse: + [^ContextPart primitiveFailTokenFor: nil]. + val := self tryPrimitiveFor: meth receiver: rcvr args: args. + ((self objectClass: val) == Array + and: [val size = 2 + and: [val first == PrimitiveFailToken]]) ifFalse: + [^val]. + (selector == #doesNotUnderstand: + and: [class == ProtoObject]) ifTrue: + [^self error: 'Simulated message ' , (args at: 1) selector, ' not understood']. + ctxt := self activateMethod: meth withArgs: args receiver: rcvr class: class. + ((self objectClass: val) == Array + and: [val size = 2 + and: [val first == PrimitiveFailToken + and: [val last notNil + and: [(ctxt method at: ctxt pc) = 129 "long store temp"]]]]) ifTrue: + [ctxt at: ctxt stackPtr put: val last]. + ^ctxt! Item was added: + ----- Method: MethodContext>>send:to:with:super: (in category 'controlling') ----- + send: selector to: rcvr with: arguments super: superFlag + "Simulate the action of sending a message with selector arguments + to rcvr. The argument, superFlag, tells whether the receiver of the + message was specified with 'super' in the source method." + + ^self send: selector + to: rcvr + with: arguments + lookupIn: (superFlag + ifTrue: [self method methodClassAssociation value superclass] + ifFalse: [self objectClass: rcvr])! Item was added: + ----- Method: MethodContext>>sender (in category 'debugger access') ----- + sender + "Answer the context that sent the message that created the receiver." + + ^sender! Item was added: + ----- Method: MethodContext>>shortStack (in category 'debugger access') ----- + shortStack + "Answer a String showing the top ten contexts on my sender chain." + + ^ String streamContents: + [:strm | + (self stackOfSize: 10) + do: [:item | strm print: item; cr]]! Item was added: + ----- Method: MethodContext>>singleRelease (in category 'debugger access') ----- + singleRelease + "Remove information from the receiver in order to break circularities." + + stackp == nil ifFalse: [1 to: stackp do: [:i | self at: i put: nil]]. + sender := nil. + pc := nil. + ! Item was added: + ----- Method: MethodContext>>size (in category 'accessing') ----- + size + "Primitive. Answer the number of indexable variables in the receiver. + This value is the same as the largest legal subscript. Essential. See Object + documentation whatIsAPrimitive. Override the default primitive to give latitude to + the VM in context management." + + <primitive: 212> + "The number of indexable fields of fixed-length objects is 0" + ^self primitiveFailed! Item was added: + ----- Method: MethodContext>>sourceCode (in category 'debugger access') ----- + sourceCode + ^self method getSource. + + "Note: The above is a bit safer than + ^ methodClass sourceCodeAt: selector + which may fail if the receiver's method has been changed in + the debugger (e.g., the method is no longer in the methodDict + and thus the above selector is something like #Doit:with:with:with:) + but the source code is still available."! Item was added: + ----- Method: MethodContext>>stack (in category 'debugger access') ----- + stack + "Answer an Array of the contexts on the receiver's sender chain." + + ^self stackOfSize: 9999! Item was added: + ----- Method: MethodContext>>stackOfSize: (in category 'debugger access') ----- + stackOfSize: limit + "Answer an OrderedCollection of the top 'limit' contexts + on the receiver's sender chain." + + | stack ctxt | + stack := OrderedCollection new. + stack addLast: (ctxt := self). + [(ctxt := ctxt sender) ~~ nil + and: [stack size < limit]] whileTrue: + [stack addLast: ctxt]. + ^stack! Item was added: + ----- Method: MethodContext>>stackPtr (in category 'private') ----- + stackPtr "For use only by the SystemTracer and the Debugger, Inspectors etc" + ^ stackp! Item was added: + ----- Method: MethodContext>>stackp: (in category 'private') ----- + stackp: newStackp + "Storing into the stack pointer is a potentially dangerous thing. + This primitive stores nil into any cells that become accessible as a result, + and it performs the entire operation atomically." + "Once this primitive is implemented, failure code should cause an error" + + <primitive: 76> + self error: 'stackp store failure'. + " + stackp == nil ifTrue: [stackp := 0]. + newStackp > stackp 'effectively checks that it is a number' + ifTrue: [oldStackp := stackp. + stackp := newStackp. + 'Nil any newly accessible cells' + oldStackp + 1 to: stackp do: [:i | self at: i put: nil]] + ifFalse: [stackp := newStackp] + "! Item was added: + ----- Method: MethodContext>>step (in category 'system simulation') ----- + step + "Simulate the execution of the receiver's next bytecode. Answer the + context that would be the active context after this bytecode." + + ^self interpretNextInstructionFor: self! Item was added: + ----- Method: MethodContext>>stepToCallee (in category 'system simulation') ----- + stepToCallee + "Step to callee or sender" + + | ctxt | + ctxt := self. + [(ctxt := ctxt step) == self] whileTrue. + ^ ctxt! Item was added: + ----- Method: MethodContext>>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: + [self halt. + "Caused by mustBeBoolean handling" + ^ctxt]]! Item was added: + ----- Method: MethodContext>>storeDataOn: (in category 'objects from disk') ----- + storeDataOn: aDataStream + "Contexts are not always allowed go to out in DataStreams. They must be included inside an ImageSegment, + or be being saved for a closure." + | cntInstVars cntIndexedVars | + + (aDataStream insideASegment + or: [(Notification new tag: self; signal) == self]) ifFalse: "or perhaps ImageSegments were not used at all" + [self error: 'This Context was not included in the ImageSegment']. + + cntInstVars := self class instSize. + cntIndexedVars := self method frameSize. + aDataStream + beginInstance: self class + size: cntInstVars + cntIndexedVars. + 1 to: cntInstVars do: + [:i | aDataStream nextPut: (self instVarAt: i)]. + 1 to: stackp do: + [:i | aDataStream nextPut: (self basicAt: i)]. + stackp + 1 to: cntIndexedVars do: + [:i | aDataStream nextPut: nil]! Item was added: + ----- Method: MethodContext>>storeIntoLiteralVariable: (in category 'instruction decoding') ----- + storeIntoLiteralVariable: value + "Simulate the action of bytecode that stores the top of the stack into a + literal variable of my method." + + self object: value instVarAt: ValueIndex put: self top! Item was added: + ----- Method: MethodContext>>storeIntoReceiverVariable: (in category 'instruction decoding') ----- + storeIntoReceiverVariable: offset + "Simulate the action of bytecode that stores the top of the stack into an + instance variable of my receiver." + + self object: self receiver instVarAt: offset + 1 put: self top! Item was added: + ----- Method: MethodContext>>storeIntoRemoteTemp:inVectorAt: (in category 'instruction decoding') ----- + storeIntoRemoteTemp: remoteTempIndex inVectorAt: tempVectorIndex + "Simulate the action of bytecode that stores the top of the stack at + an offset in one of my local variables being used as a remote temp vector." + + self object: (self at: tempVectorIndex + 1) basicAt: remoteTempIndex + 1 put: self top! Item was added: + ----- Method: MethodContext>>storeIntoTemporaryVariable: (in category 'instruction decoding') ----- + storeIntoTemporaryVariable: offset + "Simulate the action of bytecode that stores the top of the stack into one + of my temporary variables." + + self at: offset + 1 put: self top! Item was added: + ----- Method: MethodContext>>swapSender: (in category 'debugger access') ----- + swapSender: coroutine + "Replace the receiver's sender with coroutine and answer the receiver's + previous sender. For use in coroutining." + + | oldSender | + oldSender := sender. + sender := coroutine. + ^oldSender! Item was added: + ----- Method: MethodContext>>tempNames (in category 'debugger access') ----- + tempNames + "Answer a SequenceableCollection of the names of the receiver's temporary + variables, which are strings." + + ^ self debuggerMap tempNamesForContext: self! Item was added: + ----- Method: MethodContext>>tempsAndValues (in category 'debugger access') ----- + tempsAndValues + "Return a string of the temporary variables and their current values" + ^self debuggerMap tempsAndValuesForContext: self! Item was added: + ----- Method: MethodContext>>tempsAndValuesLimitedTo:indent: (in category 'debugger access') ----- + tempsAndValuesLimitedTo: sizeLimit indent: indent + "Return a string of the temporary variabls and their current values" + + | aStream | + aStream := WriteStream on: (String new: 100). + self tempNames + doWithIndex: [:title :index | + indent timesRepeat: [aStream tab]. + aStream nextPutAll: title; nextPut: $:; space; tab. + aStream nextPutAll: + ((self tempAt: index) printStringLimitedTo: (sizeLimit -3 -title size max: 1)). + aStream cr]. + ^aStream contents! Item was added: + ----- Method: MethodContext>>terminate (in category 'controlling') ----- + terminate + "Make myself unresumable." + + sender := nil. + pc := nil. + ! Item was added: + ----- Method: MethodContext>>terminateTo: (in category 'controlling') ----- + terminateTo: previousContext + "Terminate all the Contexts between me and previousContext, if previousContext is on my Context stack. Make previousContext my sender." + + | currentContext sendingContext | + <primitive: 196> + (self hasSender: previousContext) ifTrue: [ + currentContext := sender. + [currentContext == previousContext] whileFalse: [ + sendingContext := currentContext sender. + currentContext terminate. + currentContext := sendingContext]]. + sender := previousContext! Item was added: + ----- Method: MethodContext>>top (in category 'controlling') ----- + top + "Answer the top of the receiver's stack." + + ^self at: stackp! Item was added: + ----- Method: MethodContext>>tryNamedPrimitiveIn:for:withArgs: (in category 'private') ----- + tryNamedPrimitiveIn: aCompiledMethod for: aReceiver withArgs: arguments + "Invoke the named primitive for aCompiledMethod, answering its result, or, + if the primiitve fails, answering the error code." + <primitive: 218 error: ec> + ec ifNotNil: + ["If ec is an integer other than -1 there was a problem with primitive 218, + not with the external primitive itself. -1 indicates a generic failure (where + ec should be nil) but ec = nil means primitive 218 is not implemented. So + interpret -1 to mean the external primitive failed with a nil error code." + ec isInteger ifTrue: + [ec = -1 + ifTrue: [ec := nil] + ifFalse: [self primitiveFailed]]]. + ^self class primitiveFailTokenFor: ec! Item was added: + ----- Method: MethodContext>>tryPrimitiveFor:receiver:args: (in category 'private') ----- + tryPrimitiveFor: method receiver: receiver args: arguments + "If this method has a primitive index, then run the primitive and return its result. + Otherwise (and also if the primitive fails) return PrimitiveFailToken, + as an indication that the method should be activated and run as bytecodes." + | primIndex | + (primIndex := method primitive) = 0 ifTrue: [^{PrimitiveFailToken. nil}]. + ^ self doPrimitive: primIndex method: method receiver: receiver args: arguments! Item was added: + ----- Method: MethodContext>>unwindTo: (in category 'private-exceptions') ----- + unwindTo: aContext + + | 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 changed: ----- Method: Object class>>howToModifyPrimitives (in category 'documentation') ----- howToModifyPrimitives "You are allowed to write methods which specify primitives, but please use caution. If you make a subclass of a class which contains a primitive method, the subclass inherits the primitive. The message which is implemented primitively may be overridden in the subclass (E.g., see at:put: in String's subclass Symbol). The primitive behavior can be invoked using super (see Symbol string:). A class which attempts to mimic the behavior of another class without being its subclass may or may not be able to use the primitives of the original class. In general, if the instance variables read or written by a primitive have the same meanings and are in the same fields in both classes, the primitive will work. For certain frequently used 'special selectors', the compiler emits a + send-special-selector bytecode instead of a send-message bytecode. Special + selectors were created because they offer two advantages. First, code which + sends special selectors compiles into fewer bytes than normal. Second, for + some pairs of receiver classes and special selectors, the interpreter jumps + directly to a primitive routine without looking up the method in the class, + and the just-in-time (JIT) compiler (if in use) may emit code to directly execute + the primitive. At least in the interpeeter this is much faster than a normal + message lookup. In both the interpreter and the JIT send-special-selector, + conditional branch pairs are short-circuited for the comparison selectors. - send-special-selector bytecode instead of a send-message bytecode. - Special selectors were created because they offer two advantages. Code - which sends special selectors compiles into fewer bytes than normal. For - some pairs of receiver classes and special selectors, the interpreter jumps - directly to a primitive routine without looking up the method in the class. - This is much faster than a normal message lookup. A selector which is a special selector solely in order to save space has a normal behavior. Methods whose selectors are special in order to gain speed contain the comment, 'No Lookup'. When the interpreter encounters a send-special-selector bytecode, it checks the class of the receiver and the selector. If the class-selector pair is a no-lookup pair, then the interpreter swiftly jumps to the routine which implements the corresponding primitive. (A special selector whose receiver is not of the right class to make a no-lookup pair, is looked up normally). The pairs are listed below. No-lookup methods contain a primitive number specification, <primitive: xx>, which is redundant. Since the method is not normally looked up, deleting the primitive number specification cannot prevent this primitive from running. If a no-lookup primitive fails, the method is looked up normally, and the expressions in it are executed. No Lookup pairs of (class, selector) + + SmallInteger and Float with any of + - * / + SmallInteger with any of \\ bitOr: bitShift: bitAnd: // @ + SmallInteger and Float with any of = ~= > < >= <= + Any class with == ~~ class + Point with either of x y (interpreter only) + BlockClosure with either of value value: (interpreter only) - - SmallInteger with any of + - * / \\ bitOr: bitShift: bitAnd: // - SmallInteger with any of = ~= > < >= <= - Any class with == - Any class with @ - Point with either of x y - ContextPart with blockCopy: - BlockContext with either of value value: " self error: 'comment only'! Item was changed: ----- Method: Object>>instVarAt: (in category 'system primitives') ----- instVarAt: index "Primitive. Answer a fixed variable in an object. The numbering of the variables corresponds to the named instance variables, followed by the indexed instance + variables. Fail if the index is not an Integer or is not the index of a fixed or + indexed variable. Essential. See Object documentation whatIsAPrimitive." - variables. Fail if the index is not an Integer or is not the index of a fixed variable. - Essential. See Object documentation whatIsAPrimitive." <primitive: 173 error: ec> self primitiveFailed! Item was changed: ----- Method: Object>>instVarAt:put: (in category 'system primitives') ----- instVarAt: index put: anObject "Primitive. Store a value into a fixed variable in an object. The numbering of the variables corresponds to the named instance variables, followed by the indexed instance variables. Fail if the index is not an Integer or is not the index of a fixed + or indexed variable. Essential. See Object documentation whatIsAPrimitive." - variable. Essential. See Object documentation whatIsAPrimitive." <primitive: 174 error: ec> self primitiveFailed!

1 0

The Trunk: Kernel-ul.1073.mcz
by commits＠source.squeak.org 28 Mar '17

28 Mar '17

Levente Uzonyi uploaded a new version of Kernel to project The Trunk: http://source.squeak.org/trunk/Kernel-ul.1073.mcz ==================== Summary ==================== Name: Kernel-ul.1073 Author: ul Time: 28 March 2017, 2:55:29.274038 am UUID: f89437db-3d34-4690-bebc-6d9bbba66212 Ancestors: Kernel-eem.1072 - cleaned up most senders of undeclared methods - added Exception >> #printDetailsOn:, so that it can safely be sent to any exception from #printVerboseOn: - removed remnants of an old closure experiment - sped up #messages and #messagesDo: of CompiledMethod =============== Diff against Kernel-eem.1072 =============== Item was changed: ----- Method: BlockClosure>>isNestedWithin: (in category 'testing') ----- isNestedWithin: aContextOrBlock "Answer if the receiver is nested within aContextOrBlock, which may be ither a Context, or a BlockClosure." aContextOrBlock ifNotNil: [self outerContextsDo: [:ctxt| (ctxt == aContextOrBlock + or: [ctxt closure = aContextOrBlock]) ifTrue: [^true]]]. - or: [ctxt closureOrNil = aContextOrBlock]) ifTrue: [^true]]]. ^false! Item was changed: ----- Method: ClassDescription>>updateInstancesFrom: (in category 'initialize-release') ----- updateInstancesFrom: oldClass "Recreate any existing instances of the argument, oldClass, as instances of the receiver, which is a newly changed class. Permute variables as necessary, and forward old instances to new instances.. Answer nil to defeat any clients that expected the old behaviour of answering the array of old instances." "ar 7/15/1999: The updating below is possibly dangerous. If there are any contexts having an old instance as receiver it might crash the system if the new receiver in which the context is executed has a different layout. See bottom below for a simple example:" self updateInstances: oldClass allInstances asArray from: oldClass isMeta: self isMeta. - "Now fix up instances in segments that are out on the disk." - ImageSegment allSubInstancesDo: - [:seg | - seg segUpdateInstancesOf: oldClass toBe: self isMeta: self isMeta]. ^nil "This attempts to crash the VM by stepping off the end of an instance. As the doctor says, do not do this." " | crashingBlock class | class := Object subclass: #CrashTestDummy instanceVariableNames: 'instVar' classVariableNames: '' poolDictionaries: '' category: 'Crash-Test'. class compile:'instVar: value instVar := value'. class compile:'crashingBlock ^[instVar]'. crashingBlock := (class new) instVar: 42; crashingBlock. Object subclass: #CrashTestDummy instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Crash-Test'. crashingBlock value"! Item was changed: ----- Method: CompiledMethod>>messages (in category 'scanning') ----- messages "Answer a Set of all the message selectors sent by this method." | scanner aSet | aSet := Set new. scanner := InstructionStream on: self. + scanner scanFor: [ :x | + | selector | + (selector := scanner selectorToSendOrSelf) == scanner ifFalse: [ + aSet add: selector ]. + false "keep scanning" ]. - scanner - scanFor: - [:x | - scanner addSelectorTo: aSet. - false "keep scanning"]. ^aSet! Item was changed: ----- Method: CompiledMethod>>messagesDo: (in category 'scanning') ----- + messagesDo: aBlock + "Evaluate aBlock exactly once with all the message selectors sent by me." - messagesDo: aBlock + | scanner aSet | + self isQuick ifTrue: [ ^self ]. + aSet := nil. + scanner := InstructionStream on: self. + scanner scanFor: [ :x | + | selector | + (selector := scanner selectorToSendOrSelf) == scanner ifFalse: [ + ((aSet ifNil: [ aSet := IdentitySet new ]) addNewElement: selector) ifTrue: [ + aBlock value: selector ] ]. + false "keep scanning" ]! - ^ self messages do:aBlock.! Item was added: + ----- Method: Exception>>printDetailsOn: (in category 'printing') ----- + printDetailsOn: aStream + "Allow applications to optionally print extra details without overriding a base package."! Item was changed: ----- Method: Exception>>printVerboseOn: (in category 'printing') ----- printVerboseOn: aStream aStream nextPutAll: 'vvvvvvvvvvvvvvvvvv ' , self description , ' vvvvvvvvvvvvvvvvvv' ; cr ; nextPutAll: 'The time is ', DateAndTime now asString ; cr. "Allow applications to optionally print extra details without overriding a base package." + self printDetailsOn: aStream. - (self respondsTo: #printDetailsOn:) ifTrue: [ self printDetailsOn: aStream ]. aStream nextPutAll: self signalerContext longStack ; cr ; nextPutAll: '^^^^^^^^^^^^^^^^^^ ' , self description , ' ^^^^^^^^^^^^^^^^^^' ; cr ; flush! Item was removed: - ----- Method: MethodContext>>capturedTempNames (in category 'closure support') ----- - capturedTempNames - - ^ self methodNode scope capturedVars collect: [:var | var name]! Item was removed: - ----- Method: MethodContext>>doItScope (in category 'closure support') ----- - doItScope - "scope (environment) for expressions executed within a method context. self will be the receiver of the do-it method. We want temp vars directly accessible" - - ^ self methodNode scope asDoItScope! Item was removed: - ----- Method: MethodContext>>freeNames (in category 'closure support') ----- - freeNames - - ^ self methodNode freeNames! Item was removed: - ----- Method: MethodContext>>freeNamesAndValues (in category 'closure support') ----- - freeNamesAndValues - - | aStream eval | - eval := [:string | - self class evaluatorClass new - evaluate2: (ReadStream on: string) - in: self - to: nil - notifying: nil "fix this" - ifFail: [self error: 'bug'] - logged: false]. - - aStream := '' writeStream. - self freeNames doWithIndex: [:name :index | - aStream nextPutAll: name; nextPut: $:; space; tab. - (eval value: name) printOn: aStream. - aStream cr]. - ^ aStream contents!

1 0

The Trunk: Network-ul.190.mcz
by commits＠source.squeak.org 26 Mar '17

26 Mar '17

Levente Uzonyi uploaded a new version of Network to project The Trunk: http://source.squeak.org/trunk/Network-ul.190.mcz ==================== Summary ==================== Name: Network-ul.190 Author: ul Time: 26 March 2017, 10:33:09.693969 pm UUID: 3e29be46-381f-4b14-9899-4a25585ddf57 Ancestors: Network-cmm.189 Don't try to disconnect from a not connected socket in Socket >> #closeAndDestroy:, because Squeak doesn't support half-closed connections. =============== Diff against Network-cmm.189 =============== Item was changed: ----- Method: Socket>>closeAndDestroy: (in category 'connection open/close') ----- + closeAndDestroy: timeoutSeconds - closeAndDestroy: timeoutSeconds "First, try to close this connection gracefully. If the close attempt fails or times out, abort the connection. In either case, destroy the socket. Do nothing if the socket has already been destroyed (i.e., if its socketHandle is nil)." + + socketHandle ifNil: [ ^self ]. + self isConnected ifTrue: [ + self close. "Close this end.". + (self waitForDisconnectionFor: timeoutSeconds) ifFalse: [ + "The other end has not closed the connect yet, so we will just abort it." + self primSocketAbortConnection: socketHandle ] ]. - socketHandle ifNil: [ ^ self ]. - self isConnected ifTrue: [ self close ]. - (self waitForDisconnectionFor: timeoutSeconds) ifFalse: - [ "The other end has not closed the connect yet, so we will just abort it." - [ self primSocketAbortConnection: socketHandle ] - on: Error - do: [ : err | "ignore error if invalid handle" ] ]. self destroy!

1 0

The Trunk: Network-cmm.189.mcz
by commits＠source.squeak.org 25 Mar '17

25 Mar '17

Chris Muller uploaded a new version of Network to project The Trunk: http://source.squeak.org/trunk/Network-cmm.189.mcz ==================== Summary ==================== Name: Network-cmm.189 Author: cmm Time: 25 March 2017, 4:00:02.586946 pm UUID: ab3be9be-4a52-4f18-a1f6-4cd0ea6843bd Ancestors: Network-ul.188 Stop throwing errors from Socket>>#closeAndDestroy:. =============== Diff against Network-ul.188 =============== Item was changed: ----- Method: Socket>>closeAndDestroy: (in category 'connection open/close') ----- + closeAndDestroy: timeoutSeconds - closeAndDestroy: timeoutSeconds "First, try to close this connection gracefully. If the close attempt fails or times out, abort the connection. In either case, destroy the socket. Do nothing if the socket has already been destroyed (i.e., if its socketHandle is nil)." + socketHandle ifNil: [ ^ self ]. + self isConnected ifTrue: [ self close ]. + (self waitForDisconnectionFor: timeoutSeconds) ifFalse: + [ "The other end has not closed the connect yet, so we will just abort it." + [ self primSocketAbortConnection: socketHandle ] + on: Error + do: [ : err | "ignore error if invalid handle" ] ]. - - socketHandle ifNil: [ ^self ]. - self isConnected ifTrue: [ - self close. "Close this end." ]. - (self waitForDisconnectionFor: timeoutSeconds) ifFalse: [ - "The other end has not closed the connect yet, so we will just abort it." - self primSocketAbortConnection: socketHandle ]. self destroy!

1 0

The Trunk: Kernel-eem.1072.mcz
by commits＠source.squeak.org 24 Mar '17

24 Mar '17

Eliot Miranda uploaded a new version of Kernel to project The Trunk: http://source.squeak.org/trunk/Kernel-eem.1072.mcz ==================== Summary ==================== Name: Kernel-eem.1072 Author: eem Time: 23 March 2017, 6:27:21.701732 pm UUID: ecabc689-68b4-45ec-9668-a39f089448d0 Ancestors: Kernel-eem.1071 Revert the mistaken fix to needsFrameSize:. It is not the perform:withArguments: context that needs a large frame, but its sender. The arguments are pushed in the sender's context, not the perform:withArguments: context, which doesn't exist at the point the primitive is invoked. If the primitive scceeds then the arguments are pushed on the context which is activated, which will /not/ be perform:withArguments:. If the primitive fails, the arguments will be popped off the stack of the sender's context back into the array. In the Stack (and Cog) VM this is not an issue because there is ample headroom on stack pages. In a context interpreter the correct solution is to defer pushing the arguments until the new method has been found (which I think is the case anyway). In any case setting the large frame bit in perform:withArguments: is wrong. And if it were right, doing it only for perform:withArguments: and not for withArgs:evaluate:, valueWithArguments: and perform:inSuperclass:withArguments: is wrong too. Add an argument count check to the inner simulated send machinery. Nuke isPseudoContext; IIAC it's an obsolete remnant of the old jitter VM. =============== Diff against Kernel-eem.1071 =============== Item was changed: ----- Method: CompiledCode>>needsFrameSize: (in category 'initialize-release') ----- needsFrameSize: newFrameSize "Set the largeFrameBit to accomodate the newFrameSize" | largeFrameBit header | largeFrameBit := 16r20000. (self numTemps + newFrameSize) > LargeFrame ifTrue: [^ self error: 'Cannot compile -- stack including temps is too deep']. header := self objectAt: 1. (header bitAnd: largeFrameBit) ~= 0 ifTrue: [header := header - largeFrameBit]. self objectAt: 1 put: header + + ((self numTemps + newFrameSize) > SmallFrame - + ( ((self numTemps + newFrameSize) > SmallFrame or: [ self primitive = 84 "perform:withArguments:"]) ifTrue: [largeFrameBit] ifFalse: [0])! Item was changed: ----- Method: ContextPart>>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 primIndex val ctxt | (meth := lookupClass lookupSelector: selector) ifNil: [^self send: #doesNotUnderstand: to: rcvr with: {Message selector: selector arguments: arguments} lookupIn: lookupClass]. + meth numArgs ~= arguments size ifTrue: + [^self error: 'Wrong number of arguments in simulated message ', selector printString]. (primIndex := meth primitive) > 0 ifTrue: [val := self doPrimitive: primIndex method: meth receiver: rcvr args: arguments. (self isPrimFailToken: val) ifFalse: [^val]]. (selector == #doesNotUnderstand: and: [lookupClass == ProtoObject]) ifTrue: [^self error: 'Simulated message ', arguments first selector, ' not understood']. ctxt := MethodContext sender: self receiver: rcvr method: meth arguments: arguments. primIndex > 0 ifTrue: [ctxt failPrimitiveWith: val]. ^ctxt! Item was removed: - ----- Method: Object>>isPseudoContext (in category 'testing') ----- - isPseudoContext - ^false!

1 0

The Trunk: Tools-eem.748.mcz
by commits＠source.squeak.org 24 Mar '17

24 Mar '17

Eliot Miranda uploaded a new version of Tools to project The Trunk: http://source.squeak.org/trunk/Tools-eem.748.mcz ==================== Summary ==================== Name: Tools-eem.748 Author: eem Time: 23 March 2017, 6:24:29.602375 pm UUID: af8cdeaa-0777-4ea9-88f3-d89a36ed3d10 Ancestors: Tools-ul.747 Nuke isPseudoCOntext from MethodFinder's approved method list. This class could really do with some love. There are lots of methods it excludes simply because it hasn't been updated. =============== Diff against Tools-ul.747 =============== Item was changed: ----- Method: MethodFinder>>initialize (in category 'initialize') ----- (excessive size, no diff calculated)

1 0

The Trunk: KernelTests-eem.323.mcz
by commits＠source.squeak.org 24 Mar '17

24 Mar '17

Eliot Miranda uploaded a new version of KernelTests to project The Trunk: http://source.squeak.org/trunk/KernelTests-eem.323.mcz ==================== Summary ==================== Name: KernelTests-eem.323 Author: eem Time: 23 March 2017, 6:22:49.201957 pm UUID: 25f68fba-22e0-4b18-b3ac-b7ac720f3f81 Ancestors: KernelTests-eem.322 Move all the tests in and class comment of BlockContextTest into BlockClosureTest and nuke BlockContextTest. Update CompiledMethodTest>>testNew to state that CompiledMehtod>>new /should/ be an error. Update the context tests to use isCompiledMethod, isContext etc, and to drop use of isPseudoContext. =============== Diff against KernelTests-eem.322 =============== Item was changed: TestCase subclass: #BlockClosureTest + instanceVariableNames: 'aBlockClosure homeOfABlockClosure' - instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'KernelTests-Methods'! + + !BlockClosureTest commentStamp: 'eem 3/23/2017 18:07' prior: 0! + I am an SUnit Test of BlockClosure and some of Context's simulation machinery'. See also MethodContextTest. + + My fixtures are: + aBlockClosure - just some trivial block, i.e., [100@100 corner: 200@200]. + homeOfABlockClosure - the home context of the block + + NOTES ABOUT AUTOMATING USER INPUTS + + When executing non-interactive programs you will inevitably run into programs (like SqueakMap or Monticello installation packages -- and other programs, to be fair) that require user input during their execution and these sort of problems shoot the whole non-interactiveness of your enclosing program. + + BlockClosure helper methods have been made available and tests of these helpers are provided in this class to demonstrate that it can intercept PopUpMenu and FillInTheBlankMorph requests for user interaction. Of course, PopUpMenu and FillInTheBlankMorph were modified to first signal a ProvideAnswerNotification and if someone handles that (e.g. the enclosing block) then the user interaction will be circumvented and the provided answer of the enclosing block will be used. The basic syntax looks like: + + [self confirm: 'Install spyware?'] valueSupplyingAnswer: #('Install spyware?' false) + + There a few variants on this theme making it easy to provide a literal list of answers for the block so that you can handle a bunch of questions in a block with appropriate answers. + + Additionally, it is possible to suppress Object>>inform: modal dialog boxes as these get in the way of automating anything. After applying this changeset you should be able to tryout the following code snippets to see the variants on this theme that are available. + + Examples: + + So you don't need any introduction here -- this one works like usual. + [self inform: 'hello'. #done] value. + + Now let's suppress all inform: messages. + [self inform: 'hello'; inform: 'there'. #done] valueSuppressingAllMessages. + + Here we can just suppress a single inform: message. + [self inform: 'hi'; inform: 'there'. #done] valueSuppressingMessages: #('there') + + Here you see how you can suppress a list of messages. + [self inform: 'hi'; inform: 'there'; inform: 'bill'. #done] valueSuppressingMessages: #('hi' 'there') + + Enough about inform:, let's look at confirm:. As you see this one works as expected. + [self confirm: 'You like Squeak?'] value + + Let's supply answers to one of the questions -- check out the return value. + [{self confirm: 'You like Smalltalk?'. self confirm: 'You like Squeak?'}] + valueSupplyingAnswer: #('You like Smalltalk?' true) + + Here we supply answers using only substrings of the questions (for simplicity). + [{self confirm: 'You like Squeak?'. self confirm: 'You like MVC?'}] + valueSupplyingAnswers: #( ('Squeak' true) ('MVC' false) ) + + This time let's answer all questions exactly the same way. + [{self confirm: 'You like Squeak?'. self confirm: 'You like Morphic?'}] + valueSupplyingAnswer: true + + And, of course, we can answer FillInTheBlank questions in the same manner. + [FillInTheBlank request: 'What day is it?'] + valueSupplyingAnswer: 'the first day of the rest of your life' + + We can also return whatever the initialAnswer of the FillInTheBlank was by using the #default answer. + [FillInTheBlank request: 'What day is it?' initialAnswer: DateAndTime now dayOfWeekName] + valueSupplyingAnswer: #default + + Finally, you can also do regex matches on any of the question text (or inform text) (should you have VB-Regex enhancements in your image). + [FillInTheBlank request: 'What day is it?'] + valueSupplyingAnswers: { {'What day.*\?'. DateAndTime now dayOfWeekName} } + + [Comment taken from BlockContextTest last written by jrp 10/17/2004 12:22]! Item was added: + ----- Method: BlockClosureTest>>setUp (in category 'running') ----- + setUp + super setUp. + aBlockClosure := [100@100 corner: 200@200]. + homeOfABlockClosure := thisContext! Item was added: + ----- Method: BlockClosureTest>>testDecompile (in category 'tests - printing') ----- + testDecompile + self assert: ([3 + 4] decompile printString = '{[3 + 4]}')! Item was added: + ----- Method: BlockClosureTest>>testNew (in category 'tests') ----- + testNew + self should: [ContextPart new: 5] raise: Error. + [ContextPart new: 5] + on: Error do: [:e| + self assert: (e messageText includesSubstring: 'newForMethod:') description: 'Error doesn''t tell you what you did wrong by calling #new:']. + + self should: [ContextPart new] raise: Error. + [ContextPart new] + on: Error do: [:e| + self assert: (e messageText includesSubstring: 'newForMethod:') description: 'Error doesn''t tell you what you did wrong by calling #new']! Item was added: + ----- Method: BlockClosureTest>>testNoArguments (in category 'tests') ----- + testNoArguments + [10 + timesRepeat: [:arg | 1 + 2]] + ifError: [:err :rcvr | self deny: err = 'This block requires 1 arguments.']. + [10 + timesRepeat: [:arg1 :arg2 | 1 + 2]] + ifError: [:err :rcvr | self deny: err = 'This block requires 2 arguments.']! Item was added: + ----- Method: BlockClosureTest>>testOneArgument (in category 'tests') ----- + testOneArgument + | c | + c := OrderedCollection new. + c add: 'hello'. + [c + do: [1 + 2]] + ifError: [:err :rcvr | self deny: err = 'This block requires 0 arguments.']. + [c + do: [:arg1 :arg2 | 1 + 2]] + ifError: [:err :rcvr | self deny: err = 'This block requires 2 arguments.']! Item was added: + ----- Method: BlockClosureTest>>testRunSimulated (in category 'tests') ----- + testRunSimulated + self assert: Rectangle equals: (ContextPart runSimulated: aBlockClosure asContext) class! Item was added: + ----- Method: BlockClosureTest>>testSetUp (in category 'tests') ----- + testSetUp + "Note: In addition to verifying that the setUp worked the way it was expected to, testSetUp is used to illustrate the meaning of the simple access methods, methods that are not normally otherwise 'tested'" + self deny: aBlockClosure isContext. + self assert: aBlockClosure isClosure. + self assert: aBlockClosure home = homeOfABlockClosure. + self assert: aBlockClosure receiver = self. + self assert: aBlockClosure method isCompiledMethod! Item was added: + ----- Method: BlockClosureTest>>testSupplyAnswerOfFillInTheBlank (in category 'testing') ----- + testSupplyAnswerOfFillInTheBlank + + self should: ['blue' = ([UIManager default request: 'Your favorite color?'] + valueSupplyingAnswer: #('Your favorite color?' 'blue'))]! Item was added: + ----- Method: BlockClosureTest>>testSupplyAnswerOfFillInTheBlankUsingDefaultAnswer (in category 'testing') ----- + testSupplyAnswerOfFillInTheBlankUsingDefaultAnswer + + self should: ['red' = ([UIManager default request: 'Your favorite color?' initialAnswer: 'red'] + valueSupplyingAnswer: #('Your favorite color?' #default))]! Item was added: + ----- Method: BlockClosureTest>>testSupplyAnswerUsingOnlySubstringOfQuestion (in category 'tests') ----- + testSupplyAnswerUsingOnlySubstringOfQuestion + + self should: [false = ([self confirm: 'You like Smalltalk?'] + valueSupplyingAnswer: #('like' false))]! Item was added: + ----- Method: BlockClosureTest>>testSupplyAnswerUsingRegexMatchOfQuestion (in category 'tests') ----- + testSupplyAnswerUsingRegexMatchOfQuestion + + (String includesSelector: #matchesRegex:) ifFalse: [^ self]. + + self should: [true = ([self confirm: 'You like Smalltalk?'] + valueSupplyingAnswer: #('.*Smalltalk\?' true))]! Item was added: + ----- Method: BlockClosureTest>>testSupplySpecificAnswerToQuestion (in category 'tests') ----- + testSupplySpecificAnswerToQuestion + + self should: [false = ([self confirm: 'You like Smalltalk?'] + valueSupplyingAnswer: #('You like Smalltalk?' false))]! Item was added: + ----- Method: BlockClosureTest>>testSuppressInform (in category 'tests') ----- + testSuppressInform + + self should: [[nil inform: 'Should not see this message or this test failed!!'] valueSuppressingAllMessages isNil]! Item was added: + ----- Method: BlockClosureTest>>testSuppressInformUsingStringMatchOptions (in category 'tests') ----- + testSuppressInformUsingStringMatchOptions + + self should: [([nil inform: 'Should not see this message or this test failed!!'] valueSuppressingMessages: #('Should not see this message or this test failed!!')) isNil]. + + self should: [([nil inform: 'Should not see this message or this test failed!!'] valueSuppressingMessages: #('not see this message')) isNil]. + + self should: [([nil inform: 'Should not see this message or this test failed!!'] valueSuppressingMessages: #('*message*failed#')) isNil]! Item was added: + ----- Method: BlockClosureTest>>testTallyInstructions (in category 'tests') ----- + testTallyInstructions + self assert: (ContextPart tallyInstructions: aBlockClosure asContext) size = 15! Item was added: + ----- Method: BlockClosureTest>>testValueWithPossibleArgs (in category 'tests - evaluating') ----- + testValueWithPossibleArgs + | block blockWithArg blockWith2Arg | + + block := [1]. + blockWithArg := [:arg | arg]. + blockWith2Arg := [:arg1 :arg2 | {arg1. arg2}]. + + self assert: (block valueWithPossibleArgs: #()) = 1. + self assert: (block valueWithPossibleArgs: #(1)) = 1. + + self assert: (blockWithArg valueWithPossibleArgs: #()) = nil. + self assert: (blockWithArg valueWithPossibleArgs: #(1)) = 1. + self assert: (blockWithArg valueWithPossibleArgs: #(1 2)) = 1. + + self assert: (blockWith2Arg valueWithPossibleArgs: #()) = {nil .nil}. + self assert: (blockWith2Arg valueWithPossibleArgs: #(1)) = {1 . nil}. + self assert: (blockWith2Arg valueWithPossibleArgs: #(1 2)) = #(1 2). + self assert: (blockWith2Arg valueWithPossibleArgs: #(1 2 3)) = #(1 2)! Item was added: + ----- Method: BlockClosureTest>>testValueWithPossibleArgument (in category 'tests - evaluating') ----- + testValueWithPossibleArgument + | block blockWithArg blockWith2Arg | + + block := [1]. + blockWithArg := [:arg | arg]. + blockWith2Arg := [:arg1 :arg2 | {arg1. arg2}]. + + self assert: (block valueWithPossibleArgument: 1) = 1. + + self assert: (blockWithArg valueWithPossibleArgument: 1) = 1. + + self assert: (blockWith2Arg valueWithPossibleArgument: 1) = {1 . nil}! Item was removed: - TestCase subclass: #BlockContextTest - instanceVariableNames: 'aBlockContext contextOfaBlockContext' - classVariableNames: '' - poolDictionaries: '' - category: 'KernelTests-Methods'! - - !BlockContextTest commentStamp: 'jrp 10/17/2004 12:22' prior: 0! - I am an SUnit Test of BlockContext and its supertype ContextPart. See also MethodContextTest. - - My fixtures are: - aBlockContext - just some trivial block, i.e., [100@100 corner: 200@200]. - - NOTES ABOUT AUTOMATING USER INPUTS - - When executing non-interactive programs you will inevitably run into programs (like SqueakMap or Monticello installation packages -- and other programs, to be fair) that require user input during their execution and these sort of problems shoot the whole non-interactiveness of your enclosing program. - - BlockContext helper methods have been made available and tests of these helpers are provided in this class to demonstrate that it can intercept PopUpMenu and FillInTheBlankMorph requests for user interaction. Of course, PopUpMenu and FillInTheBlankMorph were modified to first signal a ProvideAnswerNotification and if someone handles that (e.g. the enclosing block) then the user interaction will be circumvented and the provided answer of the enclosing block will be used. The basic syntax looks like: - - [self confirm: 'Install spyware?'] valueSupplyingAnswer: #('Install spyware?' false) - - There a few variants on this theme making it easy to provide a literal list of answers for the block so that you can handle a bunch of questions in a block with appropriate answers. - - Additionally, it is possible to suppress Object>>inform: modal dialog boxes as these get in the way of automating anything. After applying this changeset you should be able to tryout the following code snippets to see the variants on this theme that are available. - - Examples: - - So you don't need any introduction here -- this one works like usual. - [self inform: 'hello'. #done] value. - - Now let's suppress all inform: messages. - [self inform: 'hello'; inform: 'there'. #done] valueSuppressingAllMessages. - - Here we can just suppress a single inform: message. - [self inform: 'hi'; inform: 'there'. #done] valueSuppressingMessages: #('there') - - Here you see how you can suppress a list of messages. - [self inform: 'hi'; inform: 'there'; inform: 'bill'. #done] valueSuppressingMessages: #('hi' 'there') - - Enough about inform:, let's look at confirm:. As you see this one works as expected. - [self confirm: 'You like Squeak?'] value - - Let's supply answers to one of the questions -- check out the return value. - [{self confirm: 'You like Smalltalk?'. self confirm: 'You like Squeak?'}] - valueSupplyingAnswer: #('You like Smalltalk?' true) - - Here we supply answers using only substrings of the questions (for simplicity). - [{self confirm: 'You like Squeak?'. self confirm: 'You like MVC?'}] - valueSupplyingAnswers: #( ('Squeak' true) ('MVC' false) ) - - This time let's answer all questions exactly the same way. - [{self confirm: 'You like Squeak?'. self confirm: 'You like Morphic?'}] - valueSupplyingAnswer: true - - And, of course, we can answer FillInTheBlank questions in the same manner. - [FillInTheBlank request: 'What day is it?'] - valueSupplyingAnswer: 'the first day of the rest of your life' - - We can also return whatever the initialAnswer of the FillInTheBlank was by using the #default answer. - [FillInTheBlank request: 'What day is it?' initialAnswer: DateAndTime now dayOfWeekName] - valueSupplyingAnswer: #default - - Finally, you can also do regex matches on any of the question text (or inform text) (should you have VB-Regex enhancements in your image). - [FillInTheBlank request: 'What day is it?'] - valueSupplyingAnswers: { {'What day.*\?'. DateAndTime now dayOfWeekName} }! Item was removed: - ----- Method: BlockContextTest>>setUp (in category 'running') ----- - setUp - super setUp. - aBlockContext := [100@100 corner: 200@200]. - contextOfaBlockContext := thisContext.! Item was removed: - ----- Method: BlockContextTest>>testDecompile (in category 'tests - printing') ----- - testDecompile - self assert: ([3 + 4] decompile printString = '{[3 + 4]}').! Item was removed: - ----- Method: BlockContextTest>>testNew (in category 'tests') ----- - testNew - self should: [ContextPart new: 5] raise: Error. - [ContextPart new: 5] - on: Error do: [:e| - self assert: (e messageText includesSubstring: 'newForMethod:') description: 'Error doesn''t tell you what you did wrong by calling #new:']. - - self should: [ContextPart new] raise: Error. - [ContextPart new] - on: Error do: [:e| - self assert: (e messageText includesSubstring: 'newForMethod:') description: 'Error doesn''t tell you what you did wrong by calling #new'].! Item was removed: - ----- Method: BlockContextTest>>testNoArguments (in category 'tests') ----- - testNoArguments - [10 - timesRepeat: [:arg | 1 + 2]] - ifError: [:err :rcvr | self deny: err = 'This block requires 1 arguments.']. - [10 - timesRepeat: [:arg1 :arg2 | 1 + 2]] - ifError: [:err :rcvr | self deny: err = 'This block requires 2 arguments.'] ! Item was removed: - ----- Method: BlockContextTest>>testOneArgument (in category 'tests') ----- - testOneArgument - | c | - c := OrderedCollection new. - c add: 'hello'. - [c - do: [1 + 2]] - ifError: [:err :rcvr | self deny: err = 'This block requires 0 arguments.']. - [c - do: [:arg1 :arg2 | 1 + 2]] - ifError: [:err :rcvr | self deny: err = 'This block requires 2 arguments.'] ! Item was removed: - ----- Method: BlockContextTest>>testRunSimulated (in category 'tests') ----- - testRunSimulated - self assert: Rectangle equals: (ContextPart runSimulated: aBlockContext) class.! Item was removed: - ----- Method: BlockContextTest>>testSetUp (in category 'tests') ----- - testSetUp - "Note: In addition to verifying that the setUp worked the way it was expected to, testSetUp is used to illustrate the meaning of the simple access methods, methods that are not normally otherwise 'tested'" - self deny: aBlockContext isMethodContext. - self deny: aBlockContext isPseudoContext. - self assert: aBlockContext home = contextOfaBlockContext. - self assert: aBlockContext receiver = self. - self assert: (aBlockContext method isKindOf: CompiledMethod). - ! Item was removed: - ----- Method: BlockContextTest>>testSupplyAnswerOfFillInTheBlank (in category 'testing') ----- - testSupplyAnswerOfFillInTheBlank - - self should: ['blue' = ([UIManager default request: 'Your favorite color?'] - valueSupplyingAnswer: #('Your favorite color?' 'blue'))]! Item was removed: - ----- Method: BlockContextTest>>testSupplyAnswerOfFillInTheBlankUsingDefaultAnswer (in category 'testing') ----- - testSupplyAnswerOfFillInTheBlankUsingDefaultAnswer - - self should: ['red' = ([UIManager default request: 'Your favorite color?' initialAnswer: 'red'] - valueSupplyingAnswer: #('Your favorite color?' #default))]! Item was removed: - ----- Method: BlockContextTest>>testSupplyAnswerUsingOnlySubstringOfQuestion (in category 'tests') ----- - testSupplyAnswerUsingOnlySubstringOfQuestion - - self should: [false = ([self confirm: 'You like Smalltalk?'] - valueSupplyingAnswer: #('like' false))]! Item was removed: - ----- Method: BlockContextTest>>testSupplyAnswerUsingRegexMatchOfQuestion (in category 'tests') ----- - testSupplyAnswerUsingRegexMatchOfQuestion - - (String includesSelector: #matchesRegex:) ifFalse: [^ self]. - - self should: [true = ([self confirm: 'You like Smalltalk?'] - valueSupplyingAnswer: #('.*Smalltalk\?' true))]! Item was removed: - ----- Method: BlockContextTest>>testSupplySpecificAnswerToQuestion (in category 'tests') ----- - testSupplySpecificAnswerToQuestion - - self should: [false = ([self confirm: 'You like Smalltalk?'] - valueSupplyingAnswer: #('You like Smalltalk?' false))]! Item was removed: - ----- Method: BlockContextTest>>testSuppressInform (in category 'tests') ----- - testSuppressInform - - self should: [[nil inform: 'Should not see this message or this test failed!!'] valueSuppressingAllMessages isNil]! Item was removed: - ----- Method: BlockContextTest>>testSuppressInformUsingStringMatchOptions (in category 'tests') ----- - testSuppressInformUsingStringMatchOptions - - self should: [([nil inform: 'Should not see this message or this test failed!!'] valueSuppressingMessages: #('Should not see this message or this test failed!!')) isNil]. - - self should: [([nil inform: 'Should not see this message or this test failed!!'] valueSuppressingMessages: #('not see this message')) isNil]. - - self should: [([nil inform: 'Should not see this message or this test failed!!'] valueSuppressingMessages: #('*message*failed#')) isNil]. - ! Item was removed: - ----- Method: BlockContextTest>>testTallyInstructions (in category 'tests') ----- - testTallyInstructions - self assert: (ContextPart tallyInstructions: aBlockContext) size = 15.! Item was removed: - ----- Method: BlockContextTest>>testValueWithPossibleArgs (in category 'tests - evaluating') ----- - testValueWithPossibleArgs - | block blockWithArg blockWith2Arg | - - block := [1]. - blockWithArg := [:arg | arg]. - blockWith2Arg := [:arg1 :arg2 | {arg1. arg2}]. - - self assert: (block valueWithPossibleArgs: #()) = 1. - self assert: (block valueWithPossibleArgs: #(1)) = 1. - - self assert: (blockWithArg valueWithPossibleArgs: #()) = nil. - self assert: (blockWithArg valueWithPossibleArgs: #(1)) = 1. - self assert: (blockWithArg valueWithPossibleArgs: #(1 2)) = 1. - - self assert: (blockWith2Arg valueWithPossibleArgs: #()) = {nil .nil}. - self assert: (blockWith2Arg valueWithPossibleArgs: #(1)) = {1 . nil}. - self assert: (blockWith2Arg valueWithPossibleArgs: #(1 2)) = #(1 2). - self assert: (blockWith2Arg valueWithPossibleArgs: #(1 2 3)) = #(1 2). - - - ! Item was removed: - ----- Method: BlockContextTest>>testValueWithPossibleArgument (in category 'tests - evaluating') ----- - testValueWithPossibleArgument - | block blockWithArg blockWith2Arg | - - block := [1]. - blockWithArg := [:arg | arg]. - blockWith2Arg := [:arg1 :arg2 | {arg1. arg2}]. - - self assert: (block valueWithPossibleArgument: 1) = 1. - - self assert: (blockWithArg valueWithPossibleArgument: 1) = 1. - - self assert: (blockWith2Arg valueWithPossibleArgument: 1) = {1 . nil}. - - - ! Item was added: + ----- Method: CompiledMethodTest>>testNew (in category 'tests') ----- + testNew + "This /should/ throw an exception." + self should: [self targetClass new] raise: Error! Item was changed: ----- Method: MethodContextTest>>testMethodContext (in category 'tests') ----- testMethodContext - self deny: aMethodContext isPseudoContext. self assert: aMethodContext home notNil. self assert: aMethodContext receiver notNil. + self assert: aMethodContext method isCompiledMethod.! - self assert: (aMethodContext method isKindOf: CompiledMethod).! Item was changed: ----- Method: MethodContextTest>>testSetUp (in category 'tests') ----- testSetUp "Note: In addition to verifying that the setUp worked the way it was expected to, testSetUp is used to illustrate the meaning of the simple access methods, methods that are not normally otherwise 'tested'" + self assert: aMethodContext isContext. self assert: aMethodContext isMethodContext. self deny: aMethodContext isClosure. - self deny: aMethodContext isPseudoContext. self deny: aMethodContext isDead. "self assert: aMethodContext home = aReceiver." "self assert: aMethodContext blockHome = aReceiver." self assert: aMethodContext receiver = aReceiver. + self assert: aMethodContext method isCompiledMethod. - self assert: (aMethodContext method isKindOf: CompiledMethod). self assert: aMethodContext method = aCompiledMethod. self assert: aMethodContext methodNode selector = #rightCenter. self assert: (aMethodContext methodNodeFormattedAndDecorated: true) selector = #rightCenter. self assert: aMethodContext client printString = 'MethodContextTest>>#testSetUp'. !

1 0

The Trunk: Kernel-eem.1071.mcz
by commits＠source.squeak.org 23 Mar '17

23 Mar '17

Eliot Miranda uploaded a new version of Kernel to project The Trunk: http://source.squeak.org/trunk/Kernel-eem.1071.mcz ==================== Summary ==================== Name: Kernel-eem.1071 Author: eem Time: 23 March 2017, 2:36:33.164059 pm UUID: afff36e4-2c12-45fc-8f45-519d1970e44a Ancestors: Kernel-eem.1070 Update CompiledCode's class comment with more accurate description of bit 16, and add the accessors for it. =============== Diff against Kernel-eem.1070 =============== Item was changed: ByteArray variableByteSubclass: #CompiledCode instanceVariableNames: '' classVariableNames: 'LargeFrame PrimaryBytecodeSetEncoderClass SecondaryBytecodeSetEncoderClass SmallFrame' poolDictionaries: '' category: 'Kernel-Methods'! + !CompiledCode commentStamp: 'eem 3/23/2017 14:33' prior: 0! - !CompiledCode commentStamp: 'eem 3/22/2017 12:14' prior: 0! CompiledCode instances are methods suitable for execution by the virtual machine. Instances of CompiledCode and its subclasses are the only objects in the system that have both indexable pointer fields and indexable 8-bit integer fields. The first part of a CompiledCode object is pointers, the second part is bytes. CompiledCode inherits from ByteArray to avoid duplicating some of ByteArray's methods, not because a CompiledCode is-a ByteArray. Instance variables: *indexed* (no named inst vars) Class variables: SmallFrame - the number of stack slots in a small frame Context LargeFrame - the number of stack slots in a large frame Context PrimaryBytecodeSetEncoderClass - the encoder class that defines the primary instruction set SecondaryBytecodeSetEncoderClass - the encoder class that defines the secondary instruction set The current format of a CompiledCode object is as follows: header (4 or 8 bytes, SmallInteger) literals (4 or 8 bytes each, Object, see "The last literal..." below) bytecodes (variable, bytes) trailer (variable, bytes) The header is a SmallInteger (which in the 32-bit system has 31 bits, and in the 64-bit system, 61 bits) in the following format: (index 0) 15 bits: number of literals (#numLiterals) + (index 15) 1 bit: jit without counters - reserved for methods that have been optimized by Sista - (index 15) 1 bit: is optimized - reserved for methods that have been optimized by Sista (index 16) 1 bit: has primitive (index 17) 1 bit: whether a large frame size is needed (#frameSize => either SmallFrame or LargeFrame) (index 18) 6 bits: number of temporary variables (#numTemps) (index 24) 4 bits: number of arguments to the method (#numArgs) (index 28) 2 bits: reserved for an access modifier (00-unused, 01-private, 10-protected, 11-public), although accessors for bit 29 exist (see #flag). sign bit: 1 bit: selects the instruction set, >= 0 Primary, < 0 Secondary (#signFlag) If the method has a primitive then the first bytecode of the method must be a callPrimitive: bytecode that encodes the primitive index. This bytecode can encode a primitive index from 0 to 65535. The trailer is an encoding of an instance of CompiledMethodTrailer. It is typically used to encode the index into the source files array of the method's source, but may be used to encode other values, e.g. tempNames, source as a string, etc. See the class CompiledMethodTrailer. While there are disadvantages to this "flat" representation (it is impossible to add named instance variables to CompiledCode or its subclasses, but it is possible indirectly; see AdditionalMethodState) it is effective for interpreters. It means that both bytecodes and literals can be fetched directly from a single method object, and that only one object, the method, must be saved and restored on activation and return. A more natural representation, in which there are searate instance variables for the bytecode, and (conveniently) the literals, requires either much more work on activation and return setting up references to the literals and bytecodes, or slower access to bytecodes and literals, indirecting on each access. The last literal of a CompiledCode object is reserved for special use by the kernel and/or the virtual machine. In CompiledMethod instances it must either be the methodClassAssociation, used to implement super sends, or nil, if the method is anonymous. In CompiledBlock it is to be used for a reference to the enclosing method or block object. By convention, the penultimate literal is reserved for special use by the kernel. CompiledMethod instances it must either be the method selector, or an instance of AdditionalMethodState which holds the selector and any pragmas or properties in the method. In CompiledBlock it is reserved for use for an AdditionalMethodState. Note that super sends in CompiledBlock instances do not use a methodClass association, but expect a directed supersend bytecode, in which the method class (the subclass of the class in which to start the lookup) is a literal. Logically when we switch to a bytecode set that supports the directed super send bytecode, and discard the old super send bytecodes, we can use the last literal to store the selector or the enclosing method/block or an AdditionalMethodState, and the AdditionalMethodState can hold the selector and/or the enclosing method/block.! Item was added: + ----- Method: CompiledCode>>hasNoCountersFlag (in category 'accessing') ----- + hasNoCountersFlag + "The Cog Sista VMs interpret bit 16 of the method header as suppressing the generation of performance counters." + ^self header anyMask: 16r8000! Item was added: + ----- Method: CompiledCode>>setHasNoCountersFlag (in category 'accessing') ----- + setHasNoCountersFlag + "The Cog Sista VMs interpret bit 16 of the method header as suppressing the generation of performance counters." + self objectAt: 1 put: (self header bitOr: 16r8000)!

1 0

The Trunk: System-eem.941.mcz
by commits＠source.squeak.org 23 Mar '17

23 Mar '17

Eliot Miranda uploaded a new version of System to project The Trunk: http://source.squeak.org/trunk/System-eem.941.mcz ==================== Summary ==================== Name: System-eem.941 Author: eem Time: 23 March 2017, 11:38:00.919125 am UUID: 37242d96-5f6d-43ac-bbd5-ed33537b04c9 Ancestors: System-ul.940 Move methodReference up from CompiledMethod to CompiledCode. =============== Diff against System-ul.940 =============== Item was added: + ----- Method: CompiledCode>>methodReference (in category '*System-Support') ----- + methodReference + | class selector | + class := self methodClass ifNil: [^nil]. + selector := self selector ifNil: [^nil]. + ^MethodReference class: class selector: selector. + ! Item was removed: - ----- Method: CompiledMethod>>methodReference (in category '*System-Support') ----- - methodReference - | class selector | - class := self methodClass ifNil: [^nil]. - selector := self selector ifNil: [^nil]. - ^MethodReference class: class selector: selector. - !

1 0

The Trunk: EToys-eem.287.mcz
by commits＠source.squeak.org 23 Mar '17

23 Mar '17

Eliot Miranda uploaded a new version of EToys to project The Trunk: http://source.squeak.org/trunk/EToys-eem.287.mcz ==================== Summary ==================== Name: EToys-eem.287 Author: eem Time: 23 March 2017, 11:36:34.533149 am UUID: 530c827e-a23a-4fa8-94f9-2854080179aa Ancestors: EToys-edc.286 Stop Etoys from depending on hasNewPropertyFormat (and apologies for getting the commit order right; this should have been committed earlier). =============== Diff against EToys-edc.286 =============== Item was changed: ----- Method: CompiledMethod>>who (in category '*Etoys-Squeakland-printing') ----- who "Answer an Array of the class in which the receiver is defined and the + selector to which it corresponds." - selector to which it corresponds." + ^{self methodClass ifNil: [#unknown]. self selector ifNil: [#unknown]}! - self hasNewPropertyFormat ifTrue:[^{self methodClass. self selector}]. - self systemNavigation allBehaviorsDo: - [:class | - (class methodDict keyAtIdentityValue: self ifAbsent: [nil]) ifNotNilDo: - [:sel| ^Array with: class with: sel]]. - ^Array with: #unknown with: #unknown!

1 0

← Newer
1
2
3
4
5
6
7
8
...
17
Older →

Jump to page:

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

Packages March 2017