Matthias/ruby singleton

src/packages/Maglev.package/Metaclass3.extension/instance/_rubyInspect..st

@@ -1,17 +1,11 @@
 *maglev-runtime
 _rubyInspect: envId
   "called from smalltalk code"
-   self isMeta ifTrue:[  | res |
-     res := '#<Class:' copy .
-     res add: (destClass rubyFullName: envId  ) ;
-         add:  $>  .
-     ^ res
-  ] ifFalse:[ | name |
-    name := self rubyFullName: envId .
+   (self isMeta or: [self isRubySingletonClass or: [self isMetaModule]]) 
+    ifTrue: [^ self _rubyInspectSingletonClass]
+    ifFalse:[ |name|
+      name := self rubyFullName: envId .
+      (name isNil or: [name size == 0]) ifTrue: [
+        ^ '#<Class:0x', self asOop hex, '>' ].
+      ^ name]
 
-    (name isNil or: [name size == 0]) ifTrue: [
-      self isMeta ifTrue: [ ^ (destClass rubyFullName: envId), ':Class' ].
-      ^ '#<Class:0x', self asOop hex, '>' ].
-
-    ^ name
-  ]

src/packages/Maglev.package/Metaclass3.extension/instance/_rubyInspectSingletonClass.st

@@ -0,0 +1,9 @@
+*maglev-runtime
+_rubyInspectSingletonClass
+  |str|
+  str := '#<Class:' copy.
+  destClass == nil
+    ifTrue: [str addAll: self primaryCopy _rubyInspect]
+    ifFalse: [str addAll: destClass _rubyInspect].
+  str addAll: '>'.
+  ^ str

src/packages/Maglev.package/Metaclass3.extension/instance/destClass..st

@@ -0,0 +1,4 @@
+*maglev-runtime
+destClass: aClass
+  "Called after Ruby singleton class creation."
+  destClass := aClass

src/packages/Maglev.package/Metaclass3.extension/instance/destClass.st

@@ -0,0 +1,4 @@
+*maglev-runtime
+destClass
+  ^ destClass
+

src/packages/Maglev.package/Metaclass3.extension/instance/rubyMethods.protection..st

@@ -1,6 +1,4 @@
 *maglev-runtime
 rubyMethods: includeSuper protection: protInt
   "a ruby primitive"
-  self isMeta ifTrue:[ ^ IdentitySet new ].
-  ^ self class rubyMethods: includeSuper protection: protInt env: 1"__callerEnvId"
-
+  ^ self virtualClass rubyMethods: includeSuper protection: protInt env: 1"__callerEnvId"

src/packages/Maglev.package/Metaclass3.extension/methodProperties.json

@@ -8,10 +8,13 @@
 		"_includeRubyModule:" : "DataCurator 10/02/2012 14:30",
 		"_rubyInspect" : "DataCurator 10/02/2012 14:30",
 		"_rubyInspect:" : "DataCurator 10/02/2012 14:30",
+    "_rubyInspectSingletonClass" : "DataCurator 03/28/2013 18:11",
 		"addModuleMethodIfEnabled:env:" : "DataCurator 10/02/2012 14:30",
 		"allModuleMethodsEnabled:" : "DataCurator 10/02/2012 14:30",
 		"classForConstantLookup:forModuleEval:" : "DataCurator 10/02/2012 14:30",
 		"clsMethodDefnTarget" : "DataCurator 10/02/2012 14:30",
+    "destClass" : "DataCurator 04/03/2013 18:28",
+    "destClass:" : "DataCurator 03/28/2013 18:09",
 		"is_aModule" : "DataCurator 10/02/2012 14:30",
 		"methodDefined:rubyEnv:" : "DataCurator 10/02/2012 14:30",
 		"moduleIncludeSelf:" : "DataCurator 10/02/2012 14:30",

src/packages/Maglev.package/Module.extension/instance/_rubyInspect.st

@@ -2,10 +2,10 @@
 _rubyInspect
   "a ruby primitive"
   | str |
