More Smalltalk/X API methods. Better RGClassDefinition creation.
authorJan Vrany <jan.vrany@fit.cvut.cz>
Mon, 31 Aug 2015 14:01:56 +0100
changeset 3 ed5aae792d24
parent 2 e439b82dda7d
child 4 90637b709fa9
More Smalltalk/X API methods. Better RGClassDefinition creation. RGClassDefinition>>newClass now creates a metaclass.
RGBehaviorDefinition.st
RGClassDefinition.st
RGMetaclassDefinition.st
RGMethodDefinition.st
tests/RGClassDefinitionTest.st
tests/RGGlobalDefinitionTest.st
tests/RGMethodDefinitionTest.st
--- a/RGBehaviorDefinition.st	Sat Aug 29 10:31:59 2015 +0100
+++ b/RGBehaviorDefinition.st	Mon Aug 31 14:01:56 2015 +0100
@@ -117,11 +117,23 @@
     self subclassResponsibility
 !
 
+theMetaclass
+    ^ self theMetaClass
+
+    "Created: / 29-08-2015 / 11:40:10 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
 theNonMetaClass
 
     self subclassResponsibility
 !
 
+theNonMetaclass
+    ^ self theNonMetaClass
+
+    "Created: / 29-08-2015 / 11:40:54 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
 traitNames
     "Assuming that traits in a composition can be identified by
     testing for the first character being an uppercase character
@@ -198,6 +210,12 @@
     ^ methods
 !
 
+methodDictionary
+    ^ methods
+
+    "Created: / 29-08-2015 / 18:07:37 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
 withAllSubclasses
     "if allSubclasses is stored should not affect the collection"
 
--- a/RGClassDefinition.st	Sat Aug 29 10:31:59 2015 +0100
+++ b/RGClassDefinition.st	Mon Aug 31 14:01:56 2015 +0100
@@ -14,13 +14,34 @@
 
 !RGClassDefinition class methodsFor:'instance creation'!
 
-createSharedPoolNamed: aSymbol
+newClass
+    "Creates new class definition (along with it's metaclass)"
+
+    ^ self new withMetaclass
+
+    "Created: / 29-08-2015 / 12:02:20 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+    "Modified: / 31-08-2015 / 11:54:44 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+newSharedPool
+    "A shared pool is a class inheriting from #SharedPool"
+    
+    ^ RGClassDefinition newClass
+        superclassName:#SharedPool;
+        isPool:true;
+        yourself
+
+    "Created: / 29-08-2015 / 11:54:08 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+newSharedPoolNamed:aSymbol 
     "A shared pool is a class inheriting from #SharedPool"
 
-    ^(RGClassDefinition named: aSymbol)
-            superclassName: #SharedPool;
-            isPool: true;
-            yourself
+    ^ self newSharedPool
+        name: aSymbol;
+        yourself
+
+    "Modified: / 29-08-2015 / 11:54:27 / Jan Vrany <jan.vrany@fit.cvut.cz>"
 ! !
 
 !RGClassDefinition methodsFor:'accessing'!
@@ -67,6 +88,15 @@
      
 !
 
+name: aString
+    super name: aString.
+    (metaClass notNil and:[metaClass name isNil]) ifTrue:[ 
+        metaClass name: aString, ' class'.
+    ].
+
+    "Created: / 29-08-2015 / 12:05:22 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
 package
     "Retrieves the package in which this class is contained, if exists"
     
@@ -318,3 +348,4 @@
         and:[ (self theMetaClass isSameRevisionAs: aRGClassDefinition theMetaClass) ] ] ] ] ] ] ]
 ! !
 
+
--- a/RGMetaclassDefinition.st	Sat Aug 29 10:31:59 2015 +0100
+++ b/RGMetaclassDefinition.st	Mon Aug 31 14:01:56 2015 +0100
@@ -25,9 +25,12 @@
 !RGMetaclassDefinition methodsFor:'accessing'!
 
 baseClass: aRGClassDefinition
+    baseClass:= aRGClassDefinition.
+    baseClass name notNil ifTrue:[ 
+        self name: (baseClass name, ' class') asSymbol
+    ].
 
-    baseClass:= aRGClassDefinition.
-    self name: (baseClass name, ' class') asSymbol
+    "Modified: / 29-08-2015 / 12:03:24 / Jan Vrany <jan.vrany@fit.cvut.cz>"
 !
 
 category
@@ -99,6 +102,7 @@
     ^self theNonMetaClass allSharedPoolNames
 ! !
 
