# HG changeset patch # User Jan Vrany # Date 1441026116 -3600 # Node ID ed5aae792d2419b0e9f8a1f178ff3445e6e8b033 # Parent e439b82dda7d8216b3410e29f1e8289f231c1ff8 More Smalltalk/X API methods. Better RGClassDefinition creation. RGClassDefinition>>newClass now creates a metaclass. diff -r e439b82dda7d -r ed5aae792d24 RGBehaviorDefinition.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 " +! + theNonMetaClass self subclassResponsibility ! +theNonMetaclass + ^ self theNonMetaClass + + "Created: / 29-08-2015 / 11:40:54 / Jan Vrany " +! + 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 " +! + withAllSubclasses "if allSubclasses is stored should not affect the collection" diff -r e439b82dda7d -r ed5aae792d24 RGClassDefinition.st --- 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 " + "Modified: / 31-08-2015 / 11:54:44 / Jan Vrany " +! + +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 " +! + +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 " ! ! !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 " +! + package "Retrieves the package in which this class is contained, if exists" @@ -318,3 +348,4 @@ and:[ (self theMetaClass isSameRevisionAs: aRGClassDefinition theMetaClass) ] ] ] ] ] ] ] ! ! + diff -r e439b82dda7d -r ed5aae792d24 RGMetaclassDefinition.st --- 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 " ! category @@ -99,6 +102,7 @@ ^self theNonMetaClass allSharedPoolNames ! ! + !RGMetaclassDefinition class methodsFor:'documentation'! version_HG diff -r e439b82dda7d -r ed5aae792d24 RGMethodDefinition.st --- 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 " ! 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 " +! + 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 " ! selector: aSymbol @@ -228,6 +248,18 @@ name := aSymbol ! +source + ^self sourceCode + + "Created: / 29-08-2015 / 11:19:43 / Jan Vrany " +! + +source: aString + self sourceCode: aString + + "Created: / 29-08-2015 / 11:34:20 / Jan Vrany " +! + sourceCode self isActive @@ -601,3 +633,4 @@ ifFalse:[ status == #passive ] ! ! + diff -r e439b82dda7d -r ed5aae792d24 tests/RGClassDefinitionTest.st --- 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 " +! + testNonExistingClass | newClass | diff -r e439b82dda7d -r ed5aae792d24 tests/RGGlobalDefinitionTest.st --- 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. diff -r e439b82dda7d -r ed5aae792d24 tests/RGMethodDefinitionTest.st --- 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 " ! +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 " +! + testDifferentObjectButSameMethodInSet "self debug: #testDifferentObjectButSameMethodInSet"