[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Help-smalltalk] [PATCH] prototype patch to fix mutate.st
|
From: |
Paolo Bonzini |
|
Subject: |
[Help-smalltalk] [PATCH] prototype patch to fix mutate.st |
|
Date: |
Mon, 15 Oct 2007 10:42:32 +0200 |
|
User-agent: |
Thunderbird 2.0.0.6 (Macintosh/20070728) |
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 <address@hidden>
* 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 <address@hidden>
* 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 <address@hidden>
* StartCompiler.st: Remove #parserClass from Behavior.
packages/stinst/parser:
2007-10-14 Paolo Bonzini <address@hidden>
* 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 address@hidden/smalltalk--devo--2.2--patch-606 to compare with
* comparing to address@hidden/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, ¤t_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])
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Help-smalltalk] [PATCH] prototype patch to fix mutate.st,
Paolo Bonzini <=