+
 !RGMetaclassDefinition class methodsFor:'documentation'!
 
 version_HG
--- a/RGMethodDefinition.st	Sat Aug 29 10:31:59 2015 +0100
+++ b/RGMethodDefinition.st	Mon Aug 31 14:01:56 2015 +0100
@@ -125,7 +125,9 @@
 !RGMethodDefinition methodsFor:'accessing'!
 
 ast
-    ^ self compiledMethod ast 
+    ^ self parseTree
+
+    "Modified: / 29-08-2015 / 11:20:34 / Jan Vrany <jan.vrany@fit.cvut.cz>"
 !
 
 compiledMethod
@@ -200,6 +202,14 @@
     package:= aRGPackage
 !
 
+parseTree
+    "raise an error: this method should be implemented (TODO)"
+
+    ^ RBParser parseMethod: self sourceCode
+
+    "Created: / 29-08-2015 / 11:20:34 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
 protocol
 
     self isActive 
@@ -219,7 +229,17 @@
 selector
     "Retrieves the name of the method"
 
-    ^name
+    name isNil ifTrue:[ 
+        | src |    
+
+        src := self sourceCode.
+        src notNil ifTrue:[ 
+            name := RBParser parseMethodPattern: src.  
+        ].
+    ].
+    ^ name
+
+    "Modified: / 29-08-2015 / 11:37:25 / Jan Vrany <jan.vrany@fit.cvut.cz>"
 !
 
 selector: aSymbol
@@ -228,6 +248,18 @@
     name := aSymbol
 !
 
+source
+    ^self sourceCode
+
+    "Created: / 29-08-2015 / 11:19:43 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+source: aString
+    self sourceCode: aString
+
+    "Created: / 29-08-2015 / 11:34:20 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
 sourceCode
 
     self isActive 
@@ -601,3 +633,4 @@
         ifFalse:[ status == #passive ]
 ! !
 
+
--- a/tests/RGClassDefinitionTest.st	Sat Aug 29 10:31:59 2015 +0100
+++ b/tests/RGClassDefinitionTest.st	Mon Aug 31 14:01:56 2015 +0100
@@ -147,6 +147,25 @@
     self assert: (metaClass realClass = OrderedCollection class).
 !
 
+testNewClass
+    | newClass |
+
+    newClass:= RGClassDefinition newClass.
+
+    self assert: (newClass isRingObject).
+    self assert: (newClass isClass).  
+    self assert: (newClass name isNil).
+    self assert: (newClass theMetaClass notNil).
+    self assert: (newClass theMetaClass isMetaclass).
+    self assert: (newClass theMetaClass name isNil).
+
+    newClass name: 'NewClass'.         
+    self assert: (newClass name = 'NewClass').
+    self assert: (newClass theMetaClass name = 'NewClass class').
+
+    "Created: / 29-08-2015 / 12:02:38 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
 testNonExistingClass
     | newClass |
     
--- a/tests/RGGlobalDefinitionTest.st	Sat Aug 29 10:31:59 2015 +0100
+++ b/tests/RGGlobalDefinitionTest.st	Mon Aug 31 14:01:56 2015 +0100
@@ -36,7 +36,7 @@
 
 testPoolDefinition
     | pool newClass |
-    pool := RGClassDefinition createSharedPoolNamed: #TextConstants.
+    pool := RGClassDefinition newSharedPoolNamed:#TextConstants.
     self assert: pool isPool.
     self assert: pool users isEmpty.
     self assert: pool parent equals: Smalltalk globals.
--- a/tests/RGMethodDefinitionTest.st	Sat Aug 29 10:31:59 2015 +0100
+++ b/tests/RGMethodDefinitionTest.st	Mon Aug 31 14:01:56 2015 +0100
@@ -139,6 +139,17 @@
     "Modified: / 29-08-2015 / 10:26:02 / Jan Vrany <jan.vrany@fit.cvut.cz>"
 !
 
+testCreatingMethodsWithoutFactory2
+    | newMethod |
+
+    newMethod := RGMethodDefinition realClass: OrderedCollection.
+    self assert: (newMethod selector isNil).
+    newMethod source: 'foo: a bar: b ^ a + b'.
+    self assert: (newMethod isMethod).
+
+    "Created: / 29-08-2015 / 11:58:53 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
 testDifferentObjectButSameMethodInSet
     "self debug: #testDifferentObjectButSameMethodInSet"