Packages November 2013

packages@lists.squeakfoundation.org

1 participants
315 discussions

The Trunk: Kernel-eem.822.mcz
by commits＠source.squeak.org 30 Nov '13

30 Nov '13

Eliot Miranda uploaded a new version of Kernel to project The Trunk: http://source.squeak.org/trunk/Kernel-eem.822.mcz ==================== Summary ==================== Name: Kernel-eem.822 Author: eem Time: 30 November 2013, 1:21:56.41 pm UUID: b991e66c-90bb-4118-91c7-4b7dbe38d440 Ancestors: Kernel-cmm.821 Change the execution simulation machinery (as used by the Debugger) to: - use the mirror primitives to access the receiver and literal variables, avoiding sending messages to these objects, hence mimicking the VMs behaviour, and simulating the execution of code using proxies correctly. - retrieve the primitive error code form failing primitives - fix the simulation of Object>>perform:withArguments:inSuperclass: =============== Diff against Kernel-cmm.821 =============== Item was changed: + ----- Method: BlockClosure>>simulateValueWithArguments:caller: (in category 'system simulation') ----- - ----- Method: BlockClosure>>simulateValueWithArguments:caller: (in category 'evaluating') ----- simulateValueWithArguments: anArray caller: aContext | newContext sz | (anArray class ~~ Array or: [numArgs ~= anArray size]) ifTrue: + [^ContextPart primitiveFailTokenFor: nil]. - [^ContextPart primitiveFailToken]. newContext := (MethodContext newForMethod: outerContext method) setSender: aContext receiver: outerContext receiver method: outerContext method closure: self startpc: startpc. sz := self basicSize. newContext stackp: sz + numArgs. 1 to: numArgs do: [:i| newContext at: i put: (anArray at: i)]. 1 to: sz do: [:i| newContext at: i + numArgs put: (self at: i)]. ^newContext! Item was changed: InstructionStream subclass: #ContextPart instanceVariableNames: 'stackp' + classVariableNames: 'MaxLengthForASingleDebugLogReport MaxStackDepthForASingleDebugLogReport PrimitiveFailToken QuickStep ValueIndex' - classVariableNames: 'MaxLengthForASingleDebugLogReport MaxStackDepthForASingleDebugLogReport PrimitiveFailToken QuickStep' poolDictionaries: '' category: 'Kernel-Methods'! !ContextPart commentStamp: '<historical>' prior: 0! To the instruction parsing ability of InstructionStream I add the actual semantics for execution. The execution state is stored in the indexable fields of my subclasses. This includes temporary variables and a stack of values used in evaluating expressions. The actual semantics of execution can be found in my category "system simulation" and "instruction decode". These methods exactly parallel the operation of the Smalltalk machine itself. The simulator is a group of my methods that do what the Smalltalk interpreter does: execute Smalltalk bytecodes. By adding code to the simulator, you may take statistics on the running of Smalltalk methods. For example, Transcript show: (ContextPart runSimulated: [3 factorial]) printString.! Item was changed: + ----- Method: ContextPart class>>initialize (in category 'class initialization') ----- - ----- Method: ContextPart class>>initialize (in category 'simulation') ----- initialize + ValueIndex := 2. + self assert: (Association instVarNameForIndex:ValueIndex) = 'value'. + PrimitiveFailToken class ~~ Object ifTrue: + [PrimitiveFailToken := Object new]! - - "A unique object to be returned when a primitive fails during simulation" - PrimitiveFailToken := Object new ! Item was added: + ----- Method: ContextPart class>>primitiveFailTokenFor: (in category 'simulation') ----- + primitiveFailTokenFor: errorCode + + ^{PrimitiveFailToken. errorCode}! Item was changed: ----- Method: ContextPart>>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 ^ 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 primtiive 19 with care :-)" "SystemNavigation new browseAllSelect: [:m| m primitive = 19]" primitiveIndex = 19 ifTrue: [ToolSet debugContext: self label:'Code simulation error' contents: nil]. "ContextPart>>blockCopy:; simulated to get startpc right" + (primitiveIndex = 80 and: [(self objectClass: receiver) includesBehavior: ContextPart]) - (primitiveIndex = 80 and: [receiver isKindOf: ContextPart]) ifTrue: [^self push: ((BlockContext newForMethod: receiver method) home: receiver home startpc: pc + 2 nargs: (arguments at: 1))]. + (primitiveIndex = 81 and: [(self objectClass: receiver) == BlockContext]) "BlockContext>>value[:value:...]" - (primitiveIndex = 81 and: [receiver isMemberOf: BlockContext]) "BlockContext>>value[:value:...]" ifTrue: [^receiver pushArgs: arguments from: self]. + (primitiveIndex = 82 and: [(self objectClass: receiver) == BlockContext]) "BlockContext>>valueWithArguments:" - (primitiveIndex = 82 and: [receiver isMemberOf: BlockContext]) "BlockContext>>valueWithArguments:" ifTrue: [^receiver pushArgs: arguments first from: self]. primitiveIndex = 83 "afr 9/11/1998 19:50" "Object>>perform:[with:...]" + ifTrue: [^self send: arguments first + to: receiver - ifTrue: [^self send: arguments first to: receiver with: arguments allButFirst super: false]. + primitiveIndex = 84 "afr 9/11/1998 19:50 & eem 8/18/2009 17:04" "Object>>perform:withArguments:" + ifTrue: [^self send: arguments first + to: receiver - primitiveIndex = 84 "afr 9/11/1998 19:50" "Object>>perform:withArguments:" - ifTrue: [^self send: arguments first to: receiver with: (arguments at: 2) + startClass: nil]. + primitiveIndex = 100 "eem 8/18/2009 16:57" "Object>>perform:withArguments:inSuperclass:" + ifTrue: [^self send: arguments first + to: receiver + with: (arguments at: 2) + startClass: (arguments at: 3)]. + + "Mutex>>primitiveEnterCriticalSection + Mutex>>primitiveTestAndSetOwnershipOfCriticalSection" + (primitiveIndex = 186 or: [primitiveIndex = 187]) ifTrue: + [| active effective | + active := Processor activeProcess. + effective := active effectiveProcess. + "active == effective" + value := primitiveIndex = 186 + ifTrue: [receiver primitiveEnterCriticalSectionOnBehalfOf: effective] + ifFalse: [receiver primitiveTestAndSetOwnershipOfCriticalSectionOnBehalfOf: effective]. + ^((self objectClass: value) == Array + and: [value size = 2 + and: [value first == PrimitiveFailToken]]) + ifTrue: [value] + ifFalse: [self push: value]]. + + primitiveIndex = 188 ifTrue: "eem 5/27/2008 11:10 Object>>withArgs:executeMethod:" + [^MethodContext - super: false]. - primitiveIndex = 188 ifTrue: [ - arguments size = 2 ifTrue: [ "eem 5/27/2008 11:10 Object>>withArgs:executeMethod:" - ^MethodContext - sender: self - receiver: receiver - method: (arguments at: 2) - arguments: (arguments at: 1) ]. - arguments size = 3 ifTrue: [ "CompiledMethod class >> #receiver:withArguments:executeMethod:" - ^MethodContext - sender: self - receiver: (arguments at: 1) - method: (arguments at: 3) - arguments: (arguments at: 2) ] ]. - primitiveIndex = 189 ifTrue: [ "Object >> (#with:)*executeMethod" - ^MethodContext sender: self receiver: receiver + method: (arguments at: 2) + arguments: (arguments at: 1)]. - method: arguments last - arguments: arguments allButLast ]. "Closure primitives" + (primitiveIndex = 200 and: [self == receiver]) ifTrue: - (primitiveIndex = 200 and: [receiver == self]) ifTrue: "ContextPart>>closureCopy:copiedValues:; simulated to get startpc right" [^self push: (BlockClosure outerContext: receiver startpc: pc + 2 numArgs: arguments first copiedValues: arguments last)]. ((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 = 118 ifTrue: "tryPrimitive:withArgs:; avoid recursing in the VM" + [(arguments size = 2 + and: [arguments first isInteger + 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: + [receiver tryPrimitive: primitiveIndex withArgs: arguments]]. + ^((self objectClass: value) == Array + and: [value size = 2 + and: [value first == PrimitiveFailToken]]) + ifTrue: [value] - primitiveIndex = 120 ifTrue:[ "FFI method" - value := meth literals first tryInvokeWithArguments: arguments. - ] ifFalse:[ - arguments size > 6 ifTrue: [^PrimitiveFailToken]. - value := primitiveIndex = 117 "named primitives" - ifTrue:[self tryNamedPrimitiveIn: meth for: receiver withArgs: arguments] - ifFalse:[receiver tryPrimitive: primitiveIndex withArgs: arguments]. - ]. - ^value == PrimitiveFailToken - ifTrue: [PrimitiveFailToken] ifFalse: [self push: value]! Item was changed: ----- Method: ContextPart>>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 changed: ----- Method: ContextPart>>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! - value value: self pop! Item was changed: ----- Method: ContextPart>>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! - self receiver instVarAt: offset + 1 put: self pop! Item was changed: ----- Method: ContextPart>>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! - (self at: tempVectorIndex + 1) at: remoteTempIndex + 1 put: self pop! Item was changed: ----- Method: ContextPart>>printOn: (in category 'printing') ----- printOn: aStream + | method selector class mclass | + (method := self method) ifNil: [^super printOn: aStream]. + class := self objectClass: self receiver. + mclass := method methodClass. + selector := method selector ifNil: [method defaultSelector]. - | selector class mclass | - self method == nil ifTrue: [^ super printOn: aStream]. - class := self receiver class. - mclass := self methodClass. - selector := self selector ifNil:[self method defaultSelector]. aStream nextPutAll: class name. + mclass ~~ class ifTrue: + [aStream nextPut: $(; nextPutAll: mclass name; nextPut: $)]. + aStream nextPutAll: '>>'; nextPutAll: selector. + (selector == #doesNotUnderstand: + and: [self closure isNil + and: [(self objectClass: (self tempAt: 1)) == Message]]) ifTrue: + [aStream space. + (self tempAt: 1) selector printOn: aStream]! - mclass == class - ifFalse: - [aStream nextPut: $(. - aStream nextPutAll: mclass name. - aStream nextPut: $)]. - aStream nextPutAll: '>>'. - aStream nextPutAll: selector. - selector = #doesNotUnderstand: ifTrue: [ - aStream space. - (self tempAt: 1) selector printOn: aStream. - ]. - ! Item was changed: ----- Method: ContextPart>>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)! - self push: value value! Item was changed: ----- Method: ContextPart>>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)! - self push: (self receiver instVarAt: offset + 1)! Item was changed: ----- Method: ContextPart>>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)! - self push: ((self at: tempVectorIndex + 1) at: remoteTempIndex + 1)! Item was changed: ----- Method: ContextPart>>quickSend:to:with:super: (in category 'controlling') ----- quickSend: selector to: receiver 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 | - "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!!" - | lookupClass contextToReturnTo result | contextToReturnTo := self. lookupClass := superFlag + ifTrue: [self method methodClassAssociation value superclass] + ifFalse: [self objectClass: self receiver]. + [oldSender := thisContext sender swapSender: self. + result := self object: receiver perform: selector withArguments: arguments inClass: lookupClass. + thisContext sender swapSender: oldSender] ifCurtailed: + [contextToReturnTo := thisContext sender receiver. "The block context returning nonlocally" - ifTrue: [(self method literalAt: self method numLiterals) value superclass] - ifFalse: [receiver class]. - [ | oldSender | - oldSender := thisContext sender swapSender: self. - result := receiver perform: selector withArguments: arguments inSuperclass: lookupClass. - thisContext sender swapSender: oldSender] ifCurtailed: [ - contextToReturnTo := thisContext sender receiver. "The block context returning nonlocally" contextToReturnTo jump: -1. "skip to front of return bytecode causing this unwind" + contextToReturnTo nextByte = 16r7C ifTrue: - contextToReturnTo nextByte = 16r7C 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)]. - 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: ContextPart>>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 changed: ----- Method: ContextPart>>send:to:with:super: (in category 'controlling') ----- send: selector to: rcvr with: args super: superFlag + "Simulate the action of sending a message with selector, selector, and + arguments, args, to receiver. The argument, superFlag, tells whether the + receiver of the message was specified with 'super' in the source method." - "Simulate the action of sending a message with selector, selector, and - arguments, args, to receiver. The argument, superFlag, tells whether the - receiver of the message was specified with 'super' in the source method." + | class meth val ctxt | - | class meth val | class := superFlag + ifTrue: [self method methodClassAssociation value superclass] + ifFalse: [self objectClass: rcvr]. - ifTrue: [(self method literalAt: self method numLiterals) value superclass] - ifFalse: [rcvr class]. meth := class lookupSelector: selector. + meth == nil ifTrue: + [^self + send: #doesNotUnderstand: + to: rcvr + with: (Array with: (Message selector: selector arguments: args)) + super: superFlag]. + 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! - meth == nil - ifTrue: [^ self send: #doesNotUnderstand: - to: rcvr - with: (Array with: (Message selector: selector arguments: args)) - super: superFlag] - ifFalse: [val := self tryPrimitiveFor: meth - receiver: rcvr - args: args. - val == PrimitiveFailToken ifFalse: [^ val]. - (selector == #doesNotUnderstand: and: [class == ProtoObject]) ifTrue: - [^ self error: 'Simulated message ' , (args at: 1) selector - , ' not understood']. - ^ self activateMethod: meth - withArgs: args - receiver: rcvr - class: class]! Item was changed: ----- Method: ContextPart>>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! - value value: self top! Item was changed: ----- Method: ContextPart>>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! - self receiver instVarAt: offset + 1 put: self top! Item was changed: ----- Method: ContextPart>>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! - (self at: tempVectorIndex + 1) at: remoteTempIndex + 1 put: self top! Item was changed: ----- Method: ContextPart>>tryNamedPrimitiveIn:for:withArgs: (in category 'private') ----- tryNamedPrimitiveIn: aCompiledMethod for: aReceiver withArgs: arguments + | selector theMethod spec receiverClass | + <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]]. + ^{PrimitiveFailToken. ec}]. + "Assume a nil error code implies the primitive is not implemented and fall back on the old code." "Hack. Attempt to execute the named primitive from the given compiled method" + arguments size > 8 ifTrue: + [^{PrimitiveFailToken. nil}]. - | selector theMethod spec | - arguments size > 8 ifTrue:[^PrimitiveFailToken]. selector := #( tryNamedPrimitive tryNamedPrimitive: tryNamedPrimitive:with: tryNamedPrimitive:with:with: tryNamedPrimitive:with:with:with: tryNamedPrimitive:with:with:with:with: tryNamedPrimitive:with:with:with:with:with: tryNamedPrimitive:with:with:with:with:with:with: tryNamedPrimitive:with:with:with:with:with:with:with:) at: arguments size+1. + receiverClass := self objectClass: aReceiver. + theMethod := receiverClass lookupSelector: selector. + theMethod == nil ifTrue: + [^{PrimitiveFailToken. nil}]. - theMethod := aReceiver class lookupSelector: selector. - theMethod == nil ifTrue:[^PrimitiveFailToken]. spec := theMethod literalAt: 1. spec replaceFrom: 1 to: spec size with: (aCompiledMethod literalAt: 1) startingAt: 1. + Smalltalk unbindExternalPrimitives. + ^self object: aReceiver perform: selector withArguments: arguments inClass: receiverClass! - theMethod flushCache. - selector flushCache. - ^aReceiver perform: selector withArguments: arguments! Item was changed: ----- Method: ContextPart>>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}]. - (primIndex := method primitive) = 0 ifTrue: [^ PrimitiveFailToken]. ^ self doPrimitive: primIndex method: method receiver: receiver args: arguments! Item was changed: ----- Method: ProtoObject>>tryNamedPrimitive (in category 'apply primitives') ----- tryNamedPrimitive "This method is a template that the Smalltalk simulator uses to execute primitives. See Object documentation whatIsAPrimitive." + <primitive:'' module:'' error: errorCode> + ^ContextPart primitiveFailTokenFor: errorCode! - <primitive:'' module:''> - ^ ContextPart primitiveFailToken! Item was changed: ----- Method: ProtoObject>>tryNamedPrimitive: (in category 'apply primitives') ----- tryNamedPrimitive: arg1 "This method is a template that the Smalltalk simulator uses to execute primitives. See Object documentation whatIsAPrimitive." + <primitive:'' module:'' error: errorCode> + ^ContextPart primitiveFailTokenFor: errorCode! - <primitive:'' module:''> - ^ ContextPart primitiveFailToken! Item was changed: ----- Method: ProtoObject>>tryNamedPrimitive:with: (in category 'apply primitives') ----- tryNamedPrimitive: arg1 with: arg2 "This method is a template that the Smalltalk simulator uses to execute primitives. See Object documentation whatIsAPrimitive." + <primitive:'' module:'' error: errorCode> + ^ContextPart primitiveFailTokenFor: errorCode! - <primitive:'' module:''> - ^ ContextPart primitiveFailToken! Item was changed: ----- Method: ProtoObject>>tryNamedPrimitive:with:with: (in category 'apply primitives') ----- tryNamedPrimitive: arg1 with: arg2 with: arg3 "This method is a template that the Smalltalk simulator uses to execute primitives. See Object documentation whatIsAPrimitive." + <primitive:'' module:'' error: errorCode> + ^ContextPart primitiveFailTokenFor: errorCode! - <primitive:'' module:''> - ^ ContextPart primitiveFailToken! Item was changed: ----- Method: ProtoObject>>tryNamedPrimitive:with:with:with: (in category 'apply primitives') ----- tryNamedPrimitive: arg1 with: arg2 with: arg3 with: arg4 "This method is a template that the Smalltalk simulator uses to execute primitives. See Object documentation whatIsAPrimitive." + <primitive:'' module:'' error: errorCode> + ^ContextPart primitiveFailTokenFor: errorCode! - <primitive:'' module:''> - ^ ContextPart primitiveFailToken! Item was changed: ----- Method: ProtoObject>>tryNamedPrimitive:with:with:with:with: (in category 'apply primitives') ----- tryNamedPrimitive: arg1 with: arg2 with: arg3 with: arg4 with: arg5 "This method is a template that the Smalltalk simulator uses to execute primitives. See Object documentation whatIsAPrimitive." + <primitive:'' module:'' error: errorCode> + ^ContextPart primitiveFailTokenFor: errorCode! - <primitive:'' module:''> - ^ ContextPart primitiveFailToken! Item was changed: ----- Method: ProtoObject>>tryNamedPrimitive:with:with:with:with:with: (in category 'apply primitives') ----- tryNamedPrimitive: arg1 with: arg2 with: arg3 with: arg4 with: arg5 with: arg6 "This method is a template that the Smalltalk simulator uses to execute primitives. See Object documentation whatIsAPrimitive." + <primitive:'' module:'' error: errorCode> + ^ContextPart primitiveFailTokenFor: errorCode! - <primitive:'' module:''> - ^ ContextPart primitiveFailToken! Item was changed: ----- Method: ProtoObject>>tryNamedPrimitive:with:with:with:with:with:with: (in category 'apply primitives') ----- tryNamedPrimitive: arg1 with: arg2 with: arg3 with: arg4 with: arg5 with: arg6 with: arg7 "This method is a template that the Smalltalk simulator uses to execute primitives. See Object documentation whatIsAPrimitive." + <primitive:'' module:'' error: errorCode> + ^ContextPart primitiveFailTokenFor: errorCode! - <primitive:'' module:''> - ^ ContextPart primitiveFailToken! Item was changed: ----- Method: ProtoObject>>tryNamedPrimitive:with:with:with:with:with:with:with: (in category 'apply primitives') ----- tryNamedPrimitive: arg1 with: arg2 with: arg3 with: arg4 with: arg5 with: arg6 with: arg7 with: arg8 "This method is a template that the Smalltalk simulator uses to execute primitives. See Object documentation whatIsAPrimitive." + <primitive:'' module:'' error: errorCode> + ^ContextPart primitiveFailTokenFor: errorCode! - <primitive:'' module:''> - ^ ContextPart primitiveFailToken! Item was changed: ----- Method: ProtoObject>>tryPrimitive:withArgs: (in category 'apply primitives') ----- tryPrimitive: primIndex withArgs: argumentArray "This method is a template that the Smalltalk simulator uses to execute primitives. See Object documentation whatIsAPrimitive." + <primitive: 118 error: errorCode> + ^ContextPart primitiveFailTokenFor: errorCode! - <primitive: 118> - ^ ContextPart primitiveFailToken!

