[Help-smalltalk] [PATCH] more scripting changes

[Paolo Bonzini]

This is mostly preparatory work for the conversion tool.

One syntax change is that we now use

Foo subclass: Bar [
    Bar class [
    ]
]

instead of

Foo subclass: Bar [
    Class protocol [
    ]
]

to switch to the class side and define class methods.

Paolo

2007-05-25  Daniele Sciascia  <address@hidden>

        * compiler/RBFormatter.st: fix various bugs.  Reformat method comments.
        Support varying the overall indentation.
        * compiler/RBParseNodes.st: store category in RBMethodNode.
        * compiler/RBParser.st: support storing a method category.  Rewrite
        parseDoits to deal with comments correctly (almost).
        * compiler/RBToken.st: fix bug in handling of #{...}.
        * compiler/STLoader.st: Replace #unknownTo:selector:arguments:
        with #unknown:.  Store a proxy for the nil superclass.  Add various
        methods used by the converter.
        * compiler/STLoaderObjs.st: Add ProxyNilClass.  Store selector in
        LoadedMethod.  Add various #copyEmpty: methods.

        * libgst/dict.c: Turn _gst_find_shared_pool_variable into
        _gst_namespace_association_at, add _gst_namespace_at.
        * libgst/dict.h: Declare it.
        * libgst/gst-parse.c: Support attributes both before and after
        temporaries.  Improve error recovery.  Set the correct namespace
        when extending a class.  Fix error locations.  Support class
        definition in a namespace definition.  Replace "Class protocol" with
        "Foo class".  Support subclassing nil.  Lookup classes in the
        superspaces too.
        * libgst/sym.c: Use _gst_namespace_association_at.



--- orig/compiler/RBFormatter.st
+++ mod/compiler/RBFormatter.st
@@ -17,7 +17,7 @@
 
 
 RBProgramNodeVisitor subclass: #RBFormatter
-    instanceVariableNames: 'codeStream lineStart firstLineLength tabs '
+    instanceVariableNames: 'codeStream lineStart firstLineLength tabs 
initialIndent '
     classVariableNames: ''
     poolDictionaries: ''
     category: 'Refactory-Parser'!
@@ -35,6 +35,13 @@ format: aNode 
     self visitNode: aNode.
     ^codeStream contents!
 
+initialIndent
+    initialIndent isNil ifTrue: [ initialIndent := 0 ].
+    ^initialIndent!
+
+initialIndent: anInteger
+    initialIndent := anInteger!
+
 isMultiLine
     ^firstLineLength notNil!
 
@@ -129,15 +136,30 @@ selectorsToStartOnNewLine
 
 !RBFormatter methodsFor: 'private-formatting'!
 
-formatLiteral: aValue 
-    | isArray |
-    (isArray := aValue class == Array) | (aValue class == ByteArray) ifTrue: 
-           [codeStream nextPutAll: (isArray ifTrue: ['#('] ifFalse: ['#[']).
-           aValue
-               do: [:each | self formatLiteral: each]
-               separatedBy: [codeStream nextPut: $ ].
-           codeStream nextPut: (isArray ifTrue: [$)] ifFalse: [$]]).
+formatLiteral: token 
+    | isArray aValue |
+    
+    aValue := token value.
+
+    token isCompileTimeBound ifTrue: 
+           [codeStream nextPutAll: '#{';
+               nextPutAll: aValue;
+               nextPut: $}.
            ^self].
+       aValue class == Array ifTrue: 
+                   [codeStream nextPutAll: '#('.
+                   aValue
+                               do: [:each | self formatLiteral: each]
+                               separatedBy: [codeStream nextPut: $ ].
+                   codeStream nextPut: $).
+                   ^self].
+       aValue class == ByteArray ifTrue: 
+                   [codeStream nextPutAll: '#['.
+                   aValue
+                               do: [:each | codeStream store: each]
+                               separatedBy: [codeStream nextPut: $ ].
+                       codeStream nextPut: $].
+                       ^self].
     aValue isSymbol ifTrue: 
            [self formatSymbol: aValue.
            ^self].
@@ -145,6 +167,11 @@ formatLiteral: aValue 
            [codeStream nextPut: $$;
                nextPut: aValue.
            ^self].
