[squeak-dev] The Inbox: Mirrors-cwp.2.mcz

commits at source.squeak.org commits at source.squeak.org
Tue May 22 06:25:38 UTC 2012


A new version of Mirrors was added to project The Inbox:
http://source.squeak.org/inbox/Mirrors-cwp.2.mcz

==================== Summary ====================

Name: Mirrors-cwp.2
Author: cwp
Time: 15 May 2012, 6:50:25.515 pm
UUID: 48ba5f51-623b-4e6f-9b64-47c2c3e43258
Ancestors: Mirrors-cwp.1

Implemented a simple non-invasive inspector.

==================== Snapshot ====================

SystemOrganization addCategory: #'Mirrors-Tests'!
SystemOrganization addCategory: #'Mirrors-Object'!
SystemOrganization addCategory: #'Mirrors-Utilities'!

nil subclass: #MessageShunt
	instanceVariableNames: 'handler'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Mirrors-Utilities'!

----- Method: MessageShunt class>>handler: (in category 'as yet unclassified') -----
handler: aBlock
	| inst |
	inst := self basicNew.
	CompiledMethod 
		receiver: inst 
		withArguments: {1. aBlock} 
		executeMethod: (Reflection compiledMethodAt: #fixedAt:put:).
	^ inst!

----- Method: MessageShunt class>>initialize (in category 'as yet unclassified') -----
initialize
	self superclass: nil!

----- Method: MessageShunt>>doesNotUnderstand: (in category 'as yet unclassified') -----
doesNotUnderstand: aMessage
	handler value: aMessage!

TestCase subclass: #FixedSlotMirrorTest
	instanceVariableNames: 'mirror four'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Mirrors-Tests'!

----- Method: FixedSlotMirrorTest>>instVarAt: (in category 'shunts') -----
instVarAt: anIndex
	"We don't want the slot mirror sending #instVarAt:, so if it does, fail the test"
	
	self assert: false!

----- Method: FixedSlotMirrorTest>>instVarAt:put: (in category 'shunts') -----
instVarAt: anIndex put: anObject
	"We don't want mirrors sending #instVarAt:put:, so if it does, fail the test"
	
	self assert: false!

----- Method: FixedSlotMirrorTest>>setUp (in category 'running') -----
setUp
	mirror := FixedSlotMirror on: self index: 4.
	!

----- Method: FixedSlotMirrorTest>>testName (in category 'tests') -----
testName
	self assert: mirror name = 'four'!

----- Method: FixedSlotMirrorTest>>testRead (in category 'tests') -----
testRead
	four := Object new.
	self assert: mirror value == four!

----- Method: FixedSlotMirrorTest>>testWrite (in category 'tests') -----
testWrite
	| value |
	value := Object new.
	mirror value: value.
	self assert: four == value!

TestCase subclass: #ObjectMirrorTest1
	instanceVariableNames: 'mirror four'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Mirrors-Tests'!

----- Method: ObjectMirrorTest1>>setFour (in category 'support') -----
setFour
	four := #four!

----- Method: ObjectMirrorTest1>>setUp (in category 'running') -----
setUp
	mirror := ObjectMirror on: self!

----- Method: ObjectMirrorTest1>>tearDown (in category 'running') -----
tearDown
	mirror := nil.
	four := nil.!

----- Method: ObjectMirrorTest1>>testPerformWithNoArguments (in category 'tests') -----
testPerformWithNoArguments
	mirror perform: #setFour arguments: #().
	self assert: four = #four!

----- Method: ObjectMirrorTest1>>testReflects (in category 'tests') -----
testReflects
	self assert: (mirror reflects: self)!

----- Method: ObjectMirrorTest1>>testSize (in category 'tests') -----
testSize
	| expected actual |
	expected := 4.
	actual := mirror size.
	self assert: actual = expected!

----- Method: ObjectMirrorTest1>>testSlotAt (in category 'tests') -----
testSlotAt
	| slot |
	slot := mirror slotAt: 1.
	self assert: slot value = #testSlotAt!

----- Method: ObjectMirrorTest1>>testSlotAtIfAbsent (in category 'tests') -----
testSlotAtIfAbsent
	| marker actual |
	marker := Object new.
	actual := mirror slotAt: 1 ifAbsent: [marker].
	self deny: actual == marker!

----- Method: ObjectMirrorTest1>>testSlotAtIfAbsentIfPresent (in category 'tests') -----
testSlotAtIfAbsentIfPresent
	
	| answer slot |
	answer := mirror slotAt: 1 
		ifPresent: [:val | slot := val. #present]
		ifAbsent: [#absent].
	self assert: slot value == #testSlotAtIfAbsentIfPresent.
	self assert: answer == #present!

----- Method: ObjectMirrorTest1>>testSlotAtIfAbsentIfPresentNot (in category 'tests') -----
testSlotAtIfAbsentIfPresentNot
	
	| answer value |
	answer := mirror slotAt: 10 
		ifPresent: [:val | value := val. #present]
		ifAbsent: [#absent].
	self assert: value isNil.
	self assert: answer == #absent!

----- Method: ObjectMirrorTest1>>testSlotAtIfAbsentNot (in category 'tests') -----
testSlotAtIfAbsentNot
	| marker actual |
	marker := Object new.
	actual := mirror slotAt: 10 ifAbsent: [marker].
	self assert: actual == marker!

----- Method: ObjectMirrorTest1>>testSlotAtIfPresent (in category 'tests') -----
testSlotAtIfPresent
	| slot |
	mirror slotAt: 1 ifPresent: [:s | slot := s].
	self assert: slot value == #testSlotAtIfPresent!

----- Method: ObjectMirrorTest1>>testSlotAtIfPresentNot (in category 'tests') -----
testSlotAtIfPresentNot
	| value answer |
	answer := mirror slotAt: 10 ifPresent: [:val | value := val].
	self assert: value isNil.
	self assert: answer isNil!

----- Method: ObjectMirrorTest1>>testSlots (in category 'tests') -----
testSlots
	| slots |
	slots := mirror slots.
	self assert: slots size = mirror size.
	slots do: [:ea | self assert: (ea isKindOf: FixedSlotMirror)]!

----- Method: ObjectMirrorTest1>>testUnderstands (in category 'tests') -----
testUnderstands
	self assert: (mirror understands: #testUnderstands)!

----- Method: ObjectMirrorTest1>>testUnderstandsNot (in category 'tests') -----
testUnderstandsNot
	self deny: (mirror understands: #thisSelectorIsNotImplemented)!

----- Method: ObjectMirrorTest1>>testUnderstandsSuper (in category 'tests') -----
testUnderstandsSuper
	self assert: (mirror understands: #runCase)!

TestCase subclass: #ObjectMirrorTest2
	instanceVariableNames: 'mirror handler shunt'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Mirrors-Tests'!

----- Method: ObjectMirrorTest2>>setUpFailShunt (in category 'as yet unclassified') -----
setUpFailShunt
	handler := [ :m | self assert: false ].
	shunt := MessageShunt handler: handler.
	mirror := ObjectMirror on: shunt!

----- Method: ObjectMirrorTest2>>testPerformSendsOneMessage (in category 'as yet unclassified') -----
testPerformSendsOneMessage
	handler := [:message | self assert: message selector = #griffle].
	shunt := MessageShunt handler: handler.
	mirror := ObjectMirror on: shunt.
	mirror perform: #griffle arguments: #().
	!

----- Method: ObjectMirrorTest2>>testSlotAtSendsNoMessages (in category 'as yet unclassified') -----
testSlotAtSendsNoMessages
	| slot |
	self setUpFailShunt.
	slot := mirror slotAt: 1.
	self assert: slot value == handler!

----- Method: ObjectMirrorTest2>>testUnderstandsSendsNoMessages (in category 'as yet unclassified') -----
testUnderstandsSendsNoMessages
	self setUpFailShunt.
	self deny: (mirror understands: #griffle)
	!

TestCase subclass: #ObjectMirrorTest3
	instanceVariableNames: 'mirror array'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Mirrors-Tests'!

----- Method: ObjectMirrorTest3>>setUp (in category 'as yet unclassified') -----
setUp
	array := {#one. #two. #three}.
	mirror := ObjectMirror on: array!

----- Method: ObjectMirrorTest3>>testSlotAt (in category 'as yet unclassified') -----
testSlotAt
	| slot |
	slot := mirror slotAt: 1.
	self assert: slot value = #one!

TestCase subclass: #ObjectMirrorTest4
	instanceVariableNames: 'mirror object'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Mirrors-Tests'!

----- Method: ObjectMirrorTest4>>setUp (in category 'as yet unclassified') -----
setUp
	object := (SparseLargeArray new: 3)
		at: 1 put: #one;
		at: 2 put: #two;
		at: 3 put: #three;
		yourself.
	mirror := ObjectMirror on: object!

----- Method: ObjectMirrorTest4>>testFixedSlotAt (in category 'as yet unclassified') -----
testFixedSlotAt
	| slot |
	slot := mirror slotAt: 2.
	self assert: slot value = 3!

----- Method: ObjectMirrorTest4>>testVariableSlotAt (in category 'as yet unclassified') -----
testVariableSlotAt
	| slot |
	slot := mirror slotAt: 6.
	self assert: slot value = #(one two three)!

TestCase subclass: #ObjectVmMirrorTest1
	instanceVariableNames: 'mirror four'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Mirrors-Tests'!

----- Method: ObjectVmMirrorTest1>>four: (in category 'accessing') -----
four: anObject
	four := anObject!

----- Method: ObjectVmMirrorTest1>>setUp (in category 'running') -----
setUp
	mirror := ObjectVmMirror on: self!

----- Method: ObjectVmMirrorTest1>>testFixedAt (in category 'tests') -----
testFixedAt
	four := Object new.
	self assert: (mirror fixedAt: 4) == four!

----- Method: ObjectVmMirrorTest1>>testFixedAtPut (in category 'tests') -----
testFixedAtPut
	| tmp |
	tmp := Object new.
	mirror fixedAt: 4 put: tmp.
	self assert: four == tmp!

----- Method: ObjectVmMirrorTest1>>testFixedSize (in category 'tests') -----
testFixedSize
	self assert: mirror fixedSize = 4!

----- Method: ObjectVmMirrorTest1>>testPerform (in category 'tests') -----
testPerform
	| tmp |
	tmp := Object new.
	mirror perform: #four: arguments: {tmp}.
	self assert: four == tmp!

----- Method: ObjectVmMirrorTest1>>testReflects (in category 'tests') -----
testReflects
	self assert: (mirror reflects: self)!

TestCase subclass: #ObjectVmMirrorTest2
	instanceVariableNames: 'mirror array'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Mirrors-Tests'!

----- Method: ObjectVmMirrorTest2>>setUp (in category 'as yet unclassified') -----
setUp
	array := #(one two three).
	mirror := ObjectVmMirror on: array!

----- Method: ObjectVmMirrorTest2>>testVariableAt (in category 'as yet unclassified') -----
testVariableAt
	self assert: (mirror variableAt: 2) == (array at: 2)!

----- Method: ObjectVmMirrorTest2>>testVariableAtPut (in category 'as yet unclassified') -----
testVariableAtPut
	| tmp |
	tmp := Object new.
	mirror variableAt: 2 put: tmp.
	self assert: (array at: 2) == tmp!

----- Method: ObjectVmMirrorTest2>>testVariableSize (in category 'as yet unclassified') -----
testVariableSize
	self assert: mirror variableSize = 3.!

TestCase subclass: #VariableSlotMirrorTest
	instanceVariableNames: 'mirror array'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Mirrors-Tests'!

----- Method: VariableSlotMirrorTest>>setUp (in category 'running') -----
setUp
	
	array := {#one. #two. #three}.
	mirror := VariableSlotMirror on: array index: 2.!

----- Method: VariableSlotMirrorTest>>testName (in category 'tests') -----
testName
	self assert: mirror name = '2'!

----- Method: VariableSlotMirrorTest>>testReflects (in category 'tests') -----
testReflects
	self assert: (mirror reflects: array)!

----- Method: VariableSlotMirrorTest>>testValue (in category 'tests') -----
testValue
	| actual expected |
	expected := array at: 2.
	actual := mirror value.
	self assert: actual == expected!

----- Method: VariableSlotMirrorTest>>testWrite (in category 'tests') -----
testWrite
	| tmp |
	tmp := Object new.
	mirror value: tmp.
	self assert: (array at: 2) == tmp!

Object subclass: #FixedSlotMirror
	instanceVariableNames: 'vmMirror index name'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Mirrors-Object'!

----- Method: FixedSlotMirror class>>on:index: (in category 'as yet unclassified') -----
on: anObject index: anInteger
	^ self onVmMirror: (ObjectVmMirror on: anObject) index: anInteger!

----- Method: FixedSlotMirror class>>onVmMirror:index: (in category 'as yet unclassified') -----
onVmMirror: aMirror index: anInteger
	^ self basicNew initializeWithMirror: aMirror index: anInteger!

----- Method: FixedSlotMirror>>initializeWithMirror:index: (in category 'as yet unclassified') -----
initializeWithMirror: aVmMirror index: anInteger
	| object |
	
	self initialize.
	vmMirror := aVmMirror.
	index := anInteger.
	
	"This should be done using a ClassMirror, once they're implemented."
	object := Reflection receiver: aVmMirror perform: #fixedAt: arguments: {1}.
	name := object class allInstVarNames at: anInteger!

----- Method: FixedSlotMirror>>name (in category 'as yet unclassified') -----
name
	^ name!

----- Method: FixedSlotMirror>>value (in category 'as yet unclassified') -----
value
	^ vmMirror fixedAt: index!

----- Method: FixedSlotMirror>>value: (in category 'as yet unclassified') -----
value: anObject
	vmMirror fixedAt: index put: anObject!

----- Method: FixedSlotMirror>>valueMirror (in category 'as yet unclassified') -----
valueMirror
	^ ObjectMirror on: self value!

Object subclass: #MirrorInspector
	instanceVariableNames: 'mirror index'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Mirrors-Utilities'!

----- Method: MirrorInspector class>>inspect: (in category 'as yet unclassified') -----
inspect: anObject
	(self on: anObject) open!

----- Method: MirrorInspector class>>on: (in category 'as yet unclassified') -----
on: anObject
	| mirror |
	mirror := ObjectMirror on: anObject.
	^ self basicNew initializeWithMirror: mirror!

----- Method: MirrorInspector>>buildWith: (in category 'building') -----
buildWith: aBuilder
	| list text window |
	list := aBuilder pluggableListSpec new
		model: self;
		frame: (LayoutFrame fractions: (0 at 0 corner: 0.5 at 1));
		list: #slotLabels;
		listSize: #slotCount;
		getIndex: #selectedSlotIndex;
		setIndex: #selectedSlotIndex:;
		doubleClick: #spawn;
		yourself.
	text := aBuilder pluggableTextSpec new
		model: self;
		frame: (LayoutFrame fractions: (0.5 at 0 corner: 1 at 1));
		askBeforeDiscardingEdits: false;
		getText: #slotPrintString;
		yourself.
	window := aBuilder pluggableWindowSpec new
		model: self; 
		label: #label; 
		extent: 300 at 200;
		children: {list. text}.
	^ aBuilder build: window
		!

----- Method: MirrorInspector>>initializeWithMirror: (in category 'initialization') -----
initializeWithMirror: aMirror
	self initialize.
	mirror := aMirror.
	index := 0.!

----- Method: MirrorInspector>>label (in category 'callbacks') -----
label
	^ 'Mirror Inspector on: ', self safePrintString!

----- Method: MirrorInspector>>open (in category 'initialization') -----
open
	ToolBuilder default open: self
	!

----- Method: MirrorInspector>>safePrintString (in category 'callbacks') -----
safePrintString
	^ mirror safePrintString!

----- Method: MirrorInspector>>selectedSlotIndex (in category 'callbacks') -----
selectedSlotIndex
	^ index !

----- Method: MirrorInspector>>selectedSlotIndex: (in category 'callbacks') -----
selectedSlotIndex: anInteger
	index := anInteger.
	self changed: #selectedSlotIndex.
	self changed: #slotPrintString!

----- Method: MirrorInspector>>slotCount (in category 'callbacks') -----
slotCount
	^ mirror size!

----- Method: MirrorInspector>>slotLabels (in category 'callbacks') -----
slotLabels
	^ mirror slots collect: [:ea | ea name]!

----- Method: MirrorInspector>>slotPrintString (in category 'callbacks') -----
slotPrintString
	^ index = 0 ifFalse: [(mirror slotAt: index) valueMirror safePrintString]!

----- Method: MirrorInspector>>spawn (in category 'callbacks') -----
spawn
	index = 0 ifFalse: [self class inspect: (mirror slotAt: index) value]!

Object subclass: #ObjectMirror
	instanceVariableNames: 'vmMirror'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Mirrors-Object'!

----- Method: ObjectMirror class>>on: (in category 'as yet unclassified') -----
on: anObject
	^ self basicNew initializeWithObject: anObject!

----- Method: ObjectMirror>>initializeWithObject: (in category 'initialization') -----
initializeWithObject: anObject
	self initialize.
	vmMirror := ObjectVmMirror on: anObject!

----- Method: ObjectMirror>>perform:arguments: (in category 'messages') -----
perform: aSelector arguments: anArray
	^ vmMirror perform: aSelector arguments: anArray!

----- Method: ObjectMirror>>reflects: (in category 'messages') -----
reflects: anObject
	^ vmMirror reflects: anObject!

----- Method: ObjectMirror>>safePrintString (in category 'printing') -----
safePrintString
	^ vmMirror safePrintString!

----- Method: ObjectMirror>>size (in category 'slots') -----
size
	^ vmMirror fixedSize + vmMirror variableSize!

----- Method: ObjectMirror>>slotAt: (in category 'slots') -----
slotAt: anInteger
	^ self 
		slotAt: anInteger 
		ifAbsent: [self error: 'Slot doesn''t exist']!

----- Method: ObjectMirror>>slotAt:ifAbsent: (in category 'slots') -----
slotAt: anInteger ifAbsent: aBlock
	^ self 
		slotAt: anInteger 
		ifPresent: [:val | val]
		ifAbsent: aBlock!

----- Method: ObjectMirror>>slotAt:ifPresent: (in category 'slots') -----
slotAt: anInteger ifPresent: aBlock
	^ self
		slotAt: anInteger
		ifPresent: aBlock
		ifAbsent: [nil]!

----- Method: ObjectMirror>>slotAt:ifPresent:ifAbsent: (in category 'slots') -----
slotAt: anInteger ifPresent: pBlock ifAbsent: aBlock
	^ anInteger <= self size
		ifTrue:
			[| fixedSize slot |
			fixedSize := vmMirror fixedSize.
			slot := anInteger <= fixedSize
				ifTrue: [FixedSlotMirror onVmMirror: vmMirror index: anInteger]
				ifFalse: [VariableSlotMirror onVmMirror: vmMirror index: anInteger - fixedSize].
			pBlock value: slot]
		ifFalse: aBlock
					

!

----- Method: ObjectMirror>>slots (in category 'slots') -----
slots
	^ (1 to: self size) collect: [:i | self slotAt: i]!

----- Method: ObjectMirror>>understands: (in category 'messages') -----
understands: aSelector
	^ vmMirror understands: aSelector!

Object subclass: #ObjectVmMirror
	instanceVariableNames: 'object'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Mirrors-Object'!

----- Method: ObjectVmMirror class>>on: (in category 'as yet unclassified') -----
on: anObject
	| inst |
	inst := self basicNew.
	inst initialize.
	Reflection 
		receiver: inst 
		perform: #fixedAt:put: 
		arguments: {1. anObject}.
	^ inst!

----- Method: ObjectVmMirror>>fixedAt: (in category 'slots') -----
fixedAt: anInteger
	^ Reflection
		receiver: object
		perform: #fixedAt:
		arguments: {anInteger}!

----- Method: ObjectVmMirror>>fixedAt:put: (in category 'slots') -----
fixedAt: anInteger put: anObject
	^ Reflection
		receiver: object
		perform: #fixedAt:put:
		arguments: {anInteger. anObject}!

----- Method: ObjectVmMirror>>fixedSize (in category 'slots') -----
fixedSize
	^ Reflection
		receiver: object
		perform: #fixedSize
		arguments: #()!

----- Method: ObjectVmMirror>>perform:arguments: (in category 'messages') -----
perform: aSelector arguments: anArray
	^ Reflection
		receiver: object
		perform: #perform:arguments:
		arguments: {aSelector. anArray}!

----- Method: ObjectVmMirror>>reflects: (in category 'testing') -----
reflects: anObject
	^ anObject == object!

----- Method: ObjectVmMirror>>safeIdentityHash (in category 'printing') -----
safeIdentityHash
	^ Reflection
		receiver: object
		perform: #identityHash
		arguments: #()!

----- Method: ObjectVmMirror>>safePrintOn: (in category 'printing') -----
safePrintOn: aStream
	aStream 
		nextPutAll: object class name;
		nextPut: $[;
		print: self safeIdentityHash;
		nextPut: $]!

----- Method: ObjectVmMirror>>safePrintString (in category 'printing') -----
safePrintString
	^ String streamContents: [:stream | self safePrintOn: stream]!

----- Method: ObjectVmMirror>>understands: (in category 'messages') -----
understands: aSelector
	"This should use a ClassMirror, but that isn't implemented yet. For now, #class is
	fine, because it's implemented as a byte code and doesn't send a messages to
	the reflectee"

	^ object class canUnderstand: aSelector!

----- Method: ObjectVmMirror>>variableAt: (in category 'slots') -----
variableAt: anInteger
	^ Reflection
		receiver: object
		perform: #variableAt:
		arguments: {anInteger}!

----- Method: ObjectVmMirror>>variableAt:put: (in category 'slots') -----
variableAt: anInteger put: anObject
	^ Reflection
		receiver: object
		perform: #variableAt:put:
		arguments: {anInteger. anObject}!

----- Method: ObjectVmMirror>>variableSize (in category 'slots') -----
variableSize
	^ Reflection
		receiver: object
		perform: #variableSize
		arguments: #()!

Object subclass: #Reflection
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Mirrors-Utilities'!

----- Method: Reflection class>>basicNew (in category 'as yet unclassified') -----
basicNew
	self error: 'Reflection should never be instanciated'!

----- Method: Reflection class>>primitiveFailedFor: (in category 'as yet unclassified') -----
primitiveFailedFor: anObject
	"Can make this smarter"
	
	self error: 'primitive failed'!

----- Method: Reflection class>>receiver:perform:arguments: (in category 'as yet unclassified') -----
receiver: anObject perform: aSelector arguments: anArray
	| cm |
	cm := self compiledMethodAt: aSelector ifAbsent: 
		[^ anObject doesNotUnderstand: (Message selector: aSelector arguments: anArray)].
	^ self receiver: anObject withArguments: anArray executeMethod: cm!

----- Method: Reflection class>>receiver:withArguments:executeMethod: (in category 'as yet unclassified') -----
receiver: receiver withArguments: argArray executeMethod: compiledMethod
	<primitive: 188>
	self primitiveFailed!

----- Method: Reflection class>>with:do: (in category 'as yet unclassified') -----
with: anObject do: aBlock
	| result shunt |
	shunt := MessageShunt handler:
		[:message || cm |
		cm := self compiledMethodAt: message selector.
		result := self 
			receiver: anObject 
			withArguments: message arguments 
			executeMethod: cm].
	aBlock value: shunt.
	^ result
		!

----- Method: Reflection>>fixedAt: (in category 'as yet unclassified') -----
fixedAt: anInteger
	<primitive: 73>
	^ Reflection primitiveFailedFor: self!

----- Method: Reflection>>fixedAt:put: (in category 'as yet unclassified') -----
fixedAt: anInteger put: anObject
	<primitive: 74>
	^ Reflection primitiveFailedFor: self!

----- Method: Reflection>>fixedSize (in category 'as yet unclassified') -----
fixedSize
	"We can get away with sending #class here because the compiler emits 
	a bytecode that reads the class pointer directly."
	
	| format |
	0 flag: #instSizeChange. 
	format := Reflection receiver: self class perform: #fixedAt: arguments: {3}.
	^ ((format bitShift: -10) bitAnd: 16rC0) + ((format bitShift: -1) bitAnd: 16r3F) - 1.
	
	!

----- Method: Reflection>>identityHash (in category 'as yet unclassified') -----
identityHash
	<primitive: 75>
	self class == SmallInteger ifTrue: [^ self].
	Reflection primitiveFailedFor: self!

----- Method: Reflection>>perform:arguments: (in category 'as yet unclassified') -----
perform: aSelector arguments: anArray
	<primitive: 84>
	Reflection primitiveFailedFor: self!

----- Method: Reflection>>variableAt: (in category 'as yet unclassified') -----
variableAt: anInteger
	<primitive: 60>
	^ Reflection primitiveFailedFor: self!

----- Method: Reflection>>variableAt:put: (in category 'as yet unclassified') -----
variableAt: anInteger put: anObject
	<primitive: 61>
	Reflection primitiveFailedFor: self!

----- Method: Reflection>>variableSize (in category 'as yet unclassified') -----
variableSize
	<primitive: 62>
	^ 0!

Object subclass: #VariableSlotMirror
	instanceVariableNames: 'vmMirror index'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Mirrors-Object'!

----- Method: VariableSlotMirror class>>on:index: (in category 'as yet unclassified') -----
on: anObject index: anInteger
	^ self onVmMirror: (ObjectVmMirror on: anObject) index: anInteger!

----- Method: VariableSlotMirror class>>onVmMirror:index: (in category 'as yet unclassified') -----
onVmMirror: aMirror index: anInteger
	^ self basicNew initializeWithMirror: aMirror index: anInteger!

----- Method: VariableSlotMirror>>initializeWithMirror:index: (in category 'as yet unclassified') -----
initializeWithMirror: aVmMirror index: anInteger
	self initialize.
	vmMirror := aVmMirror.
	index := anInteger!

----- Method: VariableSlotMirror>>name (in category 'as yet unclassified') -----
name
	^ index asString!

----- Method: VariableSlotMirror>>reflects: (in category 'as yet unclassified') -----
reflects: anObject
	^ vmMirror reflects: anObject!

----- Method: VariableSlotMirror>>value (in category 'as yet unclassified') -----
value
	^ vmMirror variableAt: index!

----- Method: VariableSlotMirror>>value: (in category 'as yet unclassified') -----
value: anObject
	^ vmMirror variableAt: index put: anObject!

----- Method: VariableSlotMirror>>valueMirror (in category 'as yet unclassified') -----
valueMirror
	^ ObjectMirror on: self value!



More information about the Squeak-dev mailing list