[Help-smalltalk] update STClassLoader

[Paolo Bonzini]

This patch updates STClassLoader to support more methods on the loaded 
classes, and to support class "shapes" instead of the more limited 
Smalltalk-80 "kinds".

Paolo

* looking for address@hidden/smalltalk--devo--2.2--patch-321 to compare with
* comparing to address@hidden/smalltalk--devo--2.2--patch-321
M  compiler/STLoader.st
M  compiler/STLoaderObjs.st
M  TODO
M  kernel/Behavior.st

* modified files

--- orig/TODO
+++ mod/TODO
@@ -1,8 +1,10 @@
-* 2.4
+* 3.0
 
-** implement SmallScript file-in?
+** implement new syntax (being done)
 
-** use VFS to (re)implement packages?
+** implement a better packaging system allowing zipped source files with
+XML package descriptions to be delivered and installed.  Investigate
+basing it on the Virtual File System infrastructure.
 
 ** faster startup (done)
 
@@ -11,6 +13,7 @@
 ** upgrade XML parser for package files
 *** support arch-dependent files that are installed in the image path
 
+
 * sometime
 
 ** some kind of sandboxing (partly done)
@@ -25,6 +28,17 @@ in sync.  Maybe with CVS support (see Sm
 
 ----------------------------------------------------------------------
 
+
+* bindings
+
+** zlib.  use it to implement direct ZIP-file access in VFS.
+
+** IPv6.  Not hard to do.
+
+** rss.  would provide cool examples of XML.
+
+----------------------------------------------------------------------
+
 * code auditing
 
 ** check endian-cleanness of ByteStream's float and double I/O.
@@ -77,18 +91,11 @@ outside #new and so on).
 ** follow the implementation lines of compiler/STLoader.st to implement
 SIF file-in.
 
-** implement a better packaging system allowing zipped source files with
-XML package descriptions to be delivered and installed.  Investigate
-using fastjar from gcj, and basing it on the Virtual File System
-infrastructure.
-
 ** make the smalltalk cpp work - nothing less, nothing more ;-)
 
 ** print entities correctly in the URIResolver.  A file named abc&def
 should print abc&def in the file list.
 
-** support IPv6.  Not hard to do.
-
 
 * emacs mode
 


--- orig/compiler/STLoader.st
+++ mod/compiler/STLoader.st
@@ -69,21 +69,31 @@ toEvaluate: interpretedSelector perform:
 
 !STInterpreter methodsFor: 'overrides'!
 