1 0

The Trunk: Kernel-eem.822.mcz
by commits＠source.squeak.org 30 Nov '13

30 Nov '13

1 0

The Trunk: MorphicExtras-fbs.128.mcz
by commits＠source.squeak.org 30 Nov '13

30 Nov '13

Frank Shearar uploaded a new version of MorphicExtras to project The Trunk: http://source.squeak.org/trunk/MorphicExtras-fbs.128.mcz ==================== Summary ==================== Name: MorphicExtras-fbs.128 Author: fbs Time: 30 November 2013, 10:55:47.146 am UUID: 44325252-0685-7e4c-878d-d6600bac5532 Ancestors: MorphicExtras-fbs.127 Deprecate MorphicExtras' selector mangling utilities - they've been moved to MorphicExtras, on String and Symbol. =============== Diff against MorphicExtras-fbs.127 =============== Item was changed: ----- Method: FlapTab>>adjustPositionVisAVisFlap (in category 'positioning') ----- adjustPositionVisAVisFlap | sideToAlignTo opposite | opposite := Utilities oppositeSideTo: edgeToAdhereTo. sideToAlignTo := inboard ifTrue: [opposite] ifFalse: [edgeToAdhereTo]. + self perform: sideToAlignTo asSimpleSetter with: (referent perform: opposite)! - self perform: (Utilities simpleSetterFor: sideToAlignTo) with: (referent perform: opposite)! Item was added: + ----- Method: Symbol>>asSimpleSetter (in category '*MorphicExtras-Flaps') ----- + asSimpleSetter + ^ (self, ':') asSymbol!