+  self isMetaModule ifTrue: [^ self _rubyInspectSingletonClass].
   str := self rubyFullName: 1"__callerEnvId" .
   str size ~~ 0 ifTrue:[ ^ str ].
   str := '#<Module:0x' copy .
   str addAll: self asOop hex ;
      add: $> . 
   ^ str 
-

src/packages/Maglev.package/Module.extension/instance/_rubyInspectSingletonClass.st

@@ -0,0 +1,7 @@
+*maglev-runtime
+_rubyInspectSingletonClass
+  |str|
+  str := '#<Class:' copy.
+  str addAll: primaryCopy _rubyInspect.
+  str addAll: '>'.
+  ^ str

src/packages/Maglev.package/Module.extension/instance/moduleMethodsModuleOrNil.st

@@ -4,7 +4,6 @@ moduleMethodsModuleOrNil
    for a Module "
   | meta |
   meta := self virtualClass .
-  meta == Module ifTrue: [ ^ meta ].
-  meta isRubyModuleFunctions ifTrue:[ ^ meta ].
+  meta == Module ifTrue: [meta := self _singletonClassFor: 1. ^ meta].
+  meta isRubyModuleFunctions ifTrue: [^ meta].
   ^ nil
-

src/packages/Maglev.package/Module.extension/instance/primaryCopy.st

@@ -0,0 +1,3 @@
+*maglev-runtime
+primaryCopy
+  ^ primaryCopy

src/packages/Maglev.package/Module.extension/methodProperties.json

@@ -24,6 +24,7 @@
 		"_rubyIncludeModule:envId:" : "DataCurator 10/02/2012 14:30",
 		"_rubyInspect" : "DataCurator 10/02/2012 14:30",
 		"_rubyInspect:" : "DataCurator 10/02/2012 14:30",
+        "_rubyInspectSingletonClass" : "DataCurator 04/02/2013 14:19",
 		"_rubyModuleIncludeSelfEnv:" : "",
 		"_setPersistable" : "DataCurator 10/02/2012 14:30",
 		"_setTopNameSpace:persistent:env:" : "DataCurator 10/02/2012 14:30",
@@ -64,6 +65,7 @@
 		"persistentNameSpace:put:" : "DataCurator 10/02/2012 14:30",
 		"persistentRubySuperclass:" : "DataCurator 10/02/2012 14:30",
 		"persistentRubySuperclass:put:" : "DataCurator 10/02/2012 14:30",
+        "primaryCopy" : "DataCurator 04/02/2013 14:20",
 		"removeConst:env:" : "DataCurator 10/02/2012 14:30",
 		"removeRubySelector:env:" : "DataCurator 10/02/2012 14:30",
 		"rubyAncestors" : "DataCurator 10/02/2012 14:30",

src/packages/Maglev.package/Object.extension/instance/_singletonClass..st

@@ -1,14 +1,10 @@
 *maglev-runtime
-_singletonClass: envId 
+_singletonClass: envId  
   | cls |
-  self class == Module ifTrue:[   "a  class<<self   within a  module "
-    cls := self moduleMethodsModuleOrNil ifNil:[ 
-       cls := self _rubyModuleIncludeSelfEnv: envId 
-    ].
-  ] ifFalse:[  
-    self isBehavior ifTrue:[ 
-       cls := self virtualClass . "extending metaclass"
-    ] ifFalse:[ cls := self _singletonClassFor: envId ].
-  ].
-  ^ cls 
+  self class == Module 
+    ifTrue: ["a  class<<self   within a  module "
+      cls := self moduleMethodsModuleOrNil ifNil: [cls := self _rubyModuleIncludeSelfEnv: envId]] 
+    ifFalse: ["a class or a non-class object"
+      ^ self _singletonClassFor: envId].
+  ^ cls
 

src/packages/Maglev.package/Object.extension/instance/_singletonClassAllowedFor..st

@@ -0,0 +1,6 @@
+*maglev-runtime
+_singletonClassAllowedFor: aClass
+ |classes metaClasses|
+  classes := {Behavior. Module.  Array. GsFile.}.
+  metaClasses := classes collect: [:cls | cls class].
+  ^ ((classes includes: aClass) or: [metaClasses includes: aClass]) not