+    aValue class == String ifTrue: 
+           [codeStream nextPut: $';
+               nextPutAll: (aValue copyReplaceAll: '''' with: '''''');
+               nextPut: $'.
+           ^self].
     aValue storeOn: codeStream!
 
 formatMessage: aMessageNode cascade: cascadeBoolean 
@@ -194,6 +221,19 @@ formatMessageSelector: selectorParts wit
                        nextPutAll: (formattedArgs at: i).
                    (multiLine and: [i < formattedArgs size]) ifTrue: [self 
indent]]]!
 
+formatComment: aString
+    | stream |
+    stream := ReadStream on: aString
+       from: (aString findFirst: [ :each | each = $" ]) + 1
+       to: (aString findLast: [ :each | each = $" ]) - 1.
+    stream atEnd ifTrue: [ ^self ].
+    codeStream nextPut: $".
+    stream linesDo: [ :each |
+       codeStream nextPutAll: each trimSeparators.
+       stream atEnd ifFalse: [
+           self indent. codeStream space ] ].
+    codeStream nextPut: $"!
+
 formatMethodCommentFor: aNode indentBefore: aBoolean 
     | source |
     source := aNode source.
@@ -201,8 +241,8 @@ formatMethodCommentFor: aNode indentBefo
     aNode comments do: 
            [:each | 
            aBoolean ifTrue: [self indent].
-           codeStream nextPutAll: (aNode source copyFrom: each first to: each 
last);
-               nl.
+           self formatComment: (aNode source copyFrom: each first to: each 
last).
+           codeStream nl.
            aBoolean ifFalse: [self indent]]!
 
 formatMethodPatternFor: aMethodNode 
@@ -210,7 +250,8 @@ formatMethodPatternFor: aMethodNode 
     selectorParts := aMethodNode selectorParts.
     arguments := aMethodNode arguments.
     arguments isEmpty
-       ifTrue: [codeStream nextPutAll: selectorParts first value]
+       ifTrue: [codeStream nextPutAll: selectorParts first value;
+                           nextPut: $ ]
        ifFalse: 
            [selectorParts with: arguments
                do: 
@@ -230,7 +271,7 @@ formatStatementCommentFor: aNode 
            crs := self newLinesFor: source startingAt: each first.
            (crs - 1 max: 0) timesRepeat: [codeStream nl].
            crs == 0 ifTrue: [codeStream tab] ifFalse: [self indent].
-           codeStream nextPutAll: (source copyFrom: each first to: each last)]!
+           self formatComment: (source copyFrom: each first to: each last)]!
 
 formatStatementsFor: aSequenceNode 
     | statements |
@@ -367,12 +408,7 @@ acceptCascadeNode: aCascadeNode 
                separatedBy: [codeStream nextPut: $;]]!
 
 acceptLiteralNode: aLiteralNode 
-    aLiteralNode isCompileTimeBound ifTrue: 
-           [codeStream nextPutAll: '#{';
-               nextPutAll: aLiteralNode value;
-               nextPut: $}.
-           ^self].
-    ^self formatLiteral: aLiteralNode value!
+    ^self formatLiteral: aLiteralNode token!
 
 acceptMessageNode: aMessageNode 
     | newFormatter code |
@@ -387,11 +423,24 @@ acceptMessageNode: aMessageNode 
 
 acceptMethodNode: aMethodNode 
     self formatMethodPatternFor: aMethodNode.
-    self indentWhile: 
+    codeStream nextPut: $[.
+
+    self indent: self initialIndent while: [
+        self indentWhile: 
            [self formatMethodCommentFor: aMethodNode indentBefore: true.
+
+            (aMethodNode category isNil)
+                 ifFalse: [
+                   self indent.
+                   codeStream nextPutAll: '<category: ';
+                                  print: (aMethodNode category);
+                                  nextPut: $> ] .
+       
            self indent.
-           aMethodNode body statements isEmpty 
-               ifFalse: [self visitNode: aMethodNode body]]!
+           self visitNode: aMethodNode body ].
+               
+       self indent.
+       codeStream nextPut: $] ]!
 
 acceptOptimizedNode: anOptimizedNode 
     codeStream nextPutAll: '##('.
@@ -404,8 +453,10 @@ acceptReturnNode: aReturnNode 
 
 acceptSequenceNode: aSequenceNode 
     | parent |
-    self formatMethodCommentFor: aSequenceNode indentBefore: false.
-    self formatTemporariesFor: aSequenceNode.
+    aSequenceNode statements isEmpty ifFalse: [
+        self formatMethodCommentFor: aSequenceNode indentBefore: false.
+        self formatTemporariesFor: aSequenceNode.
+    ].
     parent := aSequenceNode parent.
     (parent notNil and: [parent isMethod]) ifTrue: [self formatTagFor: parent].
     self formatStatementsFor: aSequenceNode!


--- orig/compiler/RBParseNodes.st
+++ mod/compiler/RBParseNodes.st
@@ -900,7 +900,7 @@ RBStatementNode class
 
 
 RBProgramNode subclass: #RBMethodNode
-    instanceVariableNames: 'selector selectorParts body source arguments tags '
+    instanceVariableNames: 'selector selectorParts body source arguments tags 
category'
     classVariableNames: ''
     poolDictionaries: ''
     category: 'Refactory-Parser'!
@@ -1015,7 +1015,13 @@ tags
     ^tags isNil ifTrue: [#()] ifFalse: [tags]!
 
 tags: aCollectionOfIntervals 
-    tags := aCollectionOfIntervals! !
+    tags := aCollectionOfIntervals! 
+    
+category
+    ^category!
+
+category: aCategory
+    category := aCategory! !
 
 !RBMethodNode methodsFor: 'comparing'!
 


--- orig/compiler/RBParser.st
+++ mod/compiler/RBParser.st
@@ -17,7 +17,7 @@
 
 
 Object subclass: #RBParser
-    instanceVariableNames: 'scanner currentToken nextToken errorBlock tags 
source '
+    instanceVariableNames: 'scanner currentToken nextToken errorBlock tags 
source methodCategory'
     classVariableNames: ''
     poolDictionaries: ''
     category: 'Refactory-Parser'!
@@ -26,6 +26,12 @@ Object subclass: #RBParser
 
 !RBParser methodsFor: 'accessing'!
 
+methodCategory
+    ^methodCategory !
+    
+methodCategory: aCategory
+    methodCategory := aCategory !
+
 errorBlock: aBlock 
     errorBlock := aBlock.
     scanner notNil ifTrue: [scanner errorBlock: aBlock]!
@@ -255,14 +261,34 @@ parseDoits
     " Parses the stuff to be executed until a
         ! <class expression> methodsFor: <category string> ! "
 
-    | node |
+    | node method start stop comments asd |
 
     [
-       self atEnd ifTrue: [ ^false ].
+               self atEnd ifTrue: [ ^false ].
+               comments := scanner getComments.
+               start := comments isNil
+               ifTrue: [ asd := true. currentToken start - 2 ]
+               ifFalse: [ asd := false. comments first first - 2 ].
+               
+               tags := nil.
         node := self parseStatements: false.
+        comments notNil
+            ifTrue: [ node comments isNil ifTrue: [ node comments: #() ].
+                         node comments: comments, node comments ].
+
+        "One -1 accounts for base-1 vs. base-0 (as above), the
+         other drops the bang because we have a one-token lookahead."
+               stop := currentToken start - 2.
+
+        method := RBMethodNode selectorParts: #() arguments: #().
+        method source: (scanner stream segmentFrom: start to: stop).
+        node parent: method.
+
         self step.           "gobble doit terminating bang"
-       node statements size > 0 and: [ self evaluate: node ]
+               node statements size > 0 and: [ self evaluate: node ]
+               
     ]   whileFalse.
+
     ^true
 !
 
@@ -311,6 +337,7 @@ parseMethod
     self addCommentsTo: methodNode.
     methodNode body: (self parseStatements: true).
     methodNode tags: tags.
+    methodNode category: methodCategory.
     ^methodNode!
 
 parseMethodDefinitionList
@@ -552,13 +579,20 @@ parseExpression: aString onError: aBlock
     ^(node statements size == 1 and: [node temporaries isEmpty])
        ifTrue: [node statements first]
        ifFalse: [node]!
-
+    
 parseMethod: aString 
-    ^self parseMethod: aString onError: nil!
+    ^self parseMethod: aString category: nil onError: nil!
+    
+parseMethod: aString category: aCategory
+    ^self parseMethod: aString category: aCategory onError: nil!
 
 parseMethod: aString onError: aBlock 
+    ^self parseMethod: aString category: nil onError: aBlock!
+    
+parseMethod: aString category: aCategory onError: aBlock 
     | parser |
     parser := self new.
+    parser methodCategory: aCategory.
     parser errorBlock: aBlock.
     parser initializeParserWith: aString type: #on:errorBlock:.
     ^parser parseMethod: aString!


--- orig/compiler/RBToken.st
+++ mod/compiler/RBToken.st
@@ -241,7 +241,7 @@ compiler: aCompiler
     compiler := aCompiler!
 
 isCompileTimeBound
-    ^false!
+    ^true!
 
 realValue
     association notNil ifTrue: [ ^association ].


--- orig/compiler/STLoader.st
+++ mod/compiler/STLoader.st
@@ -44,7 +44,7 @@ STInterpreter comment:
 file-in.'!
 
 STInterpreter subclass: #STClassLoader
-       instanceVariableNames: 'loadedClasses proxies currentClass
+       instanceVariableNames: 'loadedClasses proxies proxyNilClass currentClass
                               currentCategory currentNamespace'
        classVariableNames: ''
        poolDictionaries: 'STClassLoaderObjects'
@@ -77,7 +77,7 @@ evaluationMethodFor: selector
             method := class evaluationMethods at: selector ifAbsent: [ nil ].
            method isNil ifFalse: [ ^method ].
        ].
-       class == STInterpreter ifTrue: [ ^#unknownTo:selector:arguments: ].
+       class == STInterpreter ifTrue: [ ^nil ].
        class := class superclass
     ] repeat
 !
@@ -85,15 +85,13 @@ evaluationMethodFor: selector
 evaluateStatement: node
     | method |
     method := self evaluationMethodFor: node selector.
-    ^self
-       perform: method
-       with: node receiver
-       with: node selector
-       with: node arguments
-!
-
-unknownTo: receiver selector: selector arguments: argumentNodes
-    ^false
+    (method isNil)
+        ifTrue: [ ^self unknown: node ]
+        ifFalse: [ ^self
+                       perform: method
+                       with: node receiver
+                       with: node selector
+                       with: node arguments ]
 !
 
 evaluate: node
@@ -103,8 +101,12 @@ evaluate: node
            "We *do not* want short-circuit evaluation here!!"
             each isMessage
                ifTrue: [ old | (self evaluateStatement: each) ]
-               ifFalse: [ old ]
+               ifFalse: [ self unknown: each ]
         ]
+!
+
+unknown: node
+    ^false
 ! !
 
 !STClassLoader class methodsFor: 'accessing'!
@@ -171,6 +173,10 @@ currentNamespace
 currentNamespace: ns
     currentNamespace := ns!
 
+proxyNilClass
+    proxyNilClass isNil ifTrue: [ proxyNilClass := ProxyNilClass on: nil for: 
self ].
+    ^proxyNilClass!
+    
 proxyForNamespace: anObject
     ^proxies at: anObject ifAbsentPut: [
        ProxyNamespace on: anObject for: self ]!
@@ -181,10 +187,14 @@ proxyForClass: anObject
 
 !STClassLoader methodsFor: 'initializing'!
 
+defaultNamespace
+    ^Namespace current
+!
+
 initialize
-    loadedClasses := OrderedCollection new.
+    loadedClasses := OrderedSet new.
     proxies := IdentityDictionary new.
-    currentNamespace := self proxyForNamespace: Namespace current.
+    currentNamespace := self proxyForNamespace: self defaultNamespace.
 ! !
 
 !STClassLoader methodsFor: 'overrides'!
@@ -198,26 +208,38 @@ endMethodList
     currentClass := nil
 !
 
+defineMethod: node 
+    ^currentClass methodDictionary
+        at: (node selector asSymbol)
+        put: (LoadedMethod
+                category: currentCategory
+                source: (node source)
+                selector: (node selector asSymbol))
+!
+
 compile: node
-    currentClass methodDictionary
-       at: node selector asSymbol
-       put: (LoadedMethod
-           category: currentCategory
-           source: node source)
+    self defineMethod: node.
 ! !
 
 !STClassLoader methodsFor: 'evaluating statements'!
 
-doSubclass: receiver selector: selector arguments: argumentNodes
+defineSubclass: receiver selector: selector arguments: argumentNodes
     | class arguments newClass |
-    (argumentNodes allSatisfy: [ :each | each isLiteral ])
-       ifFalse: [ ^false ].
-
+    
     class := self resolveClass: receiver.
     arguments := argumentNodes collect: [ :each | each value ].
     newClass := class perform: selector withArguments: arguments asArray.
     loadedClasses add: newClass.
     proxies at: newClass put: newClass.
+    ^newClass
+!
+
+doSubclass: receiver selector: selector arguments: argumentNodes
+   
+    (argumentNodes allSatisfy: [ :each | each isLiteral ])
+       ifFalse: [ ^false ].
+    
+    self defineSubclass: receiver selector: selector arguments: argumentNodes.
     ^false
 !
 
@@ -278,7 +300,10 @@ resolveClass: node
     | object |
     (node isMessage and: [ node selector = #class ])
        ifTrue: [ ^(self resolveClass: node receiver) asMetaclass ].
-
+    node isLiteral ifTrue: [
+        "Dictionary cannot have nil as a key, use the entire RBLiteralNode."
+        ^self proxyNilClass ].
+        
     object := self resolveName: node.
     object isClass ifFalse: [ ^object ].
 


--- orig/compiler/STLoaderObjs.st
+++ mod/compiler/STLoaderObjs.st
@@ -127,6 +127,15 @@ STClassLoader as a superclass while pars
 preexisting classes is necessary to correctly augment their subclasses
 with the new classes, and to handle extension methods.'!
 
+ProxyClass subclass: #ProxyNilClass
+        instanceVariableNames: ''
+        classVariableNames: ''
+        poolDictionaries: ''
+        category: 'System-Compiler'!
+
+ProxyClass comment:
+'This class represent a proxy for the nil fake superclass.'!
+
 PseudoBehavior subclass: #LoadedBehavior
         instanceVariableNames: 'instVars superclass methods comment '
         classVariableNames: ''
@@ -159,7 +168,7 @@ LoadedBehavior comment:
 by an STClassLoader.'!
 
 Object subclass: #LoadedMethod
-        instanceVariableNames: 'source category'
+        instanceVariableNames: 'source category selector'
         classVariableNames: ''
         poolDictionaries: ''
         category: 'System-Compiler'!
@@ -689,7 +698,13 @@ doesNotUnderstand: aMessage
 setProxy: aClass for: aSTClassLoader
     self initialize: aSTClassLoader.
     proxy := aClass.
-    self setSubclasses: aClass subclasses copy.
+    self setSubclasses: OrderedCollection new.
+! !
+
+!ProxyNilClass methodsFor: 'accessing'!
+
+nameIn: aNamespace
+    ^'nil'
 ! !
 
 !LoadedBehavior methodsFor: 'accessing'!
@@ -999,8 +1014,11 @@ superclass: sup name: s instanceVariable
 
 !LoadedMethod class methodsFor: 'instance creation'!
 
-category: category source: source
-    ^self new category: category source: source
+category: category source: source selector: selector
+    ^self new
+           category: category
+           source: source
+           selector: selector
 !
 
 !LoadedMethod methodsFor: 'accessing'!
@@ -1013,6 +1031,10 @@ methodSourceCode
     ^source
 !
 
+selector
+    ^selector
+!
+
 methodSourceString
     ^source asString
 ! !
@@ -1024,9 +1046,10 @@ discardTranslation
 
 !LoadedMethod methodsFor: 'initializing'!
 
-category: c source: s
+category: c source: s selector: sel
     category := c.
     source := s.
+    selector := sel.
 ! !
 
 !PseudoNamespace methodsFor: 'abstract'!
@@ -1062,11 +1085,16 @@ storeOn: aStream
 copyEmpty: newSize
     ^(super copyEmpty: newSize)
        setLoader: loader;
+       setSubspaces: subspaces;
        yourself
 !
 
 setLoader: aSTClassLoader
     loader := aSTClassLoader
+!
+
+setSubspaces: aSet
+    subspaces := aSet
 ! !
 
 !PseudoNamespace methodsFor: 'accessing'!
@@ -1098,6 +1126,13 @@ name: aSymbol in: aDictionary for: aSTCl
        environment: aDictionary;
        yourself)
 ! !
+
+!LoadedNamespace methodsFor: 'initializing'!
+copyEmpty: newSize
+    ^(super copyEmpty: newSize)
+        name: name;
+       yourself
+! !
  
 !LoadedNamespace methodsFor: 'accessing'!
 


--- orig/libgst/dict.c
+++ mod/libgst/dict.c
@@ -1431,8 +1431,8 @@ _gst_shared_pool_dictionary (OOP class_o
 
 
 OOP
-_gst_find_shared_pool_variable (OOP poolOOP,
-                               OOP symbol)
+_gst_namespace_association_at (OOP poolOOP,
+                              OOP symbol)
 {
   OOP assocOOP;
   gst_namespace pool;
@@ -1457,6 +1457,17 @@ _gst_find_shared_pool_variable (OOP pool
       poolOOP = pool->superspace;
     }
 }
+
+OOP
+_gst_namespace_at (OOP poolOOP,
+                  OOP symbol)
+{
+  OOP assocOOP = _gst_namespace_association_at (poolOOP, symbol);
+  if (IS_NIL (assocOOP))
+    return assocOOP;
+  else
+    return ASSOCIATION_VALUE (assocOOP);
+}
 
 
 size_t


--- orig/libgst/dict.h
+++ mod/libgst/dict.h
@@ -423,9 +423,16 @@ extern OOP _gst_class_variable_dictionar
   ATTRIBUTE_HIDDEN;
 
 /* This finds the key SYMBOL into the dictionary POOLOOP and, if any,
-   in all of its super-namespaces.  */
-extern OOP _gst_find_shared_pool_variable (OOP poolOOP,
-                                          OOP symbol)
+   in all of its super-namespaces.  Returns the association.  */
+extern OOP _gst_namespace_association_at (OOP poolOOP,
+                                         OOP symbol)
+  ATTRIBUTE_PURE 
+  ATTRIBUTE_HIDDEN;
+
+/* This finds the key SYMBOL into the dictionary POOLOOP and, if any,
+   in all of its super-namespaces.  Returns the value.  */
+extern OOP _gst_namespace_at (OOP poolOOP,
+                             OOP symbol)
   ATTRIBUTE_PURE 
   ATTRIBUTE_HIDDEN;
 


--- orig/libgst/gst-parse.c
+++ mod/libgst/gst-parse.c
@@ -97,7 +97,8 @@ static int filprintf (Filament *fil,
 /* Grammar productions.  */
 
 static void parse_chunks (gst_parser *p);
-static void parse_doit (gst_parser *p);
+static void parse_doit (gst_parser *p,
+                       mst_Boolean accept_bang);
 static mst_Boolean parse_scoped_definition (gst_parser *p, 
                                            tree_node first_stmt);
 
@@ -121,7 +122,8 @@ static void parse_method (gst_parser *p,
 static tree_node parse_message_pattern (gst_parser *p);
 static tree_node parse_keyword_variable_list (gst_parser *p);
 static tree_node parse_variable (gst_parser *p);
-static tree_node parse_attributes (gst_parser *p);
+static tree_node parse_attributes (gst_parser *p,
+                                 tree_node prev_attrs);
 static tree_node parse_attribute (gst_parser *p);
 static tree_node parse_temporaries (gst_parser *p,
                                    mst_Boolean implied_pipe);
@@ -352,7 +354,7 @@ parse_chunks (gst_parser *p) 
           if (p->state == PARSE_METHOD_LIST)
            parse_method_list (p);
           else
-           parse_doit (p);
+           parse_doit (p, true);
         }
       _gst_pop_temporaries_dictionary (oldTemporaries);
     }
@@ -435,7 +437,7 @@ recover_error (gst_parser *p)
    | empty */
 
 static void
-parse_doit (gst_parser *p)
+parse_doit (gst_parser *p, mst_Boolean accept_bang)
 {
   tree_node statement = NULL;
   mst_Boolean caret;
@@ -443,7 +445,7 @@ parse_doit (gst_parser *p)
   if (token (p, 0) == '|')
     parse_temporaries (p, false);
 
-  if (token (p, 0) == EOF)
+  if (token (p, 0) == EOF && accept_bang)
     return;
 
   caret = lex_skip_if (p, '^', false);
@@ -468,7 +470,8 @@ parse_doit (gst_parser *p)
 
   /* Do not lex until after _gst_free_tree, or we lose a token! */
   lex_skip_if (p, '.', false);
-  lex_skip_if (p, '!', false);
+  if (accept_bang)
+    lex_skip_if (p, '!', false);
 }
 
 
@@ -519,19 +522,40 @@ parse_scoped_definition (gst_parser *p, 
   else if (first_stmt->nodeType == TREE_UNARY_EXPR
           && first_stmt->v_expr.selector == _gst_intern_string ("extend"))
     {
-      
-      if (receiver->nodeType == TREE_VARIABLE_NODE)
-       classOOP = parse_class (receiver);
+      OOP namespace_old = _gst_current_namespace;
+      OOP classOrMetaclassOOP = NULL;
+      mst_Boolean ret_value;
 
+      _gst_register_oop (namespace_old);
+      if (receiver->nodeType == TREE_VARIABLE_NODE)
+       {
+         classOOP = parse_class (receiver);
+         classOrMetaclassOOP = classOOP;
+       }
       else if (receiver->nodeType == TREE_UNARY_EXPR
               && receiver->v_expr.selector == _gst_intern_string ("class"))
-       {
-         classOOP = parse_class (receiver->v_expr.receiver);
-         classOOP = OOP_CLASS (classOOP);
-       }
+       {
+         classOOP = parse_class (receiver->v_expr.receiver);
+         classOrMetaclassOOP = OOP_CLASS (classOOP);
+       }          
+      if (classOrMetaclassOOP != NULL) 
+       { 
+         OOP namespace_new = ((gst_class) OOP_TO_OBJ (classOOP))->environment; 
+         
+         /* When creating the image, current namespace is not available. */
+         if (namespace_new != namespace_old)
+           _gst_msg_sendf (NULL, "%v %o current: %o",
+                           _gst_namespace_class, namespace_new);
+         
+         ret_value = parse_class_definition (p, classOrMetaclassOOP);
 
-      if (classOOP != NULL)
-       return parse_class_definition (p, classOOP);
+         if (namespace_new != namespace_old)
+           _gst_msg_sendf (NULL, "%v %o current: %o",
+                           _gst_namespace_class, namespace_old);
+         
+         _gst_unregister_oop (namespace_old);
+         return ret_value;
+       }
     }
 
   _gst_errorf_at (first_stmt->location.first_line, 
@@ -579,8 +603,9 @@ parse_namespace_definition (gst_parser *
       _gst_msg_sendf (NULL, "%v %o current: %o", 
                      _gst_namespace_class, new_namespace);
       
-      parse_eval_definition (p);       
-      
+      while (token (p, 0) != ']' && token (p, 0) != EOF)
+        parse_doit (p, false); 
+
       _gst_msg_sendf (NULL, "%v %o current: %o",
                      _gst_namespace_class, old_namespace);
       
@@ -755,16 +780,22 @@ parse_class_definition (gst_parser *p, O
                  parse_scoped_method (p, classOOP);
                  continue;
                }
-             else if (t3 == '['
-                      && strcmp (val (p, 0)->sval, "Class") == 0
-                      && strcmp (val (p, 1)->sval, "protocol") == 0)
+             else if (t3 == '[' && strcmp (val (p, 1)->sval, "class") == 0)
                {
 #if 0
                  printf ("parse class protocol\n");
 #endif
                  if (_gst_object_is_kind_of (classOOP, _gst_metaclass_class))
                    {
-                     _gst_errorf ("already on class side, Class protocol 
invalid");
+                     _gst_errorf ("already on class side");
+                     _gst_had_error = true;
+                     continue;
+                   }
+                 else if (((gst_class) OOP_TO_OBJ (classOOP))->name
+                          != _gst_intern_string (val (p, 0)->sval))
+                   {
+                     _gst_errorf ("`%s class' invalid within %O",
+                                  val (p, 0)->sval, classOOP);
                      _gst_had_error = true;
                      continue;
                    }
@@ -785,7 +816,8 @@ parse_class_definition (gst_parser *p, O
 #if 0
              printf ("parse instance variables - ignore\n");
 #endif
-             lex_consume (p, 2);             
+             lex_consume (p, 2);
+             continue;
            }
          else if (t2 == IDENTIFIER) 
            {
@@ -868,11 +900,14 @@ parse_class (tree_node list) 
 {
   const char* name;
   OOP currentOOP = _gst_current_namespace;
-       
+
+  if (strcmp (list->v_list.name, "nil") == 0)
+      return _gst_nil_oop;
+  
   do
     {
       name = list->v_list.name;
-      currentOOP = dictionary_at (currentOOP, _gst_intern_string (name));
+      currentOOP = _gst_namespace_at (currentOOP, _gst_intern_string (name));
        
       if (currentOOP == _gst_nil_oop)
        {
@@ -918,7 +953,7 @@ parse_namespace (tree_node list) 
   while (list->v_list.next != NULL)
     {
       name = _gst_intern_string (list->v_list.name);   
-      current_namespace = dictionary_at (current_namespace, name);
+      current_namespace = _gst_namespace_at (current_namespace, name);
                
       if (current_namespace == _gst_nil_oop)
        {
@@ -997,7 +1032,7 @@ parse_method_list (gst_parser *p)
 static void
 parse_method (gst_parser *p, int at_end)
 {
-  tree_node pat, temps, attrs, stmts;
+  tree_node pat, temps, stmts, attrs = NULL;
   YYLTYPE current_pos;
   tree_node method;
 
@@ -1006,8 +1041,14 @@ parse_method (gst_parser *p, int at_end)
   if (at_end == ']')
     lex_skip_mandatory (p, '[');
 
+  if (token (p, 0) == '<')
+    attrs = parse_attributes (p, NULL);
+
   temps = parse_temporaries (p, false);
-  attrs = parse_attributes (p);
+
+  if (token (p, 0) == '<')
+    attrs = parse_attributes (p, attrs);
+
   stmts = parse_statements (p, NULL, true);
 
   /* Don't lex until _gst_free_tree, or we lose a token.  */
@@ -1121,18 +1162,16 @@ parse_variable (gst_parser *p)
    | KEYWORD binary_expr */
 
 static tree_node
-parse_attributes (gst_parser *p)
+parse_attributes (gst_parser *p, tree_node prev_attrs)
 {
-  tree_node attrs = NULL;
-
   while (token (p, 0) == '<')
     {
       tree_node attr = parse_attribute (p);
       if (attr)
-       attrs = _gst_add_node (attrs, attr);
+       prev_attrs = _gst_add_node (prev_attrs, attr);
     }
 
-  return attrs;
+  return prev_attrs;
 }
 
 static tree_node


--- orig/libgst/sym.c
+++ mod/libgst/sym.c
@@ -515,7 +515,7 @@ find_class_variable (OOP varName)
     {
       class = (gst_class) OOP_TO_OBJ (class_oop);
       assocOOP =
-       _gst_find_shared_pool_variable (class->environment, varName);
+       _gst_namespace_association_at (class->environment, varName);
       if (!IS_NIL (assocOOP))
        return (assocOOP);
     }
@@ -530,7 +530,7 @@ find_class_variable (OOP varName)
        {
          poolDictionaryOOP = ARRAY_AT (class->sharedPools, i + 1);
          assocOOP =
-           _gst_find_shared_pool_variable (poolDictionaryOOP, varName);
+           _gst_namespace_association_at (poolDictionaryOOP, varName);
          if (!IS_NIL (assocOOP))
            return (assocOOP);
        }
@@ -578,7 +578,7 @@ _gst_find_variable_binding (tree_node li
     {
       root = ASSOCIATION_VALUE (assocOOP);
       symbol = _gst_intern_string (list->v_list.name);
-      assocOOP = _gst_find_shared_pool_variable (root, symbol);
+      assocOOP = _gst_namespace_association_at (root, symbol);
     }
 
   if (IS_NIL (assocOOP) && !(list->v_list.next))


--- orig/tests/except.st
+++ mod/tests/except.st
@@ -31,7 +31,7 @@
 Notification subclass: MyException [
     <category: 'testing'>
 
-    Class protocol [
+    MyException class [
        | count |
 
        count [ ^count ]


--- orig/tests/getopt.st
+++ mod/tests/getopt.st
@@ -31,7 +31,7 @@
  ======================================================================"
 
 Getopt extend [
-    Class protocol [
+    Getopt class [
         test: args with: pattern [
             args do: [ :each |
                 self


--- orig/tests/objects.st
+++ mod/tests/objects.st
@@ -33,7 +33,7 @@ Object subclass: ObjectsTest [
 
     Messages := nil.
 
-    Class protocol [
+    ObjectsTest class [
        testCompaction [
            Messages := SortedCollection new.
            ObjectMemory compact.