1 0

The Trunk: MorphicExtras-fbs.128.mcz
by commits＠source.squeak.org 30 Nov '13

30 Nov '13

1 0

The Trunk: MorphicExtras-fbs.128.mcz
by commits＠source.squeak.org 30 Nov '13

30 Nov '13

1 0

The Trunk: EToys-fbs.114.mcz
by commits＠source.squeak.org 30 Nov '13

30 Nov '13

Frank Shearar uploaded a new version of EToys to project The Trunk: http://source.squeak.org/trunk/EToys-fbs.114.mcz ==================== Summary ==================== Name: EToys-fbs.114 Author: fbs Time: 30 November 2013, 10:54:44.004 am UUID: 9c792e38-b75c-a34b-86e1-303566cfd28c Ancestors: EToys-fbs.113 Update eToys to the new selector-mangling API based on String/Symbol, rather than Utilities class. =============== Diff against EToys-fbs.113 =============== Item was changed: ----- Method: AssignmentTileMorph>>computeOperatorOrExpression (in category 'initialization') ----- computeOperatorOrExpression "Compute the operator or expression to use, and set the wording correectly on the tile face" | aSuffix wording anInterface getter doc | operatorOrExpression := (assignmentRoot, assignmentSuffix) asSymbol. aSuffix := self currentVocabulary translatedWordingFor: assignmentSuffix. + getter := assignmentRoot asGetterSelector. - getter := Utilities getterSelectorFor: assignmentRoot. anInterface := self currentVocabulary methodInterfaceAt: getter ifAbsent: [Vocabulary eToyVocabulary methodInterfaceAt: getter ifAbsent: [nil]]. wording := anInterface ifNotNil: [anInterface wording] ifNil: [assignmentRoot copyWithout: $:]. (anInterface notNil and: [(doc := anInterface documentation) notNil]) ifTrue: [self setBalloonText: doc]. operatorReadoutString := wording translated, ' ', aSuffix. self line1: operatorReadoutString. self addArrowsIfAppropriate! Item was changed: ----- Method: AssignmentTileMorph>>storeCodeOn:indent: (in category 'code generation') ----- storeCodeOn: aStream indent: tabCount "Generate code for an assignment statement. The code generated looks presentable in the case of simple assignment, though the code generated for the increment/decrement/multiply cases is still the same old assignGetter... sort for now" + aStream nextPutAll: (assignmentRoot asSetterSelector). - aStream nextPutAll: (Utilities setterSelectorFor: assignmentRoot). aStream space."Simple assignment, don't need existing value" assignmentSuffix = ':' ifFalse: ["Assignments that require that old values be retrieved" self assignmentReceiverTile storeCodeOn: aStream indent: tabCount. aStream space. + aStream nextPutAll: (assignmentRoot asGetterSelector). - aStream nextPutAll: (Utilities getterSelectorFor: assignmentRoot). aStream space. aStream nextPutAll: (self operatorForAssignmentSuffix: assignmentSuffix). aStream space]! Item was changed: ----- Method: CategoryViewer>>getterButtonFor:type: (in category 'get/set slots') ----- getterButtonFor: getterSelector type: partType "Answer a classic-tiles getter button for a part of the given name" | m inherent wording | m := TileMorph new adoptVocabulary: self currentVocabulary. + inherent := getterSelector inherentSelector. - inherent := Utilities inherentSelectorForGetter: getterSelector. wording := (scriptedPlayer slotInfo includesKey: inherent) ifTrue: [inherent] ifFalse: [self currentVocabulary tileWordingForSelector: getterSelector]. m setOperator: getterSelector andUseWording: wording. m typeColor: (ScriptingSystem colorForType: partType). m on: #mouseDown send: #makeGetter:event:from: to: self withValue: (Array with: getterSelector with: partType). ^ m! Item was changed: ----- Method: CategoryViewer>>makeSetter:event:from: (in category 'get/set slots') ----- makeSetter: selectorAndTypePair event: evt from: aMorph "Classic tiles: make a Phrase that comprises a setter of a slot, and hand it to the user." | argType m argTile selfTile argValue actualGetter | selectorAndTypePair first = #getPatchValueIn: ifTrue: [^ self makeSetterForGetPatchValue: selectorAndTypePair event: evt from: aMorph]. selectorAndTypePair first = #getRedComponentIn: ifTrue: [^ self makeSetterForColorComponent: selectorAndTypePair componentName: #red event: evt from: aMorph]. selectorAndTypePair first = #getBlueComponentIn: ifTrue: [^ self makeSetterForColorComponent: selectorAndTypePair componentName: #blue event: evt from: aMorph]. selectorAndTypePair first = #getGreenComponentIn: ifTrue: [^ self makeSetterForColorComponent: selectorAndTypePair componentName: #green event: evt from: aMorph]. argType := selectorAndTypePair second. actualGetter := selectorAndTypePair first asSymbol. m := PhraseTileMorph new + setAssignmentRoot: actualGetter inherentSelector - setAssignmentRoot: (Utilities inherentSelectorForGetter: actualGetter) type: #command rcvrType: #Player argType: argType vocabulary: self currentVocabulary. argValue := self scriptedPlayer perform: selectorAndTypePair first asSymbol. argValue isPlayerLike ifTrue: [argTile := argValue tileReferringToSelf] ifFalse: [argTile := ScriptingSystem tileForArgType: argType. (argType == #Number and: [argValue isNumber]) ifTrue: [(scriptedPlayer decimalPlacesForGetter: actualGetter) ifNotNil: [:places | (argTile findA: UpdatingStringMorph) decimalPlaces: places]]. argTile setLiteral: argValue; updateLiteralLabel]. argTile position: m lastSubmorph position. m lastSubmorph addMorph: argTile. selfTile := self tileForSelf bePossessive. selfTile position: m firstSubmorph position. m firstSubmorph addMorph: selfTile. m enforceTileColorPolicy. m openInHand! Item was changed: ----- Method: CategoryViewer>>newTilesFor:setter: (in category 'get/set slots') ----- newTilesFor: aPlayer setter: aSpec | ms argValue | "Return universal tiles for a getter on this property. Record who self is." + argValue := aPlayer perform: (aSpec second asSymbol asGetterSelector). - argValue := aPlayer perform: (Utilities getterSelectorFor: aSpec second asSymbol). ms := MessageSend receiver: aPlayer selector: aSpec ninth arguments: (Array with: argValue). ^ ms asTilesIn: aPlayer class globalNames: (aPlayer class officialClass ~~ CardPlayer) "For CardPlayers, use 'self'. For others, name it, and use its name."! Item was changed: ----- Method: CategoryViewer>>phraseForVariableFrom: (in category 'entries') ----- phraseForVariableFrom: aMethodInterface "Return a structure consisting of tiles and controls and a readout representing a 'variable' belonging to the player, complete with an appropriate readout when indicated. Functions in both universalTiles mode and classic mode. Slightly misnamed in that this path is used for any methodInterface that indicates an interesting resultType." | anArrow slotName getterButton cover inner aRow doc setter tryer universal hotTileForSelf spacer buttonFont varName | aRow := ViewerLine newRow color: self color; beSticky; elementSymbol: (slotName := aMethodInterface selector); wrapCentering: #center; cellPositioning: #leftCenter. (universal := scriptedPlayer isUniversalTiles) ifFalse: [buttonFont := Preferences standardEToysFont. aRow addMorphBack: (Morph new color: self color; extent: (((buttonFont widthOfString: '!!') + 8) @ (buttonFont height + 6)); yourself)]. "spacer" aRow addMorphBack: (self infoButtonFor: slotName). aRow addMorphBack: (Morph new color: self color; extent: 0@10). " vertical spacer" universal ifTrue: [inner := scriptedPlayer universalTilesForGetterOf: aMethodInterface. cover := Morph new color: Color transparent. cover extent: inner fullBounds extent. (getterButton := cover copy) addMorph: cover; addMorphBack: inner. cover on: #mouseDown send: #makeUniversalTilesGetter:event:from: to: self withValue: aMethodInterface. aRow addMorphFront: (tryer := ScriptingSystem tryButtonFor: inner). tryer color: tryer color lighter lighter] ifFalse: [hotTileForSelf := self tileForSelf bePossessive. hotTileForSelf on: #mouseDown send: #makeGetter:event:from: to: self withValue: (Array with: aMethodInterface selector with: aMethodInterface resultType). aRow addMorphBack: hotTileForSelf. aRow addMorphBack: (spacer := Morph new color: self color; extent: 2@10). spacer on: #mouseEnter send: #addGetterFeedback to: aRow. spacer on: #mouseLeave send: #removeHighlightFeedback to: aRow. spacer on: #mouseLeaveDragging send: #removeHighlightFeedback to: aRow. spacer on: #mouseDown send: #makeGetter:event:from: to: self withValue: (Array with: aMethodInterface selector with: aMethodInterface resultType). hotTileForSelf on: #mouseEnter send: #addGetterFeedback to: aRow. hotTileForSelf on: #mouseLeave send: #removeHighlightFeedback to: aRow. hotTileForSelf on: #mouseLeaveDragging send: #removeHighlightFeedback to: aRow. getterButton := self getterButtonFor: aMethodInterface selector type: aMethodInterface resultType]. aRow addMorphBack: getterButton. getterButton on: #mouseEnter send: #addGetterFeedback to: aRow. getterButton on: #mouseLeave send: #removeHighlightFeedback to: aRow. getterButton on: #mouseLeaveDragging send: #removeHighlightFeedback to: aRow. (doc := aMethodInterface documentation) ifNotNil: [getterButton setBalloonText: doc]. + (scriptedPlayer slotInfo includesKey: (varName := slotName inherentSelector)) "user slot" - (scriptedPlayer slotInfo includesKey: (varName := Utilities inherentSelectorForGetter: slotName)) "user slot" ifTrue: ["aRow addTransparentSpacerOfSize: 3@0. aRow addMorphBack: (self slotTypeMenuButtonFor: varName)"]. universal ifFalse: [(slotName == #seesColor:) ifTrue: [self addIsOverColorDetailTo: aRow. ^ aRow]. (slotName == #touchesA:) ifTrue: [self addTouchesADetailTo: aRow. ^ aRow]. (slotName == #overlaps: or: [ slotName == #overlapsAny:]) ifTrue: [self addOverlapsDetailTo: aRow. ^ aRow]]. aRow addMorphBack: (AlignmentMorph new beTransparent). "flexible spacer" (setter := aMethodInterface companionSetterSelector) ifNotNil: [aRow addMorphBack: (Morph new color: self color; extent: 2@10). " spacer" anArrow := universal ifTrue: [self arrowSetterButton: #newMakeSetterFromInterface:evt:from: args: aMethodInterface] ifFalse: [self arrowSetterButton: #makeSetter:from:forPart: args: (Array with: slotName with: aMethodInterface resultType)]. anArrow beTransparent. universal ifFalse: [anArrow on: #mouseEnter send: #addSetterFeedback to: aRow. anArrow on: #mouseLeave send: #removeHighlightFeedback to: aRow. anArrow on: #mouseLeaveDragging send: #removeHighlightFeedback to: aRow]. aRow addMorphBack: anArrow]. (#(color:sees: playerSeeingColor copy touchesA: overlaps: getTurtleAt: getTurtleOf:) includes: slotName) ifFalse: [(universal and: [slotName == #seesColor:]) ifFalse: [aMethodInterface wantsReadoutInViewer ifTrue: [aRow addMorphBack: (self readoutFor: slotName type: aMethodInterface resultType readOnly: setter isNil getSelector: aMethodInterface selector putSelector: setter)]]]. anArrow ifNotNil: [anArrow step]. ^ aRow! Item was changed: ----- Method: EToyVocabulary>>allMethodsInCategory:forInstance:ofClass: (in category 'method list') ----- allMethodsInCategory: aCategoryName forInstance: anObject ofClass: aClass "Answer a list of all methods in the etoy interface which are in the given category, on behalf of anObject, or if it is nil, aClass" | aCategory unfiltered suitableSelectors isAll | aCategoryName ifNil: [^ OrderedCollection new]. aClass isUniClass ifTrue: [aCategoryName = ScriptingSystem nameForScriptsCategory ifTrue: [^ aClass namedTileScriptSelectors]. aCategoryName = ScriptingSystem nameForInstanceVariablesCategory ifTrue: [^ aClass slotInfo keys asArray sort collect: + [:anInstVarName | anInstVarName asGetterSelector]]]. - [:anInstVarName | Utilities getterSelectorFor: anInstVarName]]]. unfiltered := (isAll := aCategoryName = self allCategoryName) ifTrue: [methodInterfaces collect: [:anInterface | anInterface selector]] ifFalse: [aCategory := categories detect: [:cat | cat categoryName = aCategoryName] ifNone: [^ OrderedCollection new]. aCategory elementsInOrder collect: [:anElement | anElement selector]]. (anObject isKindOf: Player) ifTrue: [suitableSelectors := anObject costume selectorsForViewer. unfiltered := unfiltered select: [:aSelector | suitableSelectors includes: aSelector]]. (isAll and: [aClass isUniClass]) ifTrue: [unfiltered addAll: aClass namedTileScriptSelectors. unfiltered addAll: (aClass slotInfo keys asArray sort collect: + [:anInstVarName | anInstVarName asGetterSelector])]. - [:anInstVarName | Utilities getterSelectorFor: anInstVarName])]. ^ (unfiltered copyWithoutAll: #(dummy unused)) asSortedArray! Item was changed: ----- Method: EToyVocabulary>>includesSelector:forInstance:ofClass:limitClass: (in category 'initialization') ----- includesSelector: aSelector forInstance: anInstance ofClass: aTargetClass limitClass: mostGenericClass "Answer whether the vocabulary includes the given selector for the given class (and instance, if provided), only considering method implementations in mostGenericClass and lower" | classToUse aClass | (aTargetClass isUniClass and: [(aTargetClass namedTileScriptSelectors includes: aSelector) or: [aTargetClass slotInfo keys anySatisfy: + [:anInstVarName | (anInstVarName asGetterSelector) = aSelector or: [(anInstVarName asSetterSelector) = aSelector]]]]) - [:anInstVarName | (Utilities getterSelectorFor: anInstVarName) = aSelector or: [(Utilities setterSelectorFor: anInstVarName) = aSelector]]]]) ifTrue: [^ true]. (methodInterfaces includesKey: aSelector) ifFalse: [^ false]. classToUse := self classToUseFromInstance: anInstance ofClass: aTargetClass. ^ (aClass := classToUse whichClassIncludesSelector: aSelector) ifNil: [false] ifNotNil: [aClass includesBehavior: mostGenericClass] ! Item was added: + TestCase subclass: #EtoysStringExtensionTest + instanceVariableNames: '' + classVariableNames: '' + poolDictionaries: '' + category: 'Etoys-Tests'! Item was added: + ----- Method: EtoysStringExtensionTest>>testGetterSelectorForReturnsAccessorName (in category 'as yet unclassified') ----- + testGetterSelectorForReturnsAccessorName + self assert: #getFoo equals: #foo asGetterSelector. + self assert: #getFoo equals: #Foo asGetterSelector. + self assert: #getFoo equals: 'foo' asGetterSelector. + + "Special cases:" + self assert: #seesColor: equals: 'isOverColor:' asGetterSelector. + self assert: #seesColor: equals: #isOverColor: asGetterSelector. + self assert: #getNewClone equals: 'copy' asGetterSelector. + self assert: #getNewClone equals: #copy asGetterSelector.! Item was added: + ----- Method: EtoysStringExtensionTest>>testInherentSelectorForGetterReturnsBaseName (in category 'as yet unclassified') ----- + testInherentSelectorForGetterReturnsBaseName + "Inverse of #asGetterSelector" + self assert: #foo equals: #getFoo inherentSelector. + self assert: #foo equals: #getfoo inherentSelector. + self assert: #foo equals: 'getFoo' inherentSelector. + + "Leaves other selector-like things alone, except for Symbol-ness" + self assert: #foo equals: 'foo' inherentSelector. + self assert: #foo equals: #foo inherentSelector. + self assert: #get equals: #get inherentSelector. + self assert: #GETAWAY equals: #GETAWAY inherentSelector. + self assert: #geFoo equals: #geFoo inherentSelector.! Item was added: + ----- Method: EtoysStringExtensionTest>>testSetterSelectorForReturnsMutatorName (in category 'as yet unclassified') ----- + testSetterSelectorForReturnsMutatorName + self assert: #setFoo: equals: #foo asSetterSelector. + self assert: #setFoo: equals: #Foo asSetterSelector. + self assert: #setFoo: equals: 'foo' asSetterSelector.! Item was changed: ----- Method: KedamaCategoryViewer>>makeSetter:event:from: (in category 'get/set slots') ----- makeSetter: selectorAndTypePair event: evt from: aMorph "Classic tiles: make a Phrase that comprises a setter of a slot, and hand it to the user." | argType m argTile selfTile argValue actualGetter | selectorAndTypePair first = #getPatchValueIn: ifTrue: [^ self makeSetterForGetPatchValue: selectorAndTypePair event: evt from: aMorph]. selectorAndTypePair first = #getRedComponentIn: ifTrue: [^ self makeSetterForColorComponent: selectorAndTypePair componentName: #red event: evt from: aMorph]. selectorAndTypePair first = #getBlueComponentIn: ifTrue: [^ self makeSetterForColorComponent: selectorAndTypePair componentName: #blue event: evt from: aMorph]. selectorAndTypePair first = #getGreenComponentIn: ifTrue: [^ self makeSetterForColorComponent: selectorAndTypePair componentName: #green event: evt from: aMorph]. argType := selectorAndTypePair second. actualGetter := selectorAndTypePair first asSymbol. m := PhraseTileMorph new + setAssignmentRoot: actualGetter inherentSelector - setAssignmentRoot: (Utilities inherentSelectorForGetter: actualGetter) type: #command rcvrType: #Player argType: argType vocabulary: self currentVocabulary. argValue := self scriptedPlayer perform: selectorAndTypePair first asSymbol. (argValue isKindOf: Player) ifTrue: [argTile := argValue tileReferringToSelf] ifFalse: [argTile := ScriptingSystem tileForArgType: argType. (argType == #Number and: [argValue isNumber]) ifTrue: [(scriptedPlayer decimalPlacesForGetter: actualGetter) ifNotNil: [:places | (argTile findA: UpdatingStringMorph) decimalPlaces: places]]. argTile setLiteral: argValue; updateLiteralLabel]. argTile position: m lastSubmorph position. m lastSubmorph addMorph: argTile. selfTile := self tileForSelf bePossessive. selfTile position: m firstSubmorph position. m firstSubmorph addMorph: selfTile. m enforceTileColorPolicy. m replacePlayerInReadoutWith: scriptedPlayer. m openInHand! Item was changed: ----- Method: KedamaExamplerPlayer>>chooseSlotTypeFor: (in category 'player protocol') ----- chooseSlotTypeFor: aGetter "Let the user designate a type for the slot associated with the given getter" | typeChoices typeChosen slotName | + slotName := aGetter inherentSelector. - slotName := Utilities inherentSelectorForGetter: aGetter. typeChoices := Vocabulary typeChoices. typeChosen := UIManager default chooseFrom: (typeChoices collect: [:t | t translated])values: typeChoices title: ('Choose the TYPE for ' translated, slotName, ' (currently ' translated, (self slotInfoAt: slotName) type translated, ')'). typeChosen isEmptyOrNil ifTrue: [^ self]. (self typeForSlot: slotName) capitalized = typeChosen ifTrue: [^ self]. (self slotInfoAt: slotName) type: typeChosen. self class allInstancesDo: "allSubInstancesDo:" [:anInst | anInst instVarNamed: slotName asString put: (anInst valueOfType: typeChosen from: (anInst instVarNamed: slotName))]. turtles setVectorSlotTypeFor: slotName typeChosen: typeChosen. sequentialStub ifNotNil: [sequentialStub setScalarSlotTypeFor: slotName typeChosen: typeChosen]. self updateAllViewers. "does siblings too" ! Item was changed: ----- Method: KedamaMorph>>makePrototypeOfExampler:color: (in category 'turtles') ----- makePrototypeOfExampler: examplerPlayer color: cPixel | array inst info | array := examplerPlayer turtles. info := array info. array size > 0 ifTrue: [ inst := array makePrototypeFromFirstInstance. cPixel ifNotNil: [inst at: (info at: #color) put: cPixel]. ^ inst. ]. inst := Array new: array instSize. info associationsDo: [:assoc | + inst at: (assoc value) put: (examplerPlayer perform: assoc key asGetterSelector). - inst at: (assoc value) put: (examplerPlayer perform: (Utilities getterSelectorFor: assoc key)). ]. cPixel ifNotNil: [inst at: (info at: #color) put: cPixel] ifNil: [inst at: (info at: #color) put: ((examplerPlayer getColor pixelValueForDepth: 32) bitAnd: 16rFFFFFF)]. inst at: (info at: #visible) put: ((inst at: (info at: #visible)) ifTrue: [1] ifFalse: [0]). ^ inst. ! Item was changed: ----- Method: Morph>>noteNegotiatedName:for: (in category '*Etoys-support') ----- noteNegotiatedName: uniqueName for: requestedName "This works, kind of, for morphs that have a single variable. Still holding out for generality of morphs being able to have multiple variables, but need a driving example" self setProperty: #variableName toValue: uniqueName. + self setProperty: #setterSelector toValue: (uniqueName asSetterSelector). - self setProperty: #setterSelector toValue: (Utilities setterSelectorFor: uniqueName). self setNameTo: uniqueName! Item was changed: ----- Method: Morph>>traverseRowTranslateSlotOld:of:to: (in category '*Etoys') ----- traverseRowTranslateSlotOld: oldSlotName of: aPlayer to: newSlotName "Traverse my submorphs, translating submorphs appropriately given the slot rename" submorphs do: [:tile | (tile isKindOf: AssignmentTileMorph) ifTrue: [tile assignmentRoot = oldSlotName ifTrue: [(self isPlayer: aPlayer ofReferencingTile: tile) ifTrue: [tile setRoot: newSlotName]]]. (tile isMemberOf: TileMorph) ifTrue: + [(tile operatorOrExpression = oldSlotName asGetterSelector) ifTrue: - [(tile operatorOrExpression = (Utilities getterSelectorFor: oldSlotName)) ifTrue: [(self isPlayer: aPlayer ofReferencingTile: tile) ifTrue: + [tile setOperator: newSlotName asGetterSelector]]]. - [tile setOperator: (Utilities getterSelectorFor: newSlotName)]]]. tile traverseRowTranslateSlotOld: oldSlotName of: aPlayer to: newSlotName]! Item was changed: ----- Method: Morph>>traverseRowTranslateSlotOld:to: (in category '*Etoys') ----- traverseRowTranslateSlotOld: oldSlotName to: newSlotName "Traverse my submorphs, translating submorphs appropriately given the slot rename" submorphs do: [:tile | (tile isKindOf: AssignmentTileMorph) ifTrue: [tile assignmentRoot = oldSlotName ifTrue: [tile setRoot: newSlotName]]. (tile isMemberOf: TileMorph) ifTrue: + [(tile operatorOrExpression = oldSlotName asGetterSelector) ifTrue: + [tile setOperator: newSlotName asGetterSelector]]. - [(tile operatorOrExpression = (Utilities getterSelectorFor: oldSlotName)) ifTrue: - [tile setOperator: (Utilities getterSelectorFor: newSlotName)]]. tile traverseRowTranslateSlotOld: oldSlotName to: newSlotName]! Item was changed: ----- Method: Player class>>slotGettersOfType: (in category 'slots') ----- slotGettersOfType: aType "Answer a list of gettter selectors for slots of mine of the given type" | aList | aList := OrderedCollection new. self slotInfo associationsDo: [:assoc | (assoc value type = aType) ifTrue: + [aList add: assoc key asGetterSelector]]. - [aList add: (Utilities getterSelectorFor: assoc key)]]. ^ aList! Item was changed: ----- Method: Player>>addInstanceVariable (in category 'slots-user') ----- addInstanceVariable "Offer the user the opportunity to add an instance variable, and if he goes through with it, actually add it." | itsName initialValue typeChosen usedNames initialAnswer setterSelector originalString | usedNames := self class instVarNames. initialAnswer := Utilities keyLike: ('var' translated, (usedNames size + 1) asString) satisfying: [:aKey | (usedNames includes: aKey) not]. originalString := UIManager default request: 'name for new variable: ' translated initialAnswer: initialAnswer. originalString isEmptyOrNil ifTrue: [^ self]. itsName := ScriptingSystem acceptableSlotNameFrom: originalString forSlotCurrentlyNamed: nil asSlotNameIn: self world: self costume world. itsName size = 0 ifTrue: [^ self]. self assureUniClass. typeChosen := self initialTypeForSlotNamed: itsName. self slotInfo at: itsName put: (SlotInformation new initialize type: typeChosen). initialValue := self initialValueForSlotOfType: typeChosen. self addInstanceVarNamed: itsName withValue: initialValue. self compileInstVarAccessorsFor: itsName. + setterSelector := itsName asSetterSelector. - setterSelector := Utilities setterSelectorFor: itsName. ((self class allSubInstances copyWithout: self) reject: [:e | e isSequentialStub]) do: [:anInstance | anInstance perform: setterSelector with: initialValue]. self updateAllViewersAndForceToShow: ScriptingSystem nameForInstanceVariablesCategory! Item was changed: ----- Method: Player>>addInstanceVariable2Named:type:value: (in category 'slots-user') ----- addInstanceVariable2Named: nameSymbol type: typeChosen value: aValue "Add an instance variable of the given name and type, and initialize it to have the given value" | initialValue setterSelector | self assureUniClass. self slotInfo at: nameSymbol put: (SlotInformation new initialize type: typeChosen). initialValue := aValue. self addInstanceVarNamed: nameSymbol withValue: aValue. self class compileAccessorsFor: nameSymbol. + setterSelector := nameSymbol asSetterSelector. - setterSelector := Utilities setterSelectorFor: nameSymbol. (self class allSubInstances copyWithout: self) do: [:anInstance | anInstance perform: setterSelector with: initialValue]. self updateAllViewersAndForceToShow: #'instance variables' ! Item was changed: ----- Method: Player>>addInstanceVariableNamed:type:value: (in category 'slots-user') ----- addInstanceVariableNamed: nameSymbol type: typeChosen value: aValue "Add an instance variable of the given name and type, and initialize it to have the given value" | initialValue setterSelector | self assureUniClass. self slotInfo at: nameSymbol put: (SlotInformation new type: typeChosen). initialValue := self initialValueForSlotOfType: typeChosen. self addInstanceVarNamed: nameSymbol withValue: aValue. self class compileAccessorsFor: nameSymbol. + setterSelector := nameSymbol asSetterSelector. - setterSelector := Utilities setterSelectorFor: nameSymbol. (self class allSubInstances copyWithout: self) do: [:anInstance | anInstance perform: setterSelector with: initialValue]. self updateAllViewersAndForceToShow: ScriptingSystem nameForInstanceVariablesCategory ! Item was changed: ----- Method: Player>>basicRemoveSlotNamed: (in category 'slots-user') ----- basicRemoveSlotNamed: aSlotName "The user has requested that an instance variable be removed..." | aSetter aGetter | (self okayToRemoveSlotNamed: aSlotName) ifFalse: [^ self inform: 'Sorry, ', aSlotName, ' is in use in a script.']. + aSetter := aSlotName asSetterSelector. + aGetter := aSlotName asGetterSelector. - aSetter := Utilities setterSelectorFor: aSlotName. - aGetter := Utilities getterSelectorFor: aSlotName. ((self systemNavigation allCallsOn: aSetter) size > 0 or: [(self systemNavigation allCallsOn: aGetter) size > 0]) ifTrue: [self inform: 'Caution!! There may be scripts belonging to other objects that may rely on the presence of this variable. If there are, they may now be broken. You may need to fix them up manually.']. self class removeInstVarName: aSlotName asString. self updateAllViewers! Item was changed: ----- Method: Player>>changeTypesInWatchersOf: (in category 'translation') ----- changeTypesInWatchersOf: slotName "The type of a variable has changed; adjust watchers to that fact." | aGetter | + aGetter := slotName asGetterSelector. - aGetter := Utilities getterSelectorFor: slotName. self allPossibleWatchersFromWorld do: [:aWatcher | | newWatcher | (aWatcher getSelector = aGetter) ifTrue: [(aWatcher ownerThatIsA: WatcherWrapper) ifNotNil: [:aWrapper | newWatcher := (aWrapper submorphs size = 1) ifTrue: [WatcherWrapper new unlabeledForPlayer: self getter: aGetter] ifFalse: [WatcherWrapper new fancyForPlayer: self getter: aGetter]. newWatcher position: aWatcher position. aWrapper owner replaceSubmorph: aWrapper by: newWatcher]]] ! Item was changed: ----- Method: Player>>chooseSlotTypeFor: (in category 'slots-user') ----- chooseSlotTypeFor: aGetter "Let the user designate a type for the slot associated with the given getter" | typeChoices typeChosen slotName | + slotName := aGetter inherentSelector. - slotName := Utilities inherentSelectorForGetter: aGetter. typeChoices := Vocabulary typeChoices. typeChosen := UIManager default chooseFrom: (typeChoices collect: [:t | t translated]) values: typeChoices title: ('Choose the TYPE for ' translated, slotName, ' (currently ' translated, (self slotInfoAt: slotName) type translated, ')'). typeChosen isEmptyOrNil ifTrue: [^ self]. (self typeForSlot: slotName) capitalized = typeChosen ifTrue: [^ self]. (self slotInfoAt: slotName) type: typeChosen. self class allInstancesDo: "allSubInstancesDo:" [:anInst | anInst instVarNamed: slotName asString put: (anInst valueOfType: typeChosen from: (anInst instVarNamed: slotName))]. self updateAllViewers. "does siblings too" self changeTypesInWatchersOf: slotName "does siblings too" ! Item was changed: ----- Method: Player>>defaultFloatPrecisionFor: (in category 'misc') ----- defaultFloatPrecisionFor: aGetSelector "Answer the float position to use in conjunction with a readout for aGetSelector, which will be of the form 'getXXX'" | aSlotName slotInfo | + aSlotName := aGetSelector inherentSelector. - aSlotName := Utilities inherentSelectorForGetter: aGetSelector. (slotInfo := self slotInfoAt: aSlotName ifAbsent: [nil]) ifNotNil: [^ slotInfo floatPrecision]. self costume ifNotNil: [^ self costume renderedMorph defaultFloatPrecisionFor: aGetSelector]. ^ 1! Item was changed: ----- Method: Player>>elementTypeFor:vocabulary: (in category 'viewer') ----- elementTypeFor: aStringOrSymbol vocabulary: aVocabulary "Answer whether aStringOrSymbol is best characterized as a #systemSlot, #systemScript, #userSlot, or #userScript. This is ancient and odious but too tedious to rip out at this point." | aSymbol anInterface aSlotName | aSymbol := aStringOrSymbol asSymbol. + aSlotName := aSymbol inherentSelector. - aSlotName := Utilities inherentSelectorForGetter: aSymbol. (self slotInfo includesKey: aSlotName) ifTrue: [^ #userSlot]. (self class isUniClass and: [self class scripts includesKey: aSymbol]) ifTrue: [^ #userScript]. anInterface := aVocabulary methodInterfaceAt: aSymbol ifAbsent: [nil]. ^ anInterface ifNotNil: [(anInterface resultType == #unknown) ifTrue: [#systemScript] ifFalse: [#systemSlot]] ifNil: [#systemScript]! Item was changed: ----- Method: Player>>fancyWatcherFor: (in category 'slots-user') ----- fancyWatcherFor: aGetter "Anser a labeled readout for viewing a value textuallyi" | aWatcher aColor aLine itsName aSelector aLabel | aWatcher := self unlabeledWatcherFor: aGetter. aColor := Color r: 0.387 g: 0.581 b: 1.0. aLine := WatcherWrapper newRow. + aLine player: self variableName: (aSelector := aGetter inherentSelector). - aLine player: self variableName: (aSelector := Utilities inherentSelectorForGetter: aGetter). itsName := aWatcher externalName. aWatcher setNameTo: 'readout'. aLine addMorphFront: (self tileReferringToSelf borderWidth: 0; layoutInset: 4@0; typeColor: aColor; color: aColor; bePossessive). aLabel := StringMorph contents: aSelector translated, ' = ' font: ScriptingSystem fontForTiles. aLabel setProperty: #watcherLabel toValue: true. aLine addMorphBack: aLabel. aLine addMorphBack: aWatcher. aLine setNameTo: itsName. ^ aLine! Item was changed: ----- Method: Player>>methodInterfacesForInstanceVariablesCategoryIn: (in category 'slots-kernel') ----- methodInterfacesForInstanceVariablesCategoryIn: aVocabulary "Return a collection of methodInterfaces for the instance-variables category. The vocabulary parameter, at present anyway, is not used." | aList | aList := OrderedCollection new. self slotInfo associationsDo: [:assoc | | itsSlotName anInterface | anInterface := MethodInterface new. itsSlotName := assoc key. anInterface wording: itsSlotName; helpMessage: 'a variable defined by this object' translated. + anInterface selector: (itsSlotName asGetterSelector) type: assoc value type setter: (itsSlotName asSetterSelector). - anInterface selector: (Utilities getterSelectorFor: itsSlotName) type: assoc value type setter: (Utilities setterSelectorFor: itsSlotName). anInterface setToRefetch. aList add: anInterface]. ^ aList! Item was changed: ----- Method: Player>>offerGetterTiles: (in category 'slots-user') ----- offerGetterTiles: slotName "For a player-type slot, offer to build convenient compound tiles that otherwise would be hard to get" | typeChoices typeChosen thePlayerThereNow slotChoices slotChosen getterTiles aCategoryViewer playerGetter | typeChoices := Vocabulary typeChoices. typeChosen := UIManager default chooseFrom: (typeChoices collect: [:t | t translated]) values: typeChoices title: ('Choose the TYPE of data to get from {1}''s {2}' translated format: {self externalName. slotName translated}). typeChosen isEmptyOrNil ifTrue: [^self]. + thePlayerThereNow := self perform: slotName asGetterSelector. - thePlayerThereNow := self perform: (Utilities getterSelectorFor: slotName). thePlayerThereNow ifNil: [thePlayerThereNow := self presenter standardPlayer]. slotChoices := thePlayerThereNow slotNamesOfType: typeChosen. slotChoices isEmpty ifTrue: [^self inform: 'sorry -- no slots of that type' translated]. slotChoices := slotChoices asSortedArray. slotChosen := UIManager default chooseFrom: (slotChoices collect: [:t | t translated]) values: slotChoices title: ('Choose the datum you want to extract from {1}''s {2}' translated format: {self externalName. slotName translated}). slotChosen isEmptyOrNil ifTrue: [^self]. "Now we want to tear off tiles of the form holder's valueAtCursor's foo" getterTiles := nil. aCategoryViewer := CategoryViewer new initializeFor: thePlayerThereNow categoryChoice: 'basic'. getterTiles := aCategoryViewer + getterTilesFor: slotChosen asGetterSelector - getterTilesFor: (Utilities getterSelectorFor: slotChosen) type: typeChosen. aCategoryViewer := CategoryViewer new initializeFor: self categoryChoice: 'basic'. playerGetter := aCategoryViewer + getterTilesFor: slotName asGetterSelector - getterTilesFor: (Utilities getterSelectorFor: slotName) type: #Player. getterTiles submorphs first acceptDroppingMorph: playerGetter event: nil. "the pad" "simulate a drop" getterTiles makeAllTilesGreen. getterTiles justGrabbedFromViewer: false. (getterTiles firstSubmorph) changeTableLayout; hResizing: #shrinkWrap; vResizing: #spaceFill. ActiveHand attachMorph: getterTiles! Item was changed: ----- Method: Player>>removeSlotNamed: (in category 'slots-user') ----- removeSlotNamed: aSlotName "The user has requested that an instance variable be removed..." | aSetter aGetter | (self okayToRemoveSlotNamed: aSlotName) ifFalse: [^ self inform: ('Sorry, {1} is in use in a script.' translated format: {aSlotName})]. + aSetter := aSlotName asSetterSelector. + aGetter := aSlotName asGetterSelector. - aSetter := Utilities setterSelectorFor: aSlotName. - aGetter := Utilities getterSelectorFor: aSlotName. ((self systemNavigation allCallsOn: aSetter) size > 0 or: [(self systemNavigation allCallsOn: aGetter) size > 0]) ifTrue: [self inform: 'Caution!! There may be scripts belonging to other objects that may rely on the presence of this variable. If there are, they may now be broken. You may need to fix them up manually.' translated]. self class removeInstVarName: aSlotName asString. self updateAllViewers! Item was changed: ----- Method: Player>>renameSlotInWatchersOld:new: (in category 'translation') ----- renameSlotInWatchersOld: oldName new: newName "A variable has been renamed; get all relevant extant watchers updated. All this assumed to be happening in the ActiveWorld" | oldGetter | + oldGetter := oldName asGetterSelector. - oldGetter := Utilities getterSelectorFor: oldName. self allPossibleWatchersFromWorld do: [:aWatcher | | wasStepping | (aWatcher getSelector = oldGetter) ifTrue: [(wasStepping := aWatcher isStepping) ifTrue: [aWatcher stopStepping]. + aWatcher getSelector: newName asGetterSelector. - aWatcher getSelector: (Utilities getterSelectorFor: newName). aWatcher putSelector ifNotNil: + [aWatcher putSelector: (newName asSetterSelector)]. - [aWatcher putSelector: (Utilities setterSelectorFor: newName)]. ((aWatcher isKindOf: UpdatingStringMorph) and: [aWatcher hasStructureOfComplexWatcher]) ifTrue: "Old style fancy watcher" [aWatcher owner owner traverseRowTranslateSlotOld: oldName to: newName. (aWatcher target labelFromWatcher: aWatcher) contents: newName, ' = ']. (aWatcher ownerThatIsA: WatcherWrapper) ifNotNil: [:wrapper | wrapper player: self variableName: newName]. wasStepping ifTrue: [aWatcher startStepping]]]! Item was changed: ----- Method: Player>>revealPlayerNamed:in: (in category 'misc') ----- revealPlayerNamed: aSymbol in: aWorld | getter | + getter := aSymbol asGetterSelector. - getter := Utilities getterSelectorFor: aSymbol. ^ (self perform: getter) revealPlayerIn: aWorld! Item was changed: ----- Method: Player>>setPrecisionFor: (in category 'slots-user') ----- setPrecisionFor: slotName "Set the precision for the given slot name" | aList reply aGetter places | + aGetter := slotName asGetterSelector. - aGetter := Utilities getterSelectorFor: slotName. places := Utilities decimalPlacesForFloatPrecision: (self defaultFloatPrecisionFor: aGetter). aList := #('0' '1' '2' '3' '4' '5' '6'). reply := UIManager default chooseFrom: aList values: (aList collect: [:m | m asNumber]) title: ('How many decimal places? (currently {1})' translated format: {places}). reply ifNotNil: [(self slotInfo includesKey: slotName) ifTrue: ["it's a user slot" (self slotInfoAt: slotName) floatPrecision: (Utilities floatPrecisionForDecimalPlaces: reply). self class allInstancesDo: [:anInst | | val | reply = 0 ifFalse: [((val := anInst instVarNamed: slotName asString) isInteger) ifTrue: [anInst instVarNamed: slotName asString put: val asFloat]]. anInst updateAllViewers]] ifFalse: ["it's specifying a preference for precision on a system-defined numeric slot" self noteDecimalPlaces: reply forGetter: aGetter. self updateAllViewers]]! Item was changed: ----- Method: Player>>slotInfoButtonHitFor:inViewer: (in category 'scripts-kernel') ----- slotInfoButtonHitFor: aGetterSymbol inViewer: aViewer "The user made a gesture asking for slot menu for the given getter symbol in a viewer; put up the menu." | aMenu slotSym aType typeVocab interface selector | (#(+ - * /) includes: aGetterSymbol) ifTrue: [^ self inform: aGetterSymbol, ' is used for vector operations']. + slotSym := aGetterSymbol inherentSelector. - slotSym := Utilities inherentSelectorForGetter: aGetterSymbol. aType := self typeForSlotWithGetter: aGetterSymbol asSymbol. aMenu := MenuMorph new defaultTarget: self. interface := aViewer currentVocabulary methodInterfaceAt: aGetterSymbol ifAbsent: [nil]. selector := interface isNil ifTrue: [slotSym asString] ifFalse: [interface selector]. aMenu addTitle: (selector, ' (', (aType asString translated), ')'). aType = #Patch ifTrue: [ aMenu add: 'grab morph' translated target: (self perform: aGetterSymbol) selector: #grabPatchMorph argument: #(). aMenu addLine. ]. (typeVocab := Vocabulary vocabularyForType: aType) addWatcherItemsToMenu: aMenu forGetter: aGetterSymbol. (self slotInfo includesKey: slotSym) ifTrue: [aMenu add: 'change value type' translated selector: #chooseSlotTypeFor: argument: aGetterSymbol. typeVocab addUserSlotItemsTo: aMenu slotSymbol: slotSym. aMenu add: ('remove "{1}"' translated format: {slotSym}) selector: #removeSlotNamed: argument: slotSym. aMenu add: ('rename "{1}"' translated format: {slotSym}) selector: #renameSlot: argument: slotSym. aMenu addLine]. typeVocab addExtraItemsToMenu: aMenu forSlotSymbol: slotSym. "e.g. Player type adds hand-me-tiles" aMenu add: 'show categories....' translated target: aViewer selector: #showCategoriesFor: argument: aGetterSymbol. self addIdiosyncraticMenuItemsTo: aMenu forSlotSymol: slotSym. aMenu items isEmpty ifTrue: [aMenu add: 'ok' translated action: #yourself]. aMenu popUpForHand: aViewer primaryHand in: aViewer world! Item was changed: ----- Method: Player>>slotInfoForGetter: (in category 'slots-user') ----- slotInfoForGetter: aGetter "Answer a SlotInformation object which describes an instance variable of mine retrieved via the given getter, or nil if none" + ^ self slotInfo at: aGetter inherentSelector ifAbsent: [nil]! - ^ self slotInfo at: (Utilities inherentSelectorForGetter: aGetter) ifAbsent: [nil]! Item was changed: ----- Method: Player>>slotNamesOfType: (in category 'slots-user') ----- slotNamesOfType: aType "Answer a list of potential slot names of the given type in the receiver" | fullList forViewer gettersToOffer | fullList := (ScriptingSystem systemSlotNamesOfType: aType), (self class slotGettersOfType: aType). forViewer := costume renderedMorph selectorsForViewer select: [:aSel | aSel beginsWith: 'get']. gettersToOffer := fullList select: [:anItem | forViewer includes: anItem]. ^ gettersToOffer collect: + [:aSel | aSel inherentSelector]! - [:aSel | Utilities inherentSelectorForGetter: aSel]! Item was changed: ----- Method: Player>>tearOffWatcherFor: (in category 'slots-user') ----- tearOffWatcherFor: aSlotGetter "Tear off a simple textual watcher for the slot whose getter is provided" | aWatcher anInterface info isNumeric | info := self slotInfoForGetter: aSlotGetter. info ifNotNil: [isNumeric := info type == #Number] ifNil: [anInterface := Vocabulary eToyVocabulary methodInterfaceAt: aSlotGetter ifAbsent: [nil]. isNumeric := anInterface notNil and: [anInterface resultType == #Number]]. aWatcher := UpdatingStringMorph new. aWatcher growable: true; getSelector: aSlotGetter; putSelector: (info notNil ifTrue: [ScriptingSystem setterSelectorForGetter: aSlotGetter] ifFalse: [anInterface companionSetterSelector]); setNameTo: (info notNil ifTrue: + [aSlotGetter inherentSelector] - [Utilities inherentSelectorForGetter: aSlotGetter] ifFalse: [anInterface wording]); target: self. isNumeric ifFalse: [aWatcher useStringFormat] ifTrue: [self setFloatPrecisionFor: aWatcher]. aWatcher step; fitContents; openInHand! Item was changed: ----- Method: Player>>typeForSlot: (in category 'slots-kernel') ----- typeForSlot: aSlotName "Answer the data type for values of the instance variable of the given name" | getter | (self slotInfo includesKey: aSlotName) ifTrue: [^ (self slotInfoAt: aSlotName) type]. getter := (aSlotName beginsWith: 'get') ifTrue: [aSlotName] ifFalse: + [aSlotName asGetterSelector]. - [Utilities getterSelectorFor: aSlotName]. ^ (self currentVocabulary methodInterfaceAt: getter ifAbsent: [self error: 'Unknown slot name: ', aSlotName]) resultType! Item was changed: ----- Method: Player>>typeForSlot:vocabulary: (in category 'slots-kernel') ----- typeForSlot: aSlotName vocabulary: aVocabulary "Answer the data type for values of the instance variable of the given name. Presently has no senders but retained for a while..." | getter inherentSelector | + inherentSelector := aSlotName inherentSelector. - inherentSelector := Utilities inherentSelectorForGetter: aSlotName. (self slotInfo includesKey: inherentSelector) ifTrue: [^ (self slotInfoAt: inherentSelector) type]. getter := (aSlotName beginsWith: 'get') ifTrue: [aSlotName] ifFalse: + [aSlotName asGetterSelector]. - [Utilities getterSelectorFor: aSlotName]. ^ (aVocabulary methodInterfaceAt: getter ifAbsent: [self error: 'Unknown slot name: ', aSlotName]) resultType! Item was changed: ----- Method: Player>>typeForSlotWithGetter: (in category 'slots-kernel') ----- typeForSlotWithGetter: aGetter "Answer the data type for values of the instance variable of the given name" | getter inherentSelector | (#(color:sees: seesColor: touchesA: overlaps: overlapsAny:) includes: aGetter) ifTrue: [^ #Boolean]. (#(+ * - /) includes: aGetter) ifTrue: [^ #Player]. "weird vector stuff" "Annoying special cases" + inherentSelector := aGetter inherentSelector. - inherentSelector := Utilities inherentSelectorForGetter: aGetter. (self slotInfo includesKey: inherentSelector) ifTrue: [^ (self slotInfoAt: inherentSelector) type]. getter := (aGetter beginsWith: 'get') ifTrue: [aGetter] ifFalse: + [aGetter asGetterSelector]. - [Utilities getterSelectorFor: aGetter]. ^ (Vocabulary eToyVocabulary methodInterfaceAt: getter ifAbsent: [self error: 'Unknown slot name: ', aGetter]) resultType! Item was changed: ----- Method: Player>>unlabeledWatcherFor: (in category 'slots-user') ----- unlabeledWatcherFor: aGetter "Answer an unnlabeled readout for viewing a numeric-valued slot of mine" | aWatcher info anInterface watcherWording itsType vocab aSetter | info := self slotInfoForGetter: aGetter. info ifNotNil: [itsType := info type. + watcherWording := aGetter inherentSelector. + aSetter := watcherWording asSetterSelector] - watcherWording := Utilities inherentSelectorForGetter: aGetter. - aSetter := Utilities setterSelectorFor: watcherWording] ifNil: [anInterface :=Vocabulary eToyVocabulary methodInterfaceAt: aGetter ifAbsent: [nil]. anInterface ifNotNil: [itsType := anInterface resultType. aSetter := anInterface companionSetterSelector] ifNil: [itsType := #Unknown. aSetter := nil]. watcherWording := anInterface ifNotNil: [anInterface wording] ifNil: ['*']]. vocab := Vocabulary vocabularyForType: itsType. aWatcher := vocab updatingTileForTarget: self partName: watcherWording getter: aGetter setter: aSetter. aWatcher setNameTo: (self externalName, '''s ', watcherWording). aWatcher minHeight: (vocab wantsArrowsOnTiles ifTrue: [22] ifFalse: [14]). ^ aWatcher! Item was changed: ----- Method: ScriptEditorMorph>>hasScriptReferencing:ofPlayer: (in category 'other') ----- hasScriptReferencing: aSlotName ofPlayer: aPlayer "Answer whether the receiver has any tiles in it which reference the given slot of the given player. By doing a text search on the decompiled method, this is able to work both with text and with tiles. The approach is still not perfect, because we can't really know until run-time whom the getters and setters are sent to. But practically speaking, this is all presumably a positive." | stringToSearch | "(aPlayer isKindOf: playerScripted class) ifFalse: [^ false]." stringToSearch := (playerScripted class compiledMethodAt: scriptName) decompileString. + {aSlotName asGetterSelector. aSlotName asSetterSelector} do: - {Utilities getterSelectorFor: aSlotName. Utilities setterSelectorFor: aSlotName} do: [:searchee | (stringToSearch findString: searchee startingAt: 1) = 0 ifFalse: [^ true]]. ^ false! Item was added: + ----- Method: String>>asGetterSelector (in category '*Etoys-support') ----- + asGetterSelector + "Answer the corresponding getter. Two idiosyncratic vectorings herein... " + | aSymbol | + (aSymbol := self asSymbol) == #isOverColor: ifTrue: [^ #seesColor:]. + aSymbol == #copy ifTrue: [^ #getNewClone]. + + ^ ('get', (self asString capitalized)) asSymbol! Item was added: + ----- Method: String>>asSetterSelector (in category '*Etoys-support') ----- + asSetterSelector + ^ (('set', (self asString capitalized)), ':') asSymbol! Item was added: + ----- Method: String>>inherentSelector (in category '*Etoys-support') ----- + inherentSelector + "Given a selector of the form #getAbc, return the inherent slotname selector that corresponds, which is to say, getterSelector with the leading 'get' removed and with the next character forced to lower case; this is the inverse of #getterSelectorFor:" + + "Utilities inherentSelectorForGetter: #getWidth" + ((self size < 4) or: [(self beginsWith: 'get') not]) + ifTrue: [ ^ self]. + ^ ((self at: 4) asLowercase asString, (self copyFrom: 5 to: self size)) asSymbol! Item was changed: ----- Method: SyntaxMorph>>setTarget: (in category 'card & stack') ----- setTarget: aPlayer "Find my UpdatingStringMorph and set its getSelector, putSelector, and target" | updatingString | (updatingString := self readOut) ifNil: [^ self]. + updatingString putSelector: (self knownName asSetterSelector). + updatingString getSelector: (self knownName asGetterSelector). - updatingString putSelector: (Utilities setterSelectorFor: self knownName). - updatingString getSelector: (Utilities getterSelectorFor: self knownName). updatingString target: aPlayer. ! Item was changed: ----- Method: TilePadMorph>>morphToDropFrom: (in category 'miscellaneous') ----- morphToDropFrom: aMorph "Given a morph being carried by the hand, which the hand is about to drop, answer the actual morph to be deposited. Normally this would be just the morph itself, but several unusual cases arise, which this method is designed to service." | vwr | (aMorph isKindOf: WatcherWrapper) ifTrue: [^ aMorph getterTilesForDrop]. ^ ((self type capitalized = #Graphic) "Special-case requested by Alan 4/30/05" and: [(aMorph isKindOf: TileMorph) and: [aMorph resultType = #Player]]) ifFalse: [aMorph] ifTrue: [vwr := CategoryViewer new initializeFor: aMorph associatedPlayer categoryChoice: #basic. + vwr getterTilesFor: #graphic asGetterSelector type: #Graphic]! - vwr getterTilesFor: (Utilities getterSelectorFor: #graphic) type: #Graphic]! Item was removed: - ----- Method: Utilities class>>getterSelectorFor: (in category '*Etoys') ----- - getterSelectorFor: identifier - "Answer the corresponding getter. Two idiosyncratic vectorings herein... " - - "Utilities getterSelectorFor: #elvis" - - | aSymbol | - (aSymbol := identifier asSymbol) == #isOverColor: ifTrue: [^ #seesColor:]. - aSymbol == #copy ifTrue: [^ #getNewClone]. - - ^ ('get', (identifier asString capitalized)) asSymbol! Item was changed: ----- Method: VariableDock>>computePlayerGetterAndSetterSelectors (in category 'getters and setters') ----- computePlayerGetterAndSetterSelectors "Compute and remember the getter and setter selectors for obtaining and setting values from the player instance" + playerGetSelector := variableName asGetterSelector. + playerPutSelector := variableName asSetterSelector.! - playerGetSelector := Utilities getterSelectorFor: variableName. - playerPutSelector := Utilities setterSelectorFor: variableName! Item was changed: ----- Method: Vocabulary>>tileWordingForSelector: (in category '*Etoys-queries') ----- tileWordingForSelector: aSelector "Answer the wording to emblazon on tiles representing aSelector" | anInterface | anInterface := self methodInterfaceAt: aSelector asSymbol ifAbsent: [ | inherent | + inherent := aSelector inherentSelector. - inherent := Utilities inherentSelectorForGetter: aSelector. ^ inherent ifNil: [self translatedWordingFor: aSelector] ifNotNil: [inherent translated]]. ^ anInterface wording! Item was changed: ----- Method: WatcherWrapper>>buildForPlayer:getter: (in category 'initialization') ----- buildForPlayer: aPlayer getter: aGetter "Build up basic structure" | aColor | self player: aPlayer + variableName: aGetter inherentSelector. - variableName: (Utilities inherentSelectorForGetter: aGetter). aColor := Color r: 0.387 g: 0.581 b: 1.0. self listDirection: #leftToRight; hResizing: #shrinkWrap; vResizing: #shrinkWrap; color: aColor; layoutInset: -1; borderWidth: 1; borderColor: aColor darker; listCentering: #center. self addMorphBack: (self buildReadout: aGetter)! Item was changed: ----- Method: WatcherWrapper>>getterTilesForDrop (in category 'accessing') ----- getterTilesForDrop "Answer getter tiles to use if there is an attempt to drop me onto a tile pad" | aCategoryViewer | aCategoryViewer := CategoryViewer new initializeFor: player categoryChoice: #basic. + ^ aCategoryViewer getterTilesFor: variableName asGetterSelector type: self resultType! - ^ aCategoryViewer getterTilesFor: (Utilities getterSelectorFor: variableName) type: self resultType! Item was changed: ----- Method: WatcherWrapper>>readoutInformation: (in category 'initialization') ----- readoutInformation: aGetter "Answer a triplet of {type. wording. setter}" | info anInterface | info := player slotInfoForGetter: aGetter. "In case of a variable" info + ifNotNil: [^ {info type. aGetter inherentSelector. variableName asSetterSelector}]. - ifNotNil: [^ {info type. Utilities inherentSelectorForGetter: aGetter. Utilities setterSelectorFor: variableName}]. "In case of a slot" anInterface := Vocabulary eToyVocabulary methodInterfaceAt: aGetter ifAbsent: [^ {#Unknown. '*'. nil}]. ^ {anInterface resultType. anInterface wording. anInterface companionSetterSelector}! Item was changed: ----- Method: WatcherWrapper>>resultType (in category 'accessing') ----- resultType "Answer the result type the receiver would produce." + ^ player typeForSlotWithGetter: variableName asGetterSelector! - ^ player typeForSlotWithGetter: (Utilities getterSelectorFor: variableName)!

