diff --git a/ChangeLog b/ChangeLog index 16c5fe4..fc641ea 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,18 @@ +2008-05-18 Stephen Compall + + * tests/pools.st: Test that namespace pragmas work, at least for + imports. + +2008-05-17 Stephen Compall + + * kernel/AbstNamespc.st: Add `sharedPools' instvar and methods for + it similar to Class's. + * kernel/Class.st: Refactor + allLocalSharedPoolDictionariesExcept:do: to a list-independent + class method. Use it to import shared pools from namespaces as + they are visited. + * tests/pools.st: Test for namespace shared pools. + 2008-05-15 Paolo Bonzini * kernel/FilePath.st: Deal correctly with UNC paths. diff --git a/kernel/AbstNamespc.st b/kernel/AbstNamespc.st index 12dacfd..76188be 100644 --- a/kernel/AbstNamespc.st +++ b/kernel/AbstNamespc.st @@ -33,7 +33,7 @@ BindingDictionary subclass: AbstractNamespace [ - | name subspaces | + | name subspaces sharedPools | @@ -175,6 +175,35 @@ an instance of me; it is called their `environment''. '> ^class ] + addSharedPool: aDictionary [ + "Import the given bindings for classes compiled with me as + environment." + + sharedPools isNil ifTrue: [^sharedPools := {aDictionary}]. + (sharedPools includes: aDictionary) ifFalse: + [sharedPools := sharedPools copyWith: aDictionary]. + ] + + import: aDictionary [ + "Import the given bindings for classes compiled with me as + environment." + + self addSharedPool: aDictionary + ] + + removeSharedPool: aDictionary [ + "Remove aDictionary from my list of direct pools." + + sharedPools isNil ifFalse: + [sharedPools := sharedPools copyWithout: aDictionary] + ] + + sharedPoolDictionaries [ + "Answer the shared pools (not names) imported for my classes." + + ^sharedPools ifNil: [#()] + ] + inheritedKeys [ "Answer a Set of all the keys in the receiver and its superspaces" diff --git a/kernel/Class.st b/kernel/Class.st index f745ce5..0495741 100644 --- a/kernel/Class.st +++ b/kernel/Class.st @@ -42,6 +42,34 @@ class name, class comment (you wouldn''t be reading this if it weren''t for me), a list of the instance variables of the class, and the class category.'> + Class class >> allPoolDictionaries: list except: inWhite do: aBlock [ + "Invoke aBlock with each of the result of combining the list + of pools using a topological sort, preferring dependent to + prerequisite, and then left to right. Any pool that is + already in inWhite will not be answered." + + | white grey order descend | + list isEmpty ifTrue: [ ^self ]. + + white := inWhite copy. + grey := IdentitySet new: list size. + order := OrderedCollection new: list size. + descend := [:pool | + (white includes: pool) ifFalse: + [(grey includes: pool) ifTrue: + [^SystemExceptions.InvalidValue + signalOn: list + reason: 'includes circular dependency']. + + "#allSuperspaces is not available on all pools" + grey add: pool. + pool allSuperspaces reverseDo: descend. + order addFirst: pool. + white add: pool]]. + list reverseDo: descend. + order do: aBlock + ] + Class class >> initialize [ "Perform the special initialization of root classes." @@ -645,8 +673,12 @@ the class category.'> "Now proceed with the `natural' (non-imported spaces)." behavior environment withAllSuperspacesDo: [:each | - (superclassSpaces includes: each) - ifFalse: [ aBlock value: each ]]] + (superclassSpaces includes: each) ifFalse: + [aBlock value: each. + "also visit the namespace shared pools" + Class allPoolDictionaries: each sharedPoolDictionaries + except: classSpaces + do: aBlock]]] ] allLocalSharedPoolDictionariesExcept: inWhite do: aBlock [ @@ -655,27 +687,8 @@ the class category.'> to prerequisite, and then left to right. Any pool that is already in inWhite will not be answered." - | white grey order descend list | - list := self sharedPoolDictionaries. - list isEmpty ifTrue: [ ^self ]. - - white := inWhite copy. - grey := IdentitySet new: list size. - order := OrderedCollection new: list size. - descend := [:pool | - (white includes: pool) ifFalse: - [(grey includes: pool) ifTrue: - [^SystemExceptions.InvalidValue - signalOn: list - reason: 'includes circular dependency']. - - "#allSuperspaces is not available on all pools" - grey add: pool. - pool allSuperspaces reverseDo: descend. - order addFirst: pool. - white add: pool]]. - list reverseDo: descend. - order do: aBlock + Class allPoolDictionaries: self sharedPoolDictionaries + except: inWhite do: aBlock ] metaclassFor: classNameString [ diff --git a/libgst/ChangeLog b/libgst/ChangeLog index a7a7024..62ddff2 100644 --- a/libgst/ChangeLog +++ b/libgst/ChangeLog @@ -1,3 +1,15 @@ +2008-05-18 Stephen Compall + + * libgst/gst-parse.c: Refactor pragma evaluation into new + function, and use it to support namespace pragmas. + +2008-05-17 Stephen Compall + + * libgst/dict.h: Add `sharedPools' instvar to gst_namespace. + * libgst/dict.c: Likewise. + * libgst/sym.c: Import shared pools from namespaces as they are + visited, and expand the comment on TwistedPools to document this. + 2008-05-17 Paolo Bonzini * libgst/callin.c: Fix _gst_oop_indexed_base. diff --git a/libgst/dict.c b/libgst/dict.c index 78840ce..9721f54 100644 --- a/libgst/dict.c +++ b/libgst/dict.c @@ -576,8 +576,8 @@ static const class_definition class_info[] = { "BindingDictionary", "environment", NULL, NULL }, {&_gst_abstract_namespace_class, &_gst_binding_dictionary_class, - GST_ISP_POINTER, true, 2, - "AbstractNamespace", "name subspaces", NULL, NULL }, + GST_ISP_POINTER, true, 3, + "AbstractNamespace", "name subspaces sharedPools", NULL, NULL }, {&_gst_root_namespace_class, &_gst_abstract_namespace_class, GST_ISP_POINTER, false, 0, @@ -772,7 +772,8 @@ init_proto_oops() nil_fill (symbolTable->data, numWords - OBJ_HEADER_SIZE_WORDS); - numWords = OBJ_HEADER_SIZE_WORDS + INITIAL_SMALLTALK_SIZE + 4; + /* 5 is the # of fixed instvars in gst_namespace */ + numWords = OBJ_HEADER_SIZE_WORDS + INITIAL_SMALLTALK_SIZE + 5; /* ... now the Smalltalk dictionary ... */ smalltalkDictionary = (gst_namespace) _gst_alloc_words (numWords); @@ -783,6 +784,7 @@ init_proto_oops() smalltalkDictionary->name = _gst_smalltalk_namespace_symbol; smalltalkDictionary->superspace = _gst_nil_oop; smalltalkDictionary->subspaces = _gst_nil_oop; + smalltalkDictionary->sharedPools = _gst_nil_oop; nil_fill (smalltalkDictionary->assoc, INITIAL_SMALLTALK_SIZE); diff --git a/libgst/dict.h b/libgst/dict.h index 2aa5dd9..fa83034 100644 --- a/libgst/dict.h +++ b/libgst/dict.h @@ -111,6 +111,7 @@ typedef struct gst_namespace OOP superspace; OOP name; OOP subspaces; + OOP sharedPools; OOP assoc[1]; /* Other, indexable fields that are the associations for this diff --git a/libgst/gst-parse.c b/libgst/gst-parse.c index 68ae6cd..346145b 100644 --- a/libgst/gst-parse.c +++ b/libgst/gst-parse.c @@ -105,6 +105,8 @@ static mst_Boolean parse_scoped_definition (gst_parser *p, static void parse_eval_definition (gst_parser *p); +static mst_Boolean parse_and_send_attribute (gst_parser *p, + OOP receiverOOP); static mst_Boolean parse_namespace_definition (gst_parser *p, tree_node first_stmt); static mst_Boolean parse_class_definition (gst_parser *p, @@ -601,6 +603,41 @@ parse_eval_definition (gst_parser *p) } static mst_Boolean +parse_and_send_attribute (gst_parser *p, OOP receiverOOP) +{ + OOP selectorOOP, args[1]; + tree_node keyword, value; + +#if 0 + printf ("parse attribute\n"); +#endif + lex_skip_mandatory (p, '<'); + keyword = parse_keyword_expression (p, NULL, EXPR_KEYWORD); + if (keyword->v_expr.expression->v_list.next != NULL) + { + _gst_errorf ("expected one keyword only"); + _gst_had_error = true; + } + else + { + value = keyword->v_expr.expression->v_list.value; + selectorOOP = _gst_compute_keyword_selector (keyword->v_expr.expression); + value = _gst_make_statement_list (&value->location, value); + args[0] = _gst_execute_statements (NULL, value, + UNDECLARED_NONE, true); + + if (!args[0]) + _gst_had_error = true; + + if (!_gst_had_error) + _gst_nvmsg_send (receiverOOP, selectorOOP, args, 1); + } + + lex_skip_mandatory (p, '>'); + return !_gst_had_error; +} + +static mst_Boolean parse_namespace_definition (gst_parser *p, tree_node first_stmt) { tree_node expr = first_stmt->v_expr.expression; @@ -615,7 +652,12 @@ parse_namespace_definition (gst_parser *p, tree_node first_stmt) _gst_namespace_class, new_namespace); while (token (p, 0) != ']' && token (p, 0) != EOF && token (p, 0) != '!') - parse_doit (p, true); + { + if (token (p, 0) == '<') + parse_and_send_attribute (p, new_namespace); + else + parse_doit (p, true); + } _gst_msg_sendf (NULL, "%v %o current: %o", _gst_namespace_class, old_namespace); @@ -679,35 +721,7 @@ parse_class_definition (gst_parser *p, OOP classOOP, mst_Boolean extend) } else if (t2 == KEYWORD) { - OOP selectorOOP, args[1]; - tree_node keyword, value; - -#if 0 - printf ("parse attribute\n"); -#endif - lex_skip_mandatory (p, '<'); - keyword = parse_keyword_expression (p, NULL, EXPR_KEYWORD); - if (keyword->v_expr.expression->v_list.next != NULL) - { - _gst_errorf ("expected one keyword only"); - _gst_had_error = true; - } - else - { - value = keyword->v_expr.expression->v_list.value; - selectorOOP = _gst_compute_keyword_selector (keyword->v_expr.expression); - value = _gst_make_statement_list (&value->location, value); - args[0] = _gst_execute_statements (NULL, value, - UNDECLARED_NONE, true); - - if (!args[0]) - _gst_had_error = true; - - if (!_gst_had_error) - _gst_nvmsg_send (classOOP, selectorOOP, args, 1); - } - - lex_skip_mandatory (p, '>'); + parse_and_send_attribute (p, classOOP); continue; } break; diff --git a/libgst/sym.c b/libgst/sym.c index 3969341..f4481cd 100644 --- a/libgst/sym.c +++ b/libgst/sym.c @@ -592,10 +592,18 @@ free_scope_symbols (scope scope) to import external namespaces for every class in a namespace, rather than each class. If this is integrated, it would need to twist nicely. - Here is how I think it would best work: after searching any namespace, - combine its shared pools using IPCA, removing all elements that are any - of this namespace or its superspaces, and search the combination from - left to right. */ + Here is how I think it would best work: after searching any + namespace, combine its shared pools as classes' shared pools are + combined, removing all elements that are any of this namespace or + its superspaces, and search the combination from left to + right. + + There is one important difference between namespace-sharedpools + and class-sharedpools: while class sharedpools export their + imports to subclasses, namespaces should not reexport bindings + made available by way of shared pools. As such, the bindings + provided by a namespace are only available when compiling methods + that actually exist in that namespace. */ OOP @@ -654,6 +662,9 @@ make_with_all_superspaces_set (OOP poolOOP) return pset; } +/* predeclared for add_namespace */ +static pool_list *combine_local_pools + (OOP sharedPoolsOOP, struct pointer_set_t *white, pool_list *p_end); /* Add, after the node whose next pointer is in P_END, the namespace POOLOOP and all of its superspaces except those in EXCEPT. @@ -668,17 +679,27 @@ add_namespace (OOP poolOOP, struct pointer_set_t *except, pool_list *p_end) for (;;) { gst_namespace pool; + OOP importsOOP; if (!is_a_kind_of (OOP_CLASS (poolOOP), _gst_dictionary_class)) return p_end; if (!except || !pointer_set_contains (except, poolOOP)) p_end = add_pool (poolOOP, p_end); - /* Try to find a super-namespace */ + /* Add imports and try to find a super-namespace */ if (!is_a_kind_of (OOP_CLASS (poolOOP), _gst_abstract_namespace_class)) return p_end; pool = (gst_namespace) OOP_TO_OBJ (poolOOP); + importsOOP = pool->sharedPools; + if (NUM_OOPS (OOP_TO_OBJ (importsOOP))) + { + struct pointer_set_t *pset; + pset = make_with_all_superspaces_set (poolOOP); + p_end = combine_local_pools (importsOOP, pset, p_end); + pointer_set_destroy (pset); + } + poolOOP = pool->superspace; } } diff --git a/packages/stinst/parser/ChangeLog b/packages/stinst/parser/ChangeLog index 1143a67..d0e039f 100644 --- a/packages/stinst/parser/ChangeLog +++ b/packages/stinst/parser/ChangeLog @@ -1,3 +1,12 @@ +2008-05-18 Stephen Compall + + * packages/stinst/parser/GSTParser.st: Support namespace pragmas. + +2008-05-17 Stephen Compall + + * packages/stinst/parser/PoolResolutionTests.st: Test for + namespace shared pools. + 2008-04-27 Stephen Compall * STSymTable.st: Create VariableBindings directly to add to diff --git a/packages/stinst/parser/GSTParser.st b/packages/stinst/parser/GSTParser.st index 884560d..1365824 100644 --- a/packages/stinst/parser/GSTParser.st +++ b/packages/stinst/parser/GSTParser.st @@ -31,7 +31,7 @@ ======================================================================" STInST.STFileInParser subclass: GSTFileInParser [ - | class currentDeclaration | + | taggee class currentDeclaration | parseStatements [ | returnPosition statements node | @@ -75,6 +75,8 @@ STInST.STFileInParser subclass: GSTFileInParser [ parseDoit [ | node | + (taggee notNil and: [currentToken value = #<]) ifTrue: + [self parseClassTag. ^nil]. node := super parseDoit. (currentToken isSpecial and: [ self skipToken: $[ ]) ifTrue: [self parseDeclaration: node statements first. ^nil]. @@ -125,15 +127,18 @@ STInST.STFileInParser subclass: GSTFileInParser [ argument: node arguments first name asSymbol ]. self evaluateStatement: node. + taggee := RBVariableNode named: + (self driver currentNamespace nameIn: Smalltalk). self parseDoits. self skipExpectedToken: $]. "restore previous namespace" + taggee := fullNamespace. node parent: nil. node arguments: { fullNamespace }. self evaluateStatement: node ] - + parseClassExtension: node [ class := node receiver. self parseClassBody: true. @@ -151,12 +156,15 @@ STInST.STFileInParser subclass: GSTFileInParser [ ] parseClassBody: extend [ - | addInstVars | + | addInstVars oldTaggee | + oldTaggee := taggee. + taggee := class. addInstVars := extend. [ self skipToken: $] ] whileFalse: [ addInstVars := self parseClassBodyElement: addInstVars - withinExtend: extend ] + withinExtend: extend ]. + taggee := oldTaggee. ] parseClassBodyElement: addInstVars withinExtend: extend [ @@ -239,11 +247,11 @@ STInST.STFileInParser subclass: GSTFileInParser [ argument isVariable ifTrue: [stmt := RBMessageNode - receiver: class + receiver: taggee selector: selector arguments: { argument }. self evaluateStatement: stmt] - ifFalse: [self evaluateMessageOn: class + ifFalse: [self evaluateMessageOn: taggee selector: selector argument: argument token value] ] diff --git a/packages/stinst/parser/PoolResolutionTests.st b/packages/stinst/parser/PoolResolutionTests.st index 82d1d21..197fae8 100644 --- a/packages/stinst/parser/PoolResolutionTests.st +++ b/packages/stinst/parser/PoolResolutionTests.st @@ -70,13 +70,16 @@ Namespace current: STInST.Tests.MyProject.MyLibWrapper [ Eval [ "note this changes my superspace" - MyProject at: #Exception put: #Exception + MyProject at: #Exception put: #Exception. + Namespace current import: + (Dictionary from: {#Blah -> 6667. #Scoobs -> 785}). ] MyLibrary.Foo subclass: Baz [ scape [^Scape] exception [^Exception] valueAdaptor [^ValueAdaptor] + blah [^Blah] ] ] "end namespace MyProject.MyLibWrapper" @@ -86,6 +89,8 @@ Namespace current: STInST.Tests.MyLibrary [ "you ask, Who would do this? to which I say..." MyProject.MyLibWrapper.Baz subclass: BackForMore [ pkgVersion [^PkgVersion] + blah [^Blah] + scoobs [^Scoobs] ] ] "end namespace MyLibrary" @@ -136,6 +141,15 @@ TestCase subclass: TestDefaultPoolResolution [ self assertVariable: #PkgVersion of: backformore is: 'MyLibrary 1.0' description: 'namespace walk stops only at direct-super-common space'. ] + + testNamespacePools [ + self assertVariable: #Blah of: baz is: 6667 + description: 'this-class ns pool var found'. + self assertVariable: #Blah of: backformore is: MyLibrary.Blah + description: 'here-namespace searched first'. + self assertVariable: #Scoobs of: backformore is: 785 + description: 'superclass ns pools inherited'. + ] ] TestCase subclass: TestClassicPoolResolution [ @@ -183,6 +197,15 @@ TestCase subclass: TestClassicPoolResolution [ self assertVariable: #PkgVersion of: backformore is: 'MyLibrary 1.0' description: 'not surprising, really'. ] + + testNamespacePools [ + self assertVariable: #Blah of: baz is: MyLibrary.Blah + description: 'ns pool vars not searched'. + self assertVariable: #Blah of: backformore is: MyLibrary.Blah + description: 'mostly vacuous'. + self assert: (backformore lookupBindingOf: #Scoobs) isNil + description: 'ns pools really not searched'. + ] ] ] diff --git a/tests/pools.ok b/tests/pools.ok index 5fe8558..788ec00 100644 --- a/tests/pools.ok +++ b/tests/pools.ok @@ -19,3 +19,18 @@ returned value is 9994 Execution begins... returned value is 'MyLibrary 1.0' + +Execution begins... +returned value is 6667 + +Execution begins... +returned value is Blah + +Execution begins... +returned value is 785 + +Execution begins... +returned value is 'MyLibrary.Foo' + +Execution begins... +returned value is 'MyProject.MyLibWrapper.Baz' diff --git a/tests/pools.st b/tests/pools.st index 995c192..d36657d 100644 --- a/tests/pools.st +++ b/tests/pools.st @@ -29,7 +29,7 @@ | ======================================================================" -Smalltalk addSubspace: #MyLibrary; addSubspace: #MyProject. +Smalltalk addSubspace: #MyLibrary; addSubspace: #MyProject; addSubspace: #MyImports. MyProject addSubspace: #MyLibWrapper. "actually for later, to demonstrate the need for the `direct @@ -66,14 +66,18 @@ Namespace current: MyLibrary [ ] "end namespace MyLibrary" Namespace current: MyProject.MyLibWrapper [ + + Namespace current import: + (Dictionary from: {#Blah -> 6667. #Scoobs -> 785}). "note this changes my superspace" MyProject at: #Exception put: #Exception. - + MyLibrary.Foo subclass: Baz [ scape [^Scape] exception [^Exception] valueAdaptor [^ValueAdaptor] + blah [^Blah] ] ] "end namespace MyProject.MyLibWrapper" @@ -83,10 +87,26 @@ Namespace current: MyLibrary [ "you ask, Who would do this? to which I say..." MyProject.MyLibWrapper.Baz subclass: BackForMore [ pkgVersion [^PkgVersion] + blah [^Blah] + scoobs [^Scoobs] ] ] "end namespace MyLibrary" +Namespace current: MyImports [ + + + Object subclass: MITest [ + test [^Foo] + ] + + + + MITest extend [ + test2 [^Baz] + ] +] + "here start the tests..." "prefer class pool to namespace" @@ -122,3 +142,12 @@ MyProject.MyLibWrapper.Baz class extend [ TryThis := ##(Scape printNl) ] MyProject.MyLibWrapper.Baz class extend [ TryThis := ##(Exception printNl) ] MyProject.MyLibWrapper.Baz class extend [ TryThis := ##(ValueAdaptor printNl) ] MyLibrary.BackForMore class extend [ TryThis := ##(PkgVersion printNl) ]" + +"test namespace-sharedpools" +Eval [ MyProject.MyLibWrapper.Baz new blah ] "6667" +Eval [ MyLibrary.BackForMore new blah ] "Blah" +Eval [ MyLibrary.BackForMore new scoobs ] "785" + +"test namespace pragmas" +Eval [ MyImports.MITest new test nameIn: Smalltalk ] "MyLibrary.Foo" +Eval [ MyImports.MITest new test2 nameIn: Smalltalk ] "MyProject.MyLibWrapper.Baz"