More Smalltalk/X API methods. Better RGClassDefinition creation.
RGClassDefinition>>newClass now creates a metaclass.
--- 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"