src/packages/Maglev.package/Object.extension/instance/_singletonClassFor..st

@@ -1,10 +1,38 @@
 *maglev-runtime
 _singletonClassFor: envId
-   | cls |
-   (cls := self virtualClass)  isRubySingletonClass ifFalse:[
-      self addRubySingletonClass: envId .
-      cls := self virtualClass .
-      cls isRubySingletonClass ifFalse:[ self error:'_singletonClassFor:, creation failed' ].
-   ].
-   ^ cls
+  |isSecondMetaOrSingleton isSecondSingletonGenerated isSecondSingletonAllowed|
+  (self _singletonClassAllowedFor: self) ifFalse: [ 
+    "singleton class generation not allowed"
+    [Kernel @ruby1:warn: 'warning: adding higher level singleton class not allowed for ', self name]
+      onException: AbstractException do: [:e| "ignore, no warnings allowed in bootstrap"].
+    ^ self virtualClass].
+  self isBehavior
+    ifFalse: ["an object" 
+      self virtualClass isRubySingletonClass ifFalse: [self addRubySingletonClass]]
+    ifTrue: ["a class"
+      (self isMetaOrModule not and: [self isRubySingletonClass not])
+        "ifTrue: It's neither a meta class nor a Ruby singleton class, so it must be a class.
+         Smalltalk meta classes (=first level Ruby singleton class) are automatically
+         created by GemStone."
+        ifFalse: [
+          self virtualClass isRubySingletonClass
+            "ifTrue: singleton class exists already."
+            ifFalse: ["The actual singleton class was not created yet. This is just a fix for Trac779."
+              self addRubySingletonClass]]].
+
+  "Generate next level singleton class, only if it does not already exist."
+  "It's a class (no meta class or singleton class), so meta class exists already."
+  isSecondMetaOrSingleton := self virtualClass isMeta not and: [self virtualClass isRubySingletonClass not].
+  "Next level singleton class was already generated."
+  isSecondSingletonGenerated := self virtualClass virtualClass isRubySingletonClass and: 
+    ["check if this singleton class is actually the singleton class for our class or just
+      a dummy singleton class for Trac779."
+      self virtualClass virtualClass destClass == self virtualClass].
+  "Generation of singleton class is allowed for this class. Reimplementing isKindOf: might
+   remove this restriction (isKindOf: only works for 'real' classes)."
+  isSecondSingletonAllowed := self _singletonClassAllowedFor: self virtualClass.
+  (isSecondSingletonGenerated not & isSecondMetaOrSingleton not & isSecondSingletonAllowed)
+    ifTrue: [self virtualClass addRubySingletonClassSecondLevel: true].
+
+  ^ self virtualClass
 

src/packages/Maglev.package/Object.extension/instance/addRubySingletonClass.st

@@ -0,0 +1,4 @@
+*maglev-runtime
+addRubySingletonClass
+  ^ self addRubySingletonClassSecondLevel: false
+

src/packages/Maglev.package/Object.extension/instance/addRubySingletonClassSecondLevel..st

@@ -0,0 +1,32 @@
+*maglev-runtime
+addRubySingletonClassSecondLevel: isSecondLevel
+
+"Insert a new singleton class in the receiver's class hierarchy.
+ Returns receiver, or signals an error. The new class is persistable."
+
+  |vCls singletonClassName|
+
+  (self _singletonClassAllowedFor: self) ifFalse: [
+    ArgumentTypeError signal: 'add singleton class disallowed for ', self name.
+    ^ self].
+
+  self isSpecial ifTrue: [
+    ArgumentTypeError signal: 'add singleton class disallowed for special objects'.
+    ^ self].
+
+  self isCommitted ifTrue: [
+    "The new class pointer for this class will not be committed!"
+    [Kernel @ruby1:warn: 'warning: adding singleton class to committed object']
+      onException: AbstractException do: [:e| "ignore, no warnings allowed in bootstrap"]].
+
+  singletonClassName := (self name, ' class') asSymbol.
+
+  "Why did we need envId here?"
+  vCls := self _addRubySingletonClass: singletonClassName forSuperClass: (self rubySingletonSuperclassSecondLevel: isSecondLevel).
+
+  vCls _isOneByteString
+    ifTrue: [ArgumentTypeError signal: 'add singleton class disallowed, ', vCls]
+    ifFalse: [vCls destClass: self].
+
+  ^ self
+