1 0

The Trunk: EToys-fbs.114.mcz
by commits＠source.squeak.org 30 Nov '13

30 Nov '13

1 0

The Trunk: EToys-fbs.114.mcz
by commits＠source.squeak.org 30 Nov '13

30 Nov '13

1 0

The Trunk: System-fbs.630.mcz
by commits＠source.squeak.org 30 Nov '13

30 Nov '13

Frank Shearar uploaded a new version of System to project The Trunk: http://source.squeak.org/trunk/System-fbs.630.mcz ==================== Summary ==================== Name: System-fbs.630 Author: fbs Time: 30 November 2013, 10:49:21.908 am UUID: 5fa34d4d-7243-9340-a9a7-e09496d63da5 Ancestors: System-fbs.629 Deprecate eToys' selector mangling utilities - they've been moved to Etoys, on String and Symbol. =============== Diff against System-fbs.629 =============== Item was removed: - ----- Method: Utilities class>>inherentSelectorForGetter: (in category 'miscellaneous') ----- - inherentSelectorForGetter: aGetterSelector - "Given a selector of the form #getAbc, return the inherent slotname selector that corresponds, which is to say, getterSelector with the leading 'get' removed and with the next character forced to lower case; this is the inverse of #getterSelectorFor:" - - "Utilities inherentSelectorForGetter: #getWidth" - ((aGetterSelector size < 4) or: [(aGetterSelector beginsWith: 'get') not]) - ifTrue: [ ^ aGetterSelector]. - ^ ((aGetterSelector at: 4) asLowercase asString, (aGetterSelector copyFrom: 5 to: aGetterSelector size)) asSymbol! Item was removed: - ----- Method: Utilities class>>setterSelectorFor: (in category 'miscellaneous') ----- - setterSelectorFor: aName - "Utilities setterSelectorFor: #elvis" - ^ (('set', (aName asString capitalized)), ':') asSymbol! Item was removed: - ----- Method: Utilities class>>simpleSetterFor: (in category 'miscellaneous') ----- - simpleSetterFor: aSymbol - "Utilities simpleSetterFor: #right" - ^ (aSymbol, ':') asSymbol!

1 0

The Trunk: System-fbs.630.mcz
by commits＠source.squeak.org 30 Nov '13

30 Nov '13

1 0

Jump to page:

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

Packages November 2013