Separate ReadOnly EnvInObj handlers

Examples/Benchmarks/Mate/Immutability/HandlesEnvInObj/Handle.som

@@ -0,0 +1,47 @@
+Handle = (
+	| target |
+    "Accessing"
+    targetSPECIAL: anObject = ( target := anObject )
+    targetSPECIAL = ( ^target )
+    = other 				= (^self equalsSPECIAL: other)
+    equalsSPECIAL: other 	= (^target = other)
+    == other 				= (^self equalsequalsSPECIAL: other)
+    equalsequalsSPECIAL: other = (
+    	| compareTo |
+    	compareTo := (other class = self class)
+    		ifTrue: [other targetSPECIAL]
+    		ifFalse: [other].
+    	^target == compareTo
+    )
+
+    ----------------------------
+
+    | semantics |
+
+    "Accessing"
+    semantics = ( ^semantics )
+    semantics: anObject	= ( semantics := anObject )
+
+    initialize = (
+        HandleForArray initialize.
+        HandleForClass initialize.
+        ImmutableMessageForHandlesMO initialize.
+        ImmutableMessageForArrayHandlesMO initialize.
+        ImmutableMessageForClassHandlesMO initialize.
+
+        self semantics:
+                    (EnvironmentMO
+                            operationalSemantics: ImmutableSemanticsForHandlesMO new
+                            message: ImmutableMessageForHandlesMO new
+                            layout: nil
+                    ).
+    )
+
+    targetSPECIAL: anObject = (
+        | object |
+        (anObject class = self) ifTrue: [^anObject].
+        object := self basicNew: self semantics.
+        object targetSPECIAL: anObject.
+        ^object
+    )
+ )

Examples/Benchmarks/Mate/Immutability/HandlesEnvInObj/HandleForArray.som

@@ -0,0 +1,6 @@
+HandleForArray = HandleSupportingPrimitives (
+
+    ----------------------------
+
+    messageMO = ( ^ImmutableMessageForArrayHandlesMO new)
+ )

Examples/Benchmarks/Mate/Immutability/HandlesEnvInObj/HandleForClass.som

@@ -0,0 +1,6 @@
+HandleForClass = HandleSupportingPrimitives (
+
+    ----------------------------
+
+    messageMO = ( ^ImmutableMessageForClassHandlesMO new)
+ )

Examples/Benchmarks/Mate/Immutability/HandlesEnvInObj/HandleSupportingPrimitives.som

@@ -0,0 +1,14 @@
+HandleSupportingPrimitives = Handle (
+
+    --------------
+
+    initialize = (
+		| shape |
+		self semantics: 
+					(EnvironmentMO 
+							operationalSemantics: ImmutableSemanticsForHandlesMO new 
+							message: self messageMO
+							layout: nil
+					).
+	)
+ )

Examples/Benchmarks/Mate/Immutability/HandlesEnvInObj/ImmutableMessageForArrayHandlesMO.som

@@ -0,0 +1,26 @@
+ImmutableMessageForArrayHandlesMO = ImmutableMessageForPrimitivesMO (
+	find: aSymbol since: aClass = (	
+		(ImmutableMessageForArrayHandlesMO writablePrimitives contains: aSymbol) 
+			ifTrue: ['ERROR: Unexpected write to a readonly object!' println. self halt. ^nil]
+		^(ImmutableMessageForArrayHandlesMO returningPrimitives containsKey: aSymbol) 
+			ifTrue: [super find: (ImmutableMessageForArrayHandlesMO returningPrimitives at: aSymbol) since: aClass]	
+			ifFalse: [super find: aSymbol since: aClass]
+	)
+
+	activate: aSignature withArguments: arguments = (
+		(ImmutableMessageForArrayHandlesMO primitives contains: aSignature) ifTrue:[
+			arguments at:3 put: (arguments at: 3) targetSPECIAL.
+		]
+		^arguments
+	)
+	----------------------------
+	initialize = (
+		Primitives := #(#length).
+		WritablePrimitives := #(#at:put:).
+
+		"We must wrap returning primitives so that the returned value is wrapped with a readonly reference"
+		ReturningPrimitives := Dictionary new.
+		ReturningPrimitives at: #at: put: #atHandlesSPECIAL:
+	)
+
+)

