[PATCH] prototype patch to fix mutate.st

This fixes one of the blockers for the release.  Basically:

- CompiledMethods remembers if they were old or new syntax

- #compile: only accepts methods with the new syntax

- #recompile is added to CompiledMethod

- a new #methodFormattedSourceString method was added which is used to
recompile old-syntax methods (and is only provided when Parser is
loaded, so old-syntax methods can only be recompiled if Parser is loaded)

- the C and STInST parsers was adapted to mark old-syntax methods
appropriately

- #parserClass was moved from Behavior to CompiledMethod.  While it is
all fine that different Behaviors have different Compilers, if we want
any tool to reason on the source code it *must* be standard Smalltalk
syntax.  Stephen's recent Presource examples show how far you can go
while remaining within those boundaries.  Even parsing could be done
using a syntax like this:

  term [
      <parse: #rule>
      factor save, ((#+ | #-) save, factor save) sequence
          -> [ :op1 :ops |
                ops inject: op1 into: [ :result :op |
                    result perform: op first with: op second ].
  ]

  factor [
      <parse: #rule>
      primary save,
      ((#* | (#/ -> #//) save, primary save) sequence
          -> [ :op1 :ops |
                ops inject: op1 into: [ :result :op |
                    result perform: op first with: op second ].
  ]

  primary [
      <parse: #rule>
      number save
      | #'(', term save, #')'
      -> [ :value | value ].

      identifier
      -> [ :name | vars at: name ].
  ]


Needs more testing, but unless someone screams that they don't like it
and suggest a better way, this will be committed.

Paolo

2007-10-14  Paolo Bonzini  <[hidden email]>
 
        * kernel/Behavior.st: Move recompilation methods to CompiledMethod.
        Move #instanceVariableNames: and related methods from ClassDescription.
        Change #updateInstanceVars:shape: to
        #updateInstanceVars:numInherited:shape:.
        * kernel/Builtins.st: Promote #instanceVariableNames: to Behavior.
        * kernel/CStruct.st: Compile methods as new syntax.
        * kernel/ClassDesc.st: Remove #instanceVariableNames: and related
        methods.
        * kernel/CompildMeth.st: Add #methodFormattedSourceString,
        #isOldSyntax, #noteOldSyntax, #recompile, #recompileNotifying:.
        Support recompiling methods from both syntaxes.
        * kernel/Metaclass.st: Change #updateInstanceVars:shape: to
        #updateInstanceVars:numInherited:shape:.
        * kernel/UndefObject.st: Add #instSize for polymorphism.

        * tests/mutate.st: Add new tests on class extension.
        * tests/mutate.ok: Update test results.

2007-10-14  Paolo Bonzini  <[hidden email]>

        * libgst/comp.c: Add brackets to source code of #methodsFor:.  
        Set isOldSyntax bit of the CompiledMethod header.
        * libgst/comp.h: Add isOldSyntax bit.
        * libgst/gst-parse.c: Parse isolated methods with new syntax.
        * libgst/tree.c: Add isOldSyntax argument to _gst_make_method.
        * libgst/tree.h: Likewise, and add it to AST.

packages/stinst/compiler:
2007-10-14  Paolo Bonzini  <[hidden email]>

        * StartCompiler.st: Remove #parserClass from Behavior.

packages/stinst/parser:
2007-10-14  Paolo Bonzini  <[hidden email]>

        * Exporter.st: Add #methodFormattedSourceString and use it.
        Add #parserClass.
        * GSTParser.st: Support adding more instance variables to a class.
        * RBParser.st: Add RBBracketedMethodParser.
        * SIFParser.st: Send #noteOldSyntax to compiled methods.
        * STFileParser.st: Return compiled methods from #compile:.  Add
        #resolveClass:.  Send #noteOldSyntax to compiled methods.
        * STLoader.st: Return compiled methods from #compile:.
        * STLoaderObjs.st: Add dummy #noteOldSyntax method to LoadedMethod.



* looking for [hidden email]--2004b/smalltalk--devo--2.2--patch-606 to compare with
* comparing to [hidden email]--2004b/smalltalk--devo--2.2--patch-606
M  packages/stinst/parser/STFileParser.st
M  packages/stinst/parser/Exporter.st
M  tests/testsuite.at
M  tests/testsuite
M  packages/stinst/compiler/ChangeLog
M  packages/stinst/parser/SIFParser.st
M  packages/stinst/parser/GSTParser.st
M  ChangeLog
M  packages/stinst/parser/ChangeLog
M  NEWS
M  packages/stinst/parser/RBParser.st
M  packages/stinst/parser/STLoader.st
M  packages/stinst/parser/STLoaderObjs.st
M  packages/stinst/compiler/StartCompiler.st
M  kernel/Behavior.st
M  kernel/Builtins.st
M  kernel/CStruct.st
M  kernel/ClassDesc.st
M  kernel/CompildMeth.st
M  kernel/Metaclass.st
M  kernel/UndefObject.st
M  libgst/ChangeLog
M  libgst/gst-parse.c
M  libgst/comp.c
M  libgst/comp.h
M  libgst/tree.c
M  libgst/tree.h
M  tests/mutate.ok
M  tests/mutate.st

* modified files

--- orig/NEWS
+++ mod/NEWS
@@ -66,6 +66,12 @@ o   The #writeStream method was moved do
 o   The database access library has been replaced by a new DBI-like library,
     contributed by Mike Anderson.
 
+o   In general, GNU Smalltalk is able to load files with the old syntax.
+    In some cases, however, it will be necessary to either convert them
+    using the gst-convert tool, or load the Parser package before them.
+    This is the case if you get a "not yet implemented" error while loading
+    the files.
+
 
 Packages improvements:
 


--- orig/kernel/Behavior.st
+++ mod/kernel/Behavior.st
@@ -54,7 +54,10 @@ method dictionary, and iterating over th
     ifTrue: [{symbol}]
     ifFalse: [instanceVariables copyWith: symbol].
  duplicated := self superclass allInstVarNames includes: symbol.
- self updateInstanceVars: newInstanceVariables shape: self shape.
+ self
+    updateInstanceVars: newInstanceVariables
+    numInherited: self superclass instSize
+    shape: self shape.
  duplicated ifTrue: [self compileAll].
  self compileAllSubclasses
     ]
@@ -73,12 +76,58 @@ method dictionary, and iterating over th
     copyReplaceFrom: index
     to: index
     with: #().
- self updateInstanceVars: newInstanceVariables shape: self shape.
+ self
+    updateInstanceVars: newInstanceVariables
+    numInherited: self superclass instSize
+    shape: self shape.
  self
     compileAll;
     compileAllSubclasses
     ]
 
+    instanceVariableNames: instVarNames [
+        "Set the instance variables for the receiver to be those
+         in instVarNames"
+
+        <category: 'instance variables'>
+        | variableArray oldInstVarNames |
+        variableArray := self parseInstanceVariableString: instVarNames.
+        variableArray := self subclassInstVarNames, variableArray.
+        oldInstVarNames := self allInstVarNames.
+
+        "If instance variables change, update  instance variables and
+         instance spec of the class and all its subclasses"
+        variableArray = oldInstVarNames ifTrue: [^self].
+        self
+    updateInstanceVars: variableArray
+    numInherited: self superclass instSize
+    shape: self shape.
+
+        "If no variable has been removed, no need to recompile"
+        (oldInstVarNames allSatisfy: [:each | variableArray includes: each])
+            ifTrue: [^self].
+        Transcript
+            nextPutAll: 'Recompiling classes...';
+            nl.
+        self compileAll.
+        self compileAllSubclasses
+    ]
+
+    parseInstanceVariableString: variableString [
+        <category: 'parsing class declarations'>
+        | variableArray |
+        variableArray := self parseVariableString: variableString.
+        ^variableArray collect: [:each | each asSymbol]
+    ]
+
+    parseVariableString: aString [
+        <category: 'parsing class declarations'>
+        | tokens |
+        tokens := aString subStrings asArray.
+        tokens do: [:token | self validateIdentifier: token].
+        ^tokens
+    ]
+
     createGetMethod: what default: value [
  "Create a method accessing the variable `what', with a default value
  of `value', using lazy initialization"
@@ -261,21 +310,7 @@ method dictionary, and iterating over th
  the new CompiledMethod if everything's ok."
 
  <category: 'method dictionary'>
- | source category ok |
- ok :=
- [source := self sourceCodeAt: selector.
- category := (self compiledMethodAt: selector) methodCategory.
- true]
- on: Error
- do: [:ex | ex return: false].
- ok ifFalse: [^nil].
- RegressionTesting
-    ifFalse:
- [Transcript
-    nextPutAll: 'Recompiling selector: ';
-    print: selector asSymbol;
-    nl].
- ^self compile: source classified: category
+ (self compiledMethodAt: selector) recompile.
     ]
 
     recompile: selector notifying: aNotifier [
@@ -284,24 +319,7 @@ method dictionary, and iterating over th
  compilation"
 
  <category: 'method dictionary'>
- | source category ok |
- ok :=
- [source := self sourceCodeAt: selector.
- category := (self compiledMethodAt: selector) methodCategory.
- true]
- on: Error
- do: [:ex | ex return: false].
- ok ifFalse: [^nil].
- RegressionTesting
-    ifFalse:
- [Transcript
-    nextPutAll: 'Recompiling selector: ';
-    print: selector asSymbol;
-    nl].
- ^self
-    compile: source
-    classified: category
-    notifying: aNotifier
+ (self compiledMethodAt: selector) recompileNotifying: aNotifier.
     ]
 
     decompile: selector [
@@ -364,7 +382,7 @@ method dictionary, and iterating over th
     nextPutAll: 'Recompiling class: ';
     print: self;
     nl].
- self methodDictionary keysDo: [:selector | self recompile: selector]]
+ self methodDictionary do: [:method | method recompile]]
     ]
 
     compileAll: aNotifier [
@@ -380,8 +398,7 @@ method dictionary, and iterating over th
     nextPutAll: 'Recompiling class: ';
     print: self;
     nl].
- self methodDictionary
-    keysDo: [:selector | self recompile: selector notifying: aNotifier]]
+ self methodDictionary do: [:method | method recompileNotifying: aNotifier]]
     ]
 
     evalString: aString to: anObject [
@@ -994,8 +1011,11 @@ method dictionary, and iterating over th
  [realShape := CSymbols.CLongSize = 4 ifTrue: [#uint] ifFalse: [#uint64]].
  shape = #inherit ifTrue: [realShape := self superclass shape].
  self shape == realShape ifTrue: [^false].
- realShape isNil
-    ifTrue: [^self updateInstanceVars: self allInstVarNames shape: nil].
+ realShape isNil ifTrue: [
+            self
+        updateInstanceVars: self allInstVarNames
+        numInherited: self superclass instSize
+        shape: nil ].
  self isVariable
     ifTrue:
  [SystemExceptions.MutationError
@@ -1317,15 +1337,13 @@ method dictionary, and iterating over th
  ^true
     ]
 
-    updateInstanceVars: variableArray shape: shape [
+    updateInstanceVars: variableArray numInherited: numInherited shape: shape [
  "Update instance variables and instance spec of the class and all
  its subclasses"
 
  <category: 'private'>
  | instVarMap startOfInstanceVars endOfInstanceVars newInstanceVars oldInstVars oldClass instances |
- startOfInstanceVars := self superclass isNil
-    ifTrue: [1]
-    ifFalse: [self superclass instSize + 1].
+ startOfInstanceVars := numInherited + 1.
  endOfInstanceVars := self instSize.
  newInstanceVars := variableArray copyFrom: startOfInstanceVars
     to: variableArray size.


--- orig/kernel/Builtins.st
+++ mod/kernel/Builtins.st
@@ -171,14 +171,14 @@ Class extend [
 ]
     
 ClassDescription extend [
-    instanceVariableNames: ivn [
-    ]
-
     import: aString [
     ]
 ]
     
 Behavior extend [
+    instanceVariableNames: ivn [
+    ]
+
     shape: aSymbol [
     ]
 ]


--- orig/kernel/CStruct.st
+++ mod/kernel/CStruct.st
@@ -130,7 +130,7 @@ CObject subclass: CCompound [
  maxAlignment := self superclass alignof.
  inspStr := WriteStream on: (String new: 8).
  inspStr
-    nextPutAll: 'inspectSelectorList';
+    nextPutAll: 'inspectSelectorList [';
     nl;
     nextPutAll: '    ^#('.
 
@@ -148,14 +148,18 @@ CObject subclass: CCompound [
  str := WriteStream on: (String new: 20).
  str
     nextPutAll: name;
+    nextPutAll: ' [';
     nl;
     nextPutAll: '    ^self at: ';
     print: offset;
     nextPutAll: ' type: ';
-    store: type.
+    store: type;
+    nl;
+    nextPut: $].
  self compile: str classified: 'accessing'.
  offset := offset + type sizeof].
- self compile: inspStr contents , ')' classified: 'debugging'.
+ inspStr nextPut: $); nl; nextPut: $].
+ self compile: inspStr contents classified: 'debugging'.
  self compileSize: offset align: maxAlignment
     ]
 
@@ -164,10 +168,12 @@ CObject subclass: CCompound [
 
  <category: 'subclass creation'>
  | sizeofMethod alignofMethod |
- sizeofMethod := 'sizeof
-    ^' , (size alignTo: alignment) printString.
- alignofMethod := 'alignof
-    ^' , alignment printString.
+ sizeofMethod := 'sizeof [
+    ^' , (size alignTo: alignment) printString, '
+]'.
+ alignofMethod := 'alignof [
+    ^' , alignment printString, '
+]'.
  self compile: sizeofMethod classified: 'accessing'.
  self class compile: sizeofMethod classified: 'accessing'.
  self compile: alignofMethod classified: 'accessing'.


--- orig/kernel/ClassDesc.st
+++ mod/kernel/ClassDesc.st
@@ -386,45 +386,5 @@ files.'>
  <category: 'parsing class declarations'>
  self addSharedPool: aDictionary
     ]
-
-    instanceVariableNames: instVarNames [
- "Set the instance variables for the receiver to be those
- in instVarNames"
-
- <category: 'parsing class declarations'>
- | variableArray variableString oldInstVarNames |
- variableArray := self parseInstanceVariableString: instVarNames.
- variableArray := self subclassInstVarNames , variableArray.
- oldInstVarNames := self allInstVarNames.
-
- "If instance variables change, update  instance variables and
- instance spec of the class and all its subclasses"
- variableArray = oldInstVarNames ifTrue: [^self].
- self updateInstanceVars: variableArray shape: self shape.
-
- "If no variable has been removed, no need to recompile"
- (oldInstVarNames allSatisfy: [:each | variableArray includes: each])
-    ifTrue: [^self].
- Transcript
-    nextPutAll: 'Recompiling classes...';
-    nl.
- self compileAll.
- self compileAllSubclasses
-    ]
-
-    parseInstanceVariableString: variableString [
- <category: 'parsing class declarations'>
- | variableArray |
- variableArray := self parseVariableString: variableString.
- ^variableArray collect: [:each | each asSymbol]
-    ]
-
-    parseVariableString: aString [
- <category: 'parsing class declarations'>
- | tokens |
- tokens := aString subStrings asArray.
- tokens do: [:token | self validateIdentifier: token].
- ^tokens
-    ]
 ]
 


--- orig/kernel/CompildMeth.st
+++ mod/kernel/CompildMeth.st
@@ -121,6 +121,13 @@ instances.'>
     ifFalse: [descriptor sourceCode]
     ]
 
+    methodFormattedSourceString [
+ "Answer the method source code as a string"
+
+ <category: 'basic'>
+ self notYetImplemented
+    ]
+
     methodSourceString [
  "Answer the method source code as a string"
 
@@ -248,7 +255,23 @@ instances.'>
  "Answer the primitive called by the receiver"
 
  <category: 'accessing'>
- ^(header bitShift: -17) bitAnd: 1023
+ ^(header bitShift: -17) bitAnd: 511
+    ]
+
+    isOldSyntax [
+ "Answer whether the method was written with the old (chunk-format)
+ syntax"
+
+ <category: 'accessing'>
+ ^((header bitShift: -26) bitAnd: 1) == 1
+    ]
+
+    noteOldSyntax [
+ "Remember that the method is written with the old (chunk-format)
+         syntax"
+
+        <category: 'accessing'>
+ header := header bitOr: (1 bitShift: 26)
     ]
 
     allLiterals [
@@ -301,6 +324,56 @@ instances.'>
     ifFalse: [anObject perform: self withArguments: args]
     ]
 
+    recompile [
+ "Recompile the method in the scope of the class where it leaves."
+
+ <category: 'compiling'>
+        | source category ok |
+        ok :=
+                [source := self isOldSyntax
+ ifTrue: [ self methodFormattedSourceString ]
+ ifFalse: [ self methodSourceString ].
+                category := self methodCategory.
+                true]
+                        on: Error
+                        do: [:ex | ex return: false].
+        ok ifFalse: [^nil].
+        RegressionTesting
+            ifFalse:
+                [Transcript
+                    nextPutAll: 'Recompiling selector: ';
+                    print: self selector asSymbol;
+                    nl].
+        ^self methodClass compile: source classified: category
+    ]
+
+    recompileNotifying: aNotifier [
+ "Recompile the method in the scope of the class where it leaves,
+ notifying errors to aNotifier by sending it #error:."
+
+ <category: 'compiling'>
+        | source category ok |
+        ok :=
+                [source := self isOldSyntax
+ ifTrue: [ self methodFormattedSourceString ]
+ ifFalse: [ self methodSourceString ].
+                category := self methodCategory.
+                true]
+                        on: Error
+                        do: [:ex | ex return: false].
+        ok ifFalse: [^nil].
+        RegressionTesting
+            ifFalse:
+                [Transcript
+                    nextPutAll: 'Recompiling selector: ';
+                    print: self selector asSymbol;
+                    nl].
+        ^self methodClass
+    compile: source
+    classified: category
+    notifying: aNotifier
+    ]
+
     isAnnotated [
  "If the receiver has any attributes, answer true."
 


--- orig/kernel/Metaclass.st
+++ mod/kernel/Metaclass.st
@@ -276,7 +276,10 @@ it should be...the Smalltalk metaclass s
     | needToRecompileMetaclasses) | (aClass shape ~~ realShape)
     ifTrue:
  [aClass instanceCount > 0 ifTrue: [ObjectMemory globalGarbageCollect].
- aClass updateInstanceVars: variableArray shape: realShape].
+ aClass
+    updateInstanceVars: variableArray
+    numInherited: superclass instSize
+    shape: realShape].
 
  "Now add/remove pool dictionaries.  FIXME: They may affect name binding,
  so we should probably recompile everything if they change."
@@ -299,8 +302,11 @@ it should be...the Smalltalk metaclass s
 
  self superclass allInstVarNames ~= superclass class allInstVarNames
     ifTrue:
- [aClass class updateInstanceVars: superclass class allInstVarNames
-    , aClass class instVarNames
+ [aClass class
+    updateInstanceVars:
+ superclass class allInstVarNames,
+ aClass class instVarNames
+    numInherited: superclass class instSize
     shape: aClass class shape].
 
  "Fix references between classes..."


--- orig/kernel/UndefObject.st
+++ mod/kernel/UndefObject.st
@@ -257,6 +257,11 @@ instance, which is the object "nil".'>
     yourself
     ]
 
+    instSize [
+ <category: 'class polymorphism'>
+ ^0
+    ]
+
     methodDictionary [
  <category: 'class polymorphism'>
  ^nil


--- orig/libgst/comp.c
+++ mod/libgst/comp.c
@@ -472,12 +472,12 @@ _gst_install_initial_methods (void)
   install_method (termination_method);
 
   methodsForString = "\
-methodsFor: aCategoryString \
+methodsFor: aCategoryString [\
     \"Calling this method prepares the parser to receive methods \
       to be compiled and installed in the receiver's method dictionary. \
       The methods are put in the category identified by the parameter.\" \
     <primitive: VMpr_Behavior_methodsFor> \
-";
+]";
   _gst_set_compilation_class (_gst_behavior_class);
   _gst_set_compilation_category (_gst_string_new ("compiling methods"));
   _gst_push_smalltalk_string (_gst_string_new (methodsForString));
@@ -662,7 +662,7 @@ _gst_execute_statements (tree_node temps
   methodOOP =
     _gst_compile_method (_gst_make_method (&statements->location, &loc,
    messagePattern, temps, NULL,
-   statements),
+   statements, false),
  true, false);
 
   SET_CLASS_ENVIRONMENT (_gst_undefined_object_class,
@@ -793,6 +793,7 @@ _gst_compile_method (tree_node method,
   int primitiveIndex;
   int stack_depth;
   inc_ptr incPtr;
+  gst_compiled_method compiledMethod;
 
   dup_message_receiver = false;
   literal_vec_curr = literal_vec;
@@ -900,6 +901,9 @@ _gst_compile_method (tree_node method,
  _gst_this_category,
  method->location.file_offset,
  method->v_method.endPos);
+
+      compiledMethod = (gst_compiled_method) OOP_TO_OBJ (methodOOP);
+      compiledMethod->header.isOldSyntax = method->v_method.isOldSyntax;
       INC_ADD_OOP (methodOOP);
 
       if (install)
@@ -2689,6 +2693,7 @@ _gst_make_new_method (int primitiveIndex
   inc_ptr incPtr;
 
   maximumStackDepth += numArgs + numTemps;
+  memset (&header, 0, sizeof (method_header));
 
   incPtr = INC_SAVE_POINTER ();
   if (primitiveIndex)
@@ -2867,6 +2872,8 @@ _gst_block_new (int numArgs,
   maximumStackDepth++; /* just to be sure */
 
   numByteCodes = _gst_bytecode_length (bytecodes);
+
+  memset (&header, 0, sizeof (header));
   header.numArgs = numArgs;
   header.numTemps = numTemps;
   header.depth = maximumStackDepth;


--- orig/libgst/comp.h
+++ mod/libgst/comp.h
@@ -88,7 +88,7 @@
 #define MTH_DEPTH_BITS 6
 #define MTH_TEMPS_BITS 6
 #define MTH_ARGS_BITS 5
-#define MTH_PRIM_BITS 10
+#define MTH_PRIM_BITS 9
 #define MTH_FLAG_BITS 3
 
 #define MTH_NORMAL 0
@@ -108,8 +108,8 @@ typedef struct method_header
 #endif
   unsigned :1; /* sign - must be 0 */
   unsigned headerFlag:MTH_FLAG_BITS; /* prim _gst_self, etc.  */
-  unsigned primitiveIndex:MTH_PRIM_BITS; /* index of primitve,
-   or 0 */
+  unsigned isOldSyntax:1;
+  unsigned primitiveIndex:MTH_PRIM_BITS; /* index of primitive, or 0 */
   unsigned numTemps:MTH_TEMPS_BITS;
   unsigned stack_depth:MTH_DEPTH_BITS;
   unsigned numArgs:MTH_ARGS_BITS;
@@ -121,6 +121,7 @@ typedef struct method_header
   unsigned numTemps:MTH_TEMPS_BITS;
   unsigned primitiveIndex:MTH_PRIM_BITS; /* index of primitve,
    or 0 */
+  unsigned isOldSyntax:1;
   unsigned headerFlag:MTH_FLAG_BITS; /* prim _gst_self, etc.  */
   unsigned :1; /* sign - must be 0 */
 #if SIZEOF_OOP == 8


--- orig/libgst/gst-parse.c
+++ mod/libgst/gst-parse.c
@@ -314,7 +314,7 @@ _gst_parse_method ()
   p.state = PARSE_METHOD;
   lex_init (&p);
   if (setjmp (p.recover) == 0)
-    parse_method (&p, EOF);
+    parse_method (&p, ']');
   else
     _gst_had_error = false;
 
@@ -1021,7 +1021,14 @@ parse_instance_variables (gst_parser *p,
     {
       gst_behavior class = (gst_behavior) OOP_TO_OBJ (classOOP);
       OOP *instVars = OOP_TO_OBJ (class->instanceVariables)->data;
-      int n = NUM_INDEXABLE_FIELDS (class->instanceVariables);
+      int n = CLASS_FIXED_FIELDS (classOOP);
+      OOP superclassOOP = SUPERCLASS (classOOP);
+      if (!IS_NIL (superclassOOP))
+ {
+  int superclassVars = CLASS_FIXED_FIELDS (superclassOOP);
+  instVars += superclassVars;
+  n -= superclassVars;
+ }
       for (; n--; instVars++)
  {
   char *s = _gst_to_cstring (*instVars);
@@ -1088,7 +1095,8 @@ parse_method (gst_parser *p, int at_end)
     current_pos.file_offset++;
 
   method = _gst_make_method (&pat->location, &current_pos,
-     pat, temps, attrs, stmts);
+     pat, temps, attrs, stmts,
+     at_end != ']');
 
   if (!_gst_had_error && !_gst_skip_compilation)
     {


--- orig/libgst/tree.c
+++ mod/libgst/tree.c
@@ -124,7 +124,8 @@ _gst_make_method (YYLTYPE *location,
   tree_node selectorExpr,
   tree_node temporaries,
   tree_node attributes,
-  tree_node statements)
+  tree_node statements,
+  int isOldSyntax)
 {
   tree_node result;
 
@@ -134,6 +135,7 @@ _gst_make_method (YYLTYPE *location,
   result->v_method.temporaries = temporaries;
   result->v_method.attributes = attributes;
   result->v_method.statements = statements;
+  result->v_method.isOldSyntax = isOldSyntax;
   return (result);
 }
 
@@ -707,6 +709,11 @@ print_method_node (tree_node node,
   indent (level);
   printf ("statements: ");
   _gst_print_tree (node->v_method.statements, level + 12);
+  indent (level);
+  if (node->v_method.isOldSyntax)
+    printf ("old syntax\n");
+  else
+    printf ("new syntax\n");
 }
 
 static void


--- orig/libgst/tree.h
+++ mod/libgst/tree.h
@@ -181,6 +181,7 @@ typedef struct method_node
   tree_node attributes;
   tree_node statements;
   int64_t endPos;
+  mst_Boolean isOldSyntax;
 }
 method_node;
 
@@ -230,7 +231,8 @@ extern tree_node _gst_make_method (YYLTY
    tree_node selectorExpr,
    tree_node temporaries,
    tree_node attributes,
-   tree_node statements)
+   tree_node statements,
+   int isOldSyntax)
   ATTRIBUTE_HIDDEN;
 
 /* Create an expr_node to be passed to _gst_make_method for a unary


--- orig/packages/stinst/compiler/StartCompiler.st
+++ mod/packages/stinst/compiler/StartCompiler.st
@@ -112,7 +112,6 @@ hidden from other objects trying to work
     ]
 ]
 
-
 
 STParsingDriver subclass: STEvaluationDriver [
     | curCategory curClass curCompilerClass evalFor lastResult method |
@@ -264,8 +263,7 @@ RBParser extend [
 Behavior extend [
 
     compilerClass [
- "This method is present for symmetry with #parserClass.  It
- specifies the class that will be used to compile the parse
+ "Return the class that will be used to compile the parse
  nodes into bytecodes."
 
  <category: 'compiling'>
@@ -287,14 +285,6 @@ Behavior extend [
  ^STInST.GSTFileInParser
     ]
 
-    parserClass [
- "Answer the class to be used by my method-compiling methods to
- parse methods for delivery to my #compilerClass."
-
- <category: 'compiling'>
- ^STInST.RBParser
-    ]
-
 ]
 
 




--- orig/packages/stinst/parser/Exporter.st
+++ mod/packages/stinst/parser/Exporter.st
@@ -294,9 +294,7 @@ FileOutExporter subclass: FormattingExpo
                         outClass asMetaclass ]
                     ifFalse: [ outClass ].
                     
- source := STInST.RBFormatter new
-      initialIndent: 1;
-                      format: (class parseNodeAt: selector).
+ source := (class compiledMethodAt: selector) methodFormattedSourceString.
         outStream nextPutAll: source; nl.
     ]
 ]
@@ -308,11 +306,28 @@ Behavior extend [
 ]
 
 CompiledMethod extend [
+    methodFormattedSourceString [
+        "Answer the method source code as a string"
+
+        <category: 'compiling'>
+ ^STInST.RBFormatter new
+      initialIndent: 1;
+                      format: self methodParseNode.
+    ]
+
     methodParseNode [
- ^STInST.RBParser
+        <category: 'compiling'>
+ ^self parserClass
             parseMethod: self methodSourceString
             category: self methodCategory
     ]
+
+    parserClass [
+        <category: 'compiling'>
+ ^self isOldSyntax
+    ifTrue: [ STInST.RBParser ]
+    ifFalse: [ STInST.RBBracketedMethodParser ]
+    ]
 ]
 
 Class extend [
@@ -341,3 +356,26 @@ ClassDescription extend [
         STInST.FileOutExporter fileOutCategory: category of: self to: aFileStream
     ]
 ]
+
+RBParser subclass: RBBracketedMethodParser [
+    skipToken: tokenValue [
+        (currentToken value = tokenValue)
+            ifTrue: [self step. ^true]
+            ifFalse: [^false]
+    ]
+
+    skipExpectedToken: tokenValue [
+        (self skipToken: tokenValue)
+            ifFalse: [self parserError: ('expected ' , tokenValue asSymbol)]
+    ]
+
+    parseMethodInto: methodNode [
+        <category: 'private-parsing'>
+        self skipExpectedToken: $[.
+ super parseMethodInto: methodNode.
+        self skipExpectedToken: $].
+        ^methodNode
+    ]
+]
+
+


--- orig/packages/stinst/parser/GSTParser.st
+++ mod/packages/stinst/parser/GSTParser.st
@@ -307,15 +307,19 @@ STInST.STFileInParser subclass: GSTFileI
     parseInstanceVariables: node add: addThem [
         | vars |
             
- "FIXME: support adding more instance variables."
- addThem ifTrue: [ self notYetImplemented ].
-        vars := (node arguments at: 1) name.
+ vars := addThem
+    ifTrue: [
+        (self resolveClass: class) instVarNames
+    fold: [ :a :b | a, ' ', b ] ]
+    ifFalse: [ '' ].
+
+        vars := vars, ' ', (node arguments at: 1) name.
         [currentToken isIdentifier]
             whileTrue: [vars := vars , ' ' , currentToken value.
         
                         self step ].      
+
         self skipExpectedToken: #|.
-        
         self evaluateMessageOn: class
              selector: #instanceVariableNames:
              argument: vars.


--- orig/packages/stinst/parser/RBParser.st
+++ mod/packages/stinst/parser/RBParser.st
@@ -1420,6 +1420,33 @@ Stream subclass: RBScanner [
     ]
 ]
 
+
+
+RBParser subclass: RBBracketedMethodParser [
+
+    <category: 'Refactory-Parser'>
+    <comment: 'A subclass of RBParser that discards a pair of brackets around
+methods.'>
+
+    skipToken: tokenValue [
+        (currentToken value = tokenValue)
+            ifTrue: [self step. ^true]
+            ifFalse: [^false]
+    ]
+
+    skipExpectedToken: tokenValue [
+        (self skipToken: tokenValue)
+            ifFalse: [self parserError: ('expected ' , tokenValue asSymbol)]
+    ]
+
+    parseMethodInto: methodNode [
+        <category: 'private-parsing'>
+        self skipExpectedToken: $[.
+       super parseMethodInto: methodNode.
+        self skipExpectedToken: $].
+        ^methodNode
+    ]
+]
 
 
 Eval [


--- orig/packages/stinst/parser/SIFParser.st
+++ mod/packages/stinst/parser/SIFParser.st
@@ -39,7 +39,9 @@ STFileInParser subclass: #SIFFileInParse
 
 parseMethodDefinitionList
     "Methods are defined one by one in SIF."
-    self compile: self parseMethodFromFile.
+    | method |
+    method := self compile: self parseMethodFromFile.
+    method isNil ifFalse: [ method noteOldSyntax ].
     self endMethodList
 ! !
 


--- orig/packages/stinst/parser/STFileParser.st
+++ mod/packages/stinst/parser/STFileParser.st
@@ -89,7 +89,7 @@ RBParser subclass: STFileParser [
 
     compile: node [
  <category: 'overridable - parsing file-ins'>
- driver compile: node
+ ^driver compile: node
     ]
 
     endMethodList [
@@ -97,6 +97,12 @@ RBParser subclass: STFileParser [
  driver endMethodList
     ]
 
+    resolveClass: node [
+ <category: 'overridable - parsing file-ins'>
+ self evaluate: node.
+ ^self result
+    ]
+
     evaluate: node [
  "This should be overridden because its result affects the parsing
  process: true means 'start parsing methods', false means 'keep
@@ -240,7 +246,7 @@ Object subclass: STParsingDriver [
  "do nothing by default"
 
  <category: 'overridable - parsing file-ins'>
-
+ ^nil
     ]
 
     endMethodList [
@@ -326,9 +332,13 @@ STFileParser subclass: STFileInParser [
  method definitions, followed by a bang"
 
  <category: 'private-parsing'>
+ | method |
+
  self step. "gobble doit terminating bang"
  [scanner atEnd or: [currentToken isSpecial and: [currentToken value == $!]]]
-    whileFalse: [self compile: self parseMethodFromFile].
+    whileFalse: [
+ method := self compile: self parseMethodFromFile.
+ method isNil ifFalse: [method noteOldSyntax]].
  scanner stripSeparators.
  self step.
  self endMethodList


--- orig/packages/stinst/parser/STLoader.st
+++ mod/packages/stinst/parser/STLoader.st
@@ -248,7 +248,7 @@ defineMethod: node
 !
 
 compile: node
-    self defineMethod: node.
+    ^self defineMethod: node
 ! !
 
 !STClassLoader methodsFor: 'evaluating statements'!


--- orig/packages/stinst/parser/STLoaderObjs.st
+++ mod/packages/stinst/parser/STLoaderObjs.st
@@ -1148,7 +1148,12 @@ methodSourceString
 
 !LoadedMethod methodsFor: 'empty stubs'!
 
+noteOldSyntax
+    "Do nothing"
+!
+
 discardTranslation
+    "Do nothing"
 ! !
 
 !PseudoNamespace methodsFor: 'abstract'!


--- orig/tests/mutate.ok
+++ mod/tests/mutate.ok
@@ -92,7 +92,20 @@ Execution begins...
 returned value is Association new "<0>"
 
 Execution begins...
-returned value is CompiledMethod new: 2 "<0>"
+returned value is CompiledMethod new: 4 "<0>"
 
 Execution begins...
 returned value is true
+Recompiling classes...
+
+Execution begins...
+(#a #b #c )
+returned value is Array new: 3 "<0>"
+
+Execution begins...
+(#a #d #b #c )
+returned value is Array new: 4 "<0>"
+
+Execution begins...
+(#a #d )
+returned value is Array new: 2 "<0>"


--- orig/tests/mutate.st
+++ mod/tests/mutate.st
@@ -123,3 +123,11 @@ Eval [ (C shape -> C classPool keys asAr
 
 Eval [ C class compile: 'foo [ ^MutationError ]' ]
 Eval [ C foo == SystemExceptions.MutationError ]
+
+Object subclass: Foo [ | a | ]
+Foo subclass: Bar [ | xyz | ]
+Foo subclass: Bar [ | b | | c | ]
+Eval [ Bar allInstVarNames printNl ]
+Foo extend [ | d | ]
+Eval [ Bar allInstVarNames printNl ]
+Eval [ Foo allInstVarNames printNl ]


--- orig/tests/testsuite.at
+++ mod/tests/testsuite.at
@@ -42,7 +42,7 @@ AT_DIFF_TEST([geometry.st])
 AT_DIFF_TEST([cobjects.st])
 AT_DIFF_TEST([compiler.st])
 AT_DIFF_TEST([fileext.st])
-AT_DIFF_TEST([mutate.st], [AT_XFAIL_IF(:)])
+AT_DIFF_TEST([mutate.st])
 AT_DIFF_TEST([untrusted.st])
 AT_DIFF_TEST([getopt.st])
 AT_DIFF_TEST([quit.st])




_______________________________________________
help-smalltalk mailing list
[hidden email]
http://lists.gnu.org/mailman/listinfo/help-smalltalk

Applied (together with some more fixes to the browser) as patch-611.

Paolo



_______________________________________________
help-smalltalk mailing list
[hidden email]
http://lists.gnu.org/mailman/listinfo/help-smalltalk