[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Help-smalltalk] [PATCH] more scripting changes
From: |
Paolo Bonzini |
Subject: |
[Help-smalltalk] [PATCH] more scripting changes |
Date: |
Fri, 25 May 2007 14:34:51 +0200 |
User-agent: |
Thunderbird 2.0.0.0 (Macintosh/20070326) |
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.
[Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Help-smalltalk] [PATCH] more scripting changes,
Paolo Bonzini <=