Examples/Benchmarks/Mate/Immutability/HandlesEnvInObj/ImmutableMessageForClassHandlesMO.som

@@ -0,0 +1,29 @@
+ImmutableMessageForClassHandlesMO = ImmutableMessageForPrimitivesMO (
+	find: aSymbol since: aClass = (	
+		(ImmutableMessageForClassHandlesMO writablePrimitives contains: aSymbol) 
+			ifTrue: ['ERROR: Unexpected write to a readonly object!' println. self halt. ^nil]
+		^(ImmutableMessageForClassHandlesMO returningPrimitives containsKey: aSymbol) 
+			ifTrue: [super find: (ImmutableMessageForClassHandlesMO returningPrimitives at: aSymbol) since: aClass]	
+			ifFalse: [super find: aSymbol since: aClass]
+	)
+
+	activate: aSignature withArguments: arguments = (
+		(ImmutableMessageForClassHandlesMO primitives contains: aSignature) ifTrue:[
+			arguments at:3 put: (arguments at: 3) targetSPECIAL.
+		]
+		^arguments
+	)
+	----------------------------
+
+	initialize = (
+		Primitives := #().
+		WritablePrimitives := #(#basicNew).
+
+		"We must wrap returning primitives so that the returned value is wrapped with a readonly reference"
+		ReturningPrimitives := Dictionary new.
+		ReturningPrimitives at: #superclass put: #superclassSPECIAL.
+		ReturningPrimitives at: #fields put: #fieldsSPECIAL.
+		ReturningPrimitives at: #methods put: #methodsSPECIAL.
+		ReturningPrimitives at: #name put: #nameSPECIAL.
+	)
+)

Examples/Benchmarks/Mate/Immutability/HandlesEnvInObj/ImmutableMessageForHandlesMO.som

@@ -0,0 +1,17 @@
+ImmutableMessageForHandlesMO = MessageLookupMO (
+    find: aSymbol since: aClass = (	
+		| lookupStart |
+		lookupStart := (ImmutableMessageForHandlesMO reimplementedPrimitives contains: aSymbol) 
+			ifTrue: [self class]
+			ifFalse: [self targetSPECIAL class].
+		^super find: aSymbol since: lookupStart
+	)
+
+	----------------------------
+	| ReimplementedPrimitives |
+
+	initialize = (
+		ReimplementedPrimitives := #(#= #== #equalsequalsSPECIAL: #equalsSPECIAL:)
+	)
+	reimplementedPrimitives = (^ReimplementedPrimitives)
+)

Examples/Benchmarks/Mate/Immutability/HandlesEnvInObj/ImmutableMessageForPrimitivesMO.som

@@ -0,0 +1,8 @@
+ImmutableMessageForPrimitivesMO = ImmutableMessageForHandlesMO (
+    ----------------------------
+	| WritablePrimitives ReturningPrimitives Primitives |
+
+	writablePrimitives = (^WritablePrimitives)
+	returningPrimitives = (^ReturningPrimitives)
+	primitives = (^Primitives) 
+)

Examples/Benchmarks/Mate/Immutability/HandlesEnvInObj/ImmutableSemanticsForHandlesMO.som

@@ -0,0 +1,4 @@
+ImmutableSemanticsForHandlesMO = OperationalSemanticsMO (
+    read: anIndex = (^(self targetSPECIAL instVarAt: anIndex) readOnly)
+    write: anIndex value: aValue = (^aValue)
+)

Smalltalk/Object.som

@@ -84,7 +84,7 @@ Object = nil (
     "Debugging"
     inspect   = primitive
     halt      = primitive
-    hasMetaObjectEnvironment = primitive
+    hasEnvironment = primitive
     inMeta = primitive
 
     "Error handling"