+evaluationMethodFor: selector
+    | method class |
+    class := self class.
+    [
+        class evaluationMethods isNil ifFalse: [
+            method := class evaluationMethods at: selector ifAbsent: [ nil ].
+           method isNil ifFalse: [ ^method ].
+       ].
+       class == STInterpreter ifTrue: [ ^#unknownTo:selector:arguments: ].
+       class := class superclass
+    ] repeat
+!
+
 evaluateStatement: node
-    | receiver selector argumentNodes result |
-    receiver := node receiver.
-    selector := node selector.
-    argumentNodes := node arguments.
-
-    result := false.
-    self class evaluationMethods at: selector ifPresent: [ :method |
-       result := self
-           perform: method
-           with: receiver
-           with: selector
-           with: argumentNodes ].
+    | method |
+    method := self evaluationMethodFor: node selector.
+    ^self
+       perform: method
+       with: node receiver
+       with: node selector
+       with: node arguments
+!
 
-    ^result
+unknownTo: receiver selector: selector arguments: argumentNodes
+    ^false
 !
 
 evaluate: node
@@ -101,9 +111,15 @@ evaluate: node
 
 initialize
     self
+       toEvaluate: #subclass:
+       perform: #doSubclass:selector:arguments:;
+
        toEvaluate: 
#subclass:instanceVariableNames:classVariableNames:poolDictionaries:category:
        perform: #doSubclass:selector:arguments:;
 
+       toEvaluate: 
#variable:subclass:instanceVariableNames:classVariableNames:poolDictionaries:category:
+       perform: #doSubclass:selector:arguments:;
+
        toEvaluate: 
#variableSubclass:instanceVariableNames:classVariableNames:poolDictionaries:category:
        perform: #doSubclass:selector:arguments:;
 
@@ -122,11 +138,23 @@ initialize
        toEvaluate: #current:
        perform: #doSetNamespace:selector:arguments:;
 
+       toEvaluate: #import:
+       perform: #doImport:selector:arguments:;
+
+       toEvaluate: #category:
+       perform: #doSend:selector:arguments:;
+
        toEvaluate: #comment:
-       perform: #doComment:selector:arguments:;
+       perform: #doSend:selector:arguments:;
+
+       toEvaluate: #shape:
+       perform: #doSend:selector:arguments:;
+
+       toEvaluate: #addClassVarName:
+       perform: #doSend:selector:arguments:;
 
        toEvaluate: #instanceVariableNames:
-       perform: #doClassInstVars:selector:arguments:
+       perform: #doSend:selector:arguments:
 ! !
 
 !STClassLoader class methodsFor: 'instance creation'!
@@ -193,26 +221,26 @@ doSubclass: receiver selector: selector 
     ^false
 !
 
-doComment: receiver selector: selector arguments: argumentNodes
-    | class |
+doSend: receiver selector: selector arguments: argumentNodes
+    | isClass class |
     (argumentNodes allSatisfy: [ :each | each isLiteral ])
        ifFalse: [ ^false ].
 
-    class := self resolveClass: receiver.
-    class comment: argumentNodes first value.
+    isClass := receiver isMessage and: [ receiver selector = #class ].
+    class := isClass
+       ifTrue: [ (self resolveClass: receiver receiver) asMetaclass ]
+       ifFalse: [ self resolveClass: receiver ].
+
+    class perform: selector with: argumentNodes first value.
     ^false
 !
 
-doClassInstVars: receiver selector: selector arguments: argumentNodes
-    | class |
-    (argumentNodes allSatisfy: [ :each | each isLiteral ])
-       ifFalse: [ ^false ].
-
-    receiver isMessage ifFalse: [ ^false ].
-    receiver selector = #class ifFalse: [ ^false ].
-
+doImport: receiver selector: selector arguments: argumentNodes
+    | class namespace |
+    receiver isMessage ifTrue: [ ^false ].
     class := self resolveClass: receiver.
-    class instanceVariableNames: argumentNodes first value.
+    namespace := self resolveNamespace: argumentNodes first.
+    class import: namespace.
     ^false
 !
 


--- orig/compiler/STLoaderObjs.st
+++ mod/compiler/STLoaderObjs.st
@@ -139,7 +139,7 @@ by an STClassLoader.'!
 
 LoadedBehavior subclass: #LoadedClass
         instanceVariableNames: 'name category sharedPools classVars class
-                               environment kind '
+                               environment shape '
         classVariableNames: ''
         poolDictionaries: ''
         category: 'System-Compiler'!
@@ -210,7 +210,7 @@ variableByteSubclass: s instanceVariable
        classVariableNames: cvn
        poolDictionaries: pd
        category: c
-       kind: 'variableByteSubclass:'
+       shape: #byte
        loader: loader!
  
 variableWordSubclass: s instanceVariableNames: ivn classVariableNames: cvn
@@ -223,7 +223,20 @@ variableWordSubclass: s instanceVariable
        classVariableNames: cvn
        poolDictionaries: pd
        category: c
-       kind: 'variableWordSubclass:'
+       shape: #word
+       loader: loader!
+ 
+variable: shape subclass: s instanceVariableNames: ivn classVariableNames: cvn
+       poolDictionaries: pd category: c
+
+    ^LoadedClass
+       superclass: self
+       name: s
+       instanceVariableNames: ivn
+       classVariableNames: cvn
+       poolDictionaries: pd
+       category: c
+       shape: shape
        loader: loader!
  
 variableSubclass: s instanceVariableNames: ivn classVariableNames: cvn
@@ -236,7 +249,7 @@ variableSubclass: s instanceVariableName
        classVariableNames: cvn
        poolDictionaries: pd
        category: c
-       kind: 'variableSubclass:'
+       shape: #pointer
        loader: loader!
  
 subclass: s instanceVariableNames: ivn classVariableNames: cvn
@@ -249,7 +262,19 @@ subclass: s instanceVariableNames: ivn c
        classVariableNames: cvn
        poolDictionaries: pd
        category: c
-       kind: 'subclass:'
+       shape: nil
+       loader: loader!
+
+subclass: s
+
+    ^LoadedClass
+       superclass: self
+       name: s
+       instanceVariableNames: ''
+       classVariableNames: ''
+       poolDictionaries: ''
+       category: ''
+       shape: nil
        loader: loader!
 
 !PseudoBehavior methodsFor: 'method dictionary services'!
@@ -520,6 +545,14 @@ asMetaclass
     self subclassResponsibility
 !
 
+category
+    self subclassResponsibility
+!
+
+category: aString
+    self subclassResponsibility
+!
+
 comment
     self subclassResponsibility
 !
@@ -528,6 +561,14 @@ comment: aString
     self subclassResponsibility
 !
 
+shape
+    self subclassResponsibility
+!
+
+shape: aSymbol
+    self subclassResponsibility
+!
+
 environment
     self subclassResponsibility
 !
@@ -604,6 +645,14 @@ isClass
     ^true
 !
 
+category
+    ^self asClass category
+!
+
+category: aString
+    ^self asClass category: aString
+!
+
 comment
     ^self asClass comment
 !
@@ -651,6 +700,10 @@ instVarNames
     ^instVars
 !
 
+instanceVariableNames: ivn
+    instVars := (TokenStream on: ivn) contents.
+!
+
 superclass
     ^superclass
 !
@@ -674,10 +727,6 @@ isMetaclass
     ^true
 !
 
-instanceVariableNames: ivn
-    instVars := (TokenStream on: ivn) contents.
-!
-
 asClass
     ^instanceClass
 !
@@ -712,8 +761,8 @@ environment
     ^self asClass environment
 !
 
-kindOfSubclass
-    ^'subclass:'
+shape
+    ^nil
 !
 
 classVarNames
@@ -752,10 +801,10 @@ for: aClass
 !LoadedClass class methodsFor: 'creating classes'!
 
 superclass: sup name: s instanceVariableNames: ivn classVariableNames: cvn
-       poolDictionaries: pd category: c kind: kind loader: loader
+       poolDictionaries: pd category: c shape: sh loader: loader
     ^self new
        superclass: sup name: s instanceVariableNames: ivn classVariableNames: 
cvn
-       poolDictionaries: pd category: c kind: kind loader: loader
+       poolDictionaries: pd category: c shape: sh loader: loader
 ! !
 
 !LoadedClass methodsFor: 'accessing'!
@@ -782,6 +831,21 @@ category
     ^category
 !
 
+category: aString
+    "Set the class category"
+    category := aString
+!
+
+shape
+    "Answer the class shape"
+    ^shape
+!
+
+shape: aSymbol
+    "Set the class shape"
+    shape := aSymbol
+!
+
 comment
     "Answer the class comment"
     ^comment
@@ -798,8 +862,11 @@ environment
 !
 
 kindOfSubclass
-    ^kind
-!
+    "Return a string indicating the type of class the receiver is"
+    self isVariable ifFalse: [ ^'subclass:' ].
+    self isPointers ifTrue: [ ^'variableSubclass:' ].
+    ^'variable: ', self shape storeString, 'subclass:'
+! 
 
 classVarNames
     "Answer the names of the variables in the class pool dictionary"
@@ -811,6 +878,18 @@ sharedPools
     "Return the names of the shared pools defined by the class"
 
     ^sharedPools
+!
+
+addClassVarName: aString
+    "Return the names of the shared pools defined by the class"
+
+    sharedPools := sharedPools copyWith: aString
+!
+
+import: aNamespace
+    "Return the names of the shared pools defined by the class"
+
+    sharedPools := sharedPools copyWith: (aNamespace nameIn: self environment)
 ! !
 
 !LoadedClass methodsFor: 'filing'!
@@ -903,12 +982,12 @@ fileOutOn: aFileStream
 !LoadedClass methodsFor: 'initializing'!
 
 superclass: sup name: s instanceVariableNames: ivn classVariableNames: cvn
-       poolDictionaries: pd category: c kind: k loader: loader
+       poolDictionaries: pd category: c shape: sh loader: loader
     self initialize: loader.
     superclass := sup.
     name := s.
     category := c.
-    kind := k.
+    shape := sh.
     environment := loader currentNamespace.
     class := LoadedMetaclass new for: self.
     instVars := (TokenStream on: ivn) contents.


--- orig/kernel/Behavior.st
+++ mod/kernel/Behavior.st
@@ -904,7 +904,7 @@ inheritsFrom: aClass
 kindOfSubclass
     "Return a string indicating the type of class the receiver is"
     self isVariable ifFalse: [ ^'subclass:' ].
-    self isPointers ifFalse: [ ^'variableSubclass:' ].
+    self isPointers ifTrue: [ ^'variableSubclass:' ].
     ^'variable: ', self shape storeString, 'subclass:'
 !