src/packages/Maglev.package/Object.extension/instance/rubySingletonSuperclassSecondLevel..st

@@ -0,0 +1,22 @@
+*maglev-runtime
+rubySingletonSuperclassSecondLevel: isSecondLevel
+  "Returns the superclass of self's singleton class. Creates
+  all singleton classes in the singleton class's hierarchy,
+  if necessary."
+
+  self isClass ifTrue: [
+    self == Object
+      ifTrue: [^ Metaclass3]
+      ifFalse: [
+        self == Module class
+          ifTrue: [
+            "We don't want to create 2nd/higher order singleton
+             classes of Behavior."
+            ^ Object class]
+          ifFalse: [
+            isSecondLevel 
+              ifTrue: ["Don't go deeper. This is already the second level."
+                ^ self _superclass virtualClass]
+              ifFalse: [^ self _superclass rubySingletonClass]]]]
+    ifFalse: [^ self class].
+

src/packages/Maglev.package/Object.extension/methodProperties.json

@@ -16,9 +16,11 @@
 		"_rubyTo:" : "DataCurator 10/02/2012 14:30",
 		"_rubyTo_:" : "DataCurator 10/02/2012 14:30",
 		"_singletonClass:" : "DataCurator 10/02/2012 14:30",
+    "_singletonClassAllowedFor:" : "DataCurator 04/03/2013 18:24",
 		"_singletonClassFor:" : "DataCurator 10/02/2012 14:30",
 		"addRubyClassVar:value:mref:" : "DataCurator 10/02/2012 14:30",
-		"addRubySingletonClass:" : "DataCurator 10/02/2012 14:30",
+		"addRubySingletonClass" : "DataCurator 10/02/2012 14:30",
+    "addRubySingletonClassSecondLevel:" : "DataCurator 03/04/2013 18:20",
 		"classForConstantLookup:forModuleEval:" : "DataCurator 10/02/2012 14:30",
 		"clsMethodDefnTarget" : "DataCurator 10/02/2012 14:30",
 		"instanceEvalString:with:args:" : "DataCurator 10/02/2012 14:30",
@@ -48,4 +50,5 @@
 		"rubySingletonClass" : "DataCurator 10/02/2012 14:30",
 		"rubySingletonClassForExtend" : "DataCurator 10/02/2012 14:30",
 		"rubySingletonMethods:protection:" : "DataCurator 10/02/2012 14:30",
-		"rubySingletonMethods:protection:env:" : "DataCurator 10/02/2012 14:30" } }
+		"rubySingletonMethods:protection:env:" : "DataCurator 10/02/2012 14:30",
+    "rubySingletonSuperclassSecondLevel:" : "DataCurator 03/28/2013 18:06" } }

src/smalltalk/ruby/Object_ruby.gs

@@ -251,17 +251,17 @@ _rubyNilQ
 
 category: 'Ruby private'
 method:
-_addRubySingletonClass: committedOk envId: envId
+_addRubySingletonClass: singleton forSuperClass: singletonSuperclass
 
-"Insert a new singleton class in the receiver's class hierarchy.
+"Insert the singleton class in the receiver's class hierarchy.
  Returns the new class, or a String giving reason for failure
 "
 <primitive: 682>
-committedOk _validateClass: Boolean .
+"committedOk _validateClass: Boolean .
 envId _validateClass: SmallInteger .
-(envId < 1 or:[ envId > 255]) ifTrue:[ OutOfRange signal:'invalid envId'].
+(envId < 1 or:[ envId > 255]) ifTrue:[ OutOfRange signal:'invalid envId']."
 self _primitiveFailed: #_addRubySingletonClass:envId:
-     args: { committedOk . envId }
+     args: { singleton . singletonSuperclass }
 %