"====================================================================== | | RootNamespace Method Definitions | | $Revision: 1.7.5$ | $Date: 2000/05/28 16:56:52$ | $Author: pb$ | ======================================================================" "====================================================================== | | Copyright 1988-92, 1994-95, 1999, 2000 Free Software Foundation, Inc. | Written by Paolo Bonzini. | | This file is part of the GNU Smalltalk class library. | | The GNU Smalltalk class library is free software; you can redistribute it | and/or modify it under the terms of the GNU Lesser General Public License | as published by the Free Software Foundation; either version 2.1, or (at | your option) any later version. | | The GNU Smalltalk class library is distributed in the hope that it will be | useful, but WITHOUT ANY WARRANTY; without even the implied warranty of | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser | General Public License for more details. | | You should have received a copy of the GNU Lesser General Public License | along with the GNU Smalltalk class library; see the file COPYING.LESSER. | If not, write to the Free Software Foundation, 59 Temple Place - Suite | 330, Boston, MA 02111-1307, USA. | ======================================================================" Dictionary variableSubclass: #RootNamespace instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Language-Implementation' ! RootNamespace comment: 'I am a special form of dictionary. I provide special ways to access my keys, which typically begin with an uppercase letter. Classes hold on an instance of me; it is called their `environment''). My keys are (expected to be) symbols, so I use == to match searched keys to those in the dictionary -- this is done expecting that it brings a bit more speed.' ! !RootNamespace class methodsFor: 'instance creation'! new "Disabled - use #new to create instances" ^self error: 'use #new: to create instances' ! new: spaceName "Create a new root namespace with the given name, and add to Smalltalk a key that references it." ^Smalltalk at: spaceName asGlobalKey put: ((super new: 31) setSuperspace: nil) ! primNew: parent name: spaceName "Private - Create a new namespace with the given name and parent, and add to the parent a key that references it." ^parent at: spaceName asGlobalKey put: ((super new: 31) setSuperspace: parent) ! ! !RootNamespace methodsFor: 'copying'! copy ^self ! shallowCopy ^self ! deepCopy ^self ! ! !RootNamespace methodsFor: 'accessing'! allAssociations "Answer a Dictionary with all of the associations in the receiver and each of its superspaces (duplicate keys are associated to the associations that are deeper in the namespace hierarchy)" | allAssociations value | allAssociations := Dictionary new. self withAllSuperspaces reverseDo: [ :each | 1 to: each primSize do: [ :index | value := each primAt: index. value isNil ifFalse: [ allAssociations add: value copy ] ]. ]. ^allAssociations ! allBehaviorsDo: aBlock "Evaluate aBlock once for each class and metaclass in the namespace." Behavior withAllSubclassesDo: [ :subclass | (subclass == Class) | (subclass == Metaclass) ifFalse: [ subclass allInstancesDo: [ :each | each environment == self ifTrue: [ aBlock value: each ] ] ] ]. "Special case classes and metaclasses because #allInstancesDo: is very slow - the less we use it, the better it is." Class allSubclassesDo: [ :eachMeta | eachMeta environment == self ifTrue: [ aBlock value: eachMeta; value: eachMeta instanceClass ] ] ! allClassesDo: aBlock "Evaluate aBlock once for each class in the namespace." Class allSubclassesDo: [ :eachMeta | eachMeta environment == self ifTrue: [ aBlock value: eachMeta instanceClass ] ] ! allClassObjectsDo: aBlock "Evaluate aBlock once for each class and metaclass in the namespace." Class allSubclassesDo: [ :eachMeta | eachMeta environment == self ifTrue: [ aBlock value: eachMeta; value: eachMeta instanceClass ] ] ! allMetaclassesDo: aBlock "Evaluate aBlock once for each metaclass in the namespace." Class allSubclassesDo: [ :eachMeta | eachMeta environment == self ifTrue: [ aBlock value: eachMeta ] ] ! classAt: aKey "Answer the value corrisponding to aKey if it is a class. Fail if either aKey is not found or it is associated to something different from a class." ^self classAt: aKey ifAbsent: [ ^self error: 'class not found - ', aKey ]. ! classAt: aKey ifAbsent: aBlock "Answer the value corrisponding to aKey if it is a class. Evaluate aBlock and answer its result if either aKey is not found or it is associated to something different from a class." | class | class := self at: aKey asGlobalKey ifAbsent: [ ^aBlock value ]. class isClass ifFalse: [ ^aBlock value ]. ^class ! define: aSymbol "Define aSymbol as equal to nil inside the receiver. Fail if such a variable already exists (use #at:put: if you don't want to fail)" super at: aSymbol ifAbsent: [ self at: aSymbol put: nil. ^self ]. self error: 'cannot redefine variable' ! import: aSymbol from: aNamespace "Add to the receiver the symbol aSymbol, associated to the same value as in aNamespace. Fail if aNamespace does not contain the given key." self add: (aNamespace associationAt: aSymbol) copy ! doesNotUnderstand: aMessage "Try to map unary selectors to read accesses to the Namespace, and one-argument keyword selectors to write accesses. Note that: a) this works only if the selector has an uppercase first letter; and b) `aNamespace Variable: value' is the same as `aNamespace set: #Variable to: value', not the same as `aNamespace at: #Variable put: value' --- the latter always refers to the current namespace, while the former won't define a new variable, instead searching in superspaces (and raising an error if the variable cannot be found)." | key | (aMessage selector at: 1) isUppercase ifFalse: [ ^super doesNotUnderstand: aMessage ]. aMessage arguments size = 0 ifTrue: [ ^self at: aMessage selector ifAbsent: [ super doesNotUnderstand: aMessage ] ]. aMessage arguments size > 1 ifTrue: [ ^super doesNotUnderstand: aMessage ]. key := (aMessage selector copyWithout: $:) asSymbol. ^self set: key to: aMessage argument ifAbsent: [ super doesNotUnderstand: aMessage ] ! ! !RootNamespace methodsFor: 'forward declarations'! at: key put: value "Store value as associated to the given key. If any, recycle Associations temporarily stored by the compiler inside the `Undeclared' dictionary." | undeclared | undeclared := Smalltalk at: #Undeclared. (undeclared includesKey: key) ifTrue: [ self add: (undeclared associationAt: key). undeclared removeKey: key ]. ^super at: key put: value ! ! !RootNamespace methodsFor: 'overrides for superspaces'! definedKeys "Answer a kind of Set containing the keys of the receiver" | aSet value | aSet := self keysClass new: tally * 4 // 3. 1 to: self primSize do: [ :index | value := self primAt: index. value isNil ifFalse: [ aSet add: value key ] ]. ^aSet ! definesKey: key "Answer whether the receiver defines the given key. `Defines' means that the receiver's superspaces, if any, are not considered." ^super includesKey: key ! hereAt: key ifAbsent: aBlock "Return the value associated to the variable named as specified by `key' *in this namespace*. If the key is not found search will *not* be brought on in superspaces and aBlock will be immediately evaluated." ^super at: key ifAbsent: aBlock ! hereAt: key "Return the value associated to the variable named as specified by `key' *in this namespace*. If the key is not found search will *not* be brought on in superspaces and the method will fail." ^self hereAt: key ifAbsent: [ self error: 'key not found' ] ! inheritedKeys "Answer a Set of all the keys in the receiver and its superspaces" ^Set new ! set: key to: newValue "Assign newValue to the variable named as specified by `key'. This method won't define a new variable; instead if the key is not found it will search in superspaces and raising an error if the variable cannot be found in any of the superspaces. Answer newValue." ^self set: key to: newValue ifAbsent: [ self error: 'key not found' ] ! set: key to: newValue ifAbsent: aBlock "Assign newValue to the variable named as specified by `key'. This method won't define a new variable; instead if the key is not found it will search in superspaces and evaluate aBlock if it is not found. Answer newValue." | index | index := self findIndexOrAnswerNil: key. index isNil ifTrue: [ ^aBlock value ]. (self primAt: index) value: newValue. ^newValue ! values "Answer a Bag containing the values of the receiver" | aBag value | aBag := Bag new: tally. 1 to: self primSize do: [ :index | value := self primAt: index. value isNil ifFalse: [ aBag add: value value ] ]. ^aBag ! ! !RootNamespace methodsFor: 'namespace hierarchy'! addSubspace: aSymbol "Add aNamespace to the set of the receiver's subspaces" ^Namespace primNew: self name: aSymbol ! allSubassociationsDo: aBlock "Invokes aBlock once for every association in each of the receiver's subspaces." self allSubspacesDo: [ :subspace | subspace associationsDo: aBlock ] ! allSubspacesDo: aBlock "Invokes aBlock for all subspaces, both direct and indirect." self subspaces notNil ifTrue: [ self subspaces do: [ :space | aBlock value: space. space allSubspacesDo: aBlock ] ] ! allSubspaces "Answer the direct and indirect subspaces of the receiver in a Set" | aSet | aSet := Set new. self allSubspacesDo: [ :subspace | aSet add: subspace ]. ^aSet ! allSuperspaces "Answer all the receiver's superspaces in a collection" | supers | supers := OrderedCollection new. self allSuperspacesDo: [ :superspace | supers addLast: superspace ]. ^supers ! allSuperspacesDo: aBlock "Evaluate aBlock once for each of the receiver's superspaces" | space | space := self. [ space := space superspace. space notNil ] whileTrue: [ aBlock value: space ] ! includesClassNamed: aString "Answer whether the receiver or any of its superspaces include the given class -- note that this method (unlike #includesKey:) does not require aString to be interned and (unlike #includesGlobalNamed:) only returns true if the global is a class object." | possibleClass | possibleClass := Symbol hasInterned: aString ifTrue: [ :aSymbol | self at: aSymbol ifAbsent: [nil] ]. ^possibleClass isClass ! includesGlobalNamed: aString "Answer whether the receiver or any of its superspaces include the given key -- note that this method (unlike #includesKey:) does not require aString to be interned but (unlike #includesClassNamed:) returns true even if the global is not a class object." Symbol hasInterned: aString ifTrue: [ :aSymbol | self at: aSymbol ifPresent: [ :value | ^true] ]. ^false ! inheritsFrom: aNamespace "Answer whether aNamespace is one of the receiver's direct and indirect superspaces" | space | space := self. [ space := space superspace. space == aNamespace ifTrue: [ ^true ]. space notNil ] whileTrue ! selectSubspaces: aBlock "Return a Set of subspaces of the receiver satisfying aBlock." | aSet | aSet := Set new. self allSubspacesDo: [ :subspace | (aBlock value: subspace) ifTrue: [ aSet add: subspace ] ]. ^aSet ! selectSuperspaces: aBlock "Return a Set of superspaces of the receiver satisfying aBlock." | aSet | aSet := Set new. self allSuperspacesDo: [ :superspace | (aBlock value: superspace) ifTrue: [ aSet add: superspace ] ]. ^aSet ! siblings "Answer all the other root namespaces" ^RootNamespace allInstances asSet remove: self; yourself ! siblingsDo: aBlock "Evaluate aBlock once for each of the other root namespaces, passing the namespace as a parameter." RootNamespace allInstances asSet do: [ :space | space == self ifFalse: [ aBlock value: space ] ] ! superspace "Send #at:ifAbsent: to super because our implementation of #at:ifAbsent: sends this message (chicken and egg!)" ^super at: #Super ifAbsent: [ self error: 'Namespace has no superspace!'. nil ] ! superspace: aNamespace "Set the superspace of the receiver to be 'aNamespace'. Also adds the receiver as a subspace of it." | oldSuperspace newSuperspace root | oldSuperspace := self superspace. newSuperspace := aNamespace. oldSuperspace == newSuperspace ifTrue: [ ^self ]. "don't need to change anything" oldSuperspace isNil ifTrue: [ oldSuperspace := Smalltalk. self become: ((Namespace basicNew: self primSize) copyAllFrom: self). ] ifFalse: [ oldSuperspace subspaces remove: self. ]. newSuperspace isNil ifTrue: [ newSuperspace := Smalltalk self become: ((RootNamespace basicNew: self primSize) copyAllFrom: self). ] ifFalse: [ aNamespace subspaces add: self ]. self at: #Super put: aNamespace. newSuperspace add: (oldSuperspace removeAssociation: self name asSymbol -> nil). self do: [ :each | each isClass ifTrue: [ each recompileAll. each class recompileAll. ] ]. self allSubassociationsDo: [ :assoc | assoc value isClass ifTrue: [ assoc value recompileAll. assoc value class recompileAll. ] ]. ! subspaces "Answer the receiver's direct subspaces" ^super at: #Subspaces ifAbsent: [ self at: #Subspaces put: IdentitySet new ] ! subspacesDo: aBlock "Invokes aBlock for all direct subspaces." self subspaces do: [ :subclass | aBlock value: subclass ] ! withAllSubspaces "Answer a Set containing the receiver together with its direct and indirect subspaces" | aSet | aSet := Set with: self. aSet addAll: self allSubspaces. ^aSet ! withAllSubspacesDo: aBlock "Invokes aBlock for the receiver and all subclasses, both direct and indirect." aBlock value: self. self subspaces do: [ :subspace | aBlock value: subspace. subspace allSubspacesDo: aBlock ] ! withAllSuperspaces "Answer the receiver and all of its superspaces in a collection" | supers | supers := OrderedCollection with: self. self allSuperspacesDo: [ :superspace | supers addLast: superspace ]. ^supers ! withAllSuperspacesDo: aBlock "Invokes aBlock for the receiver and all superspaces, both direct and indirect." | space | space := self. [ aBlock value: space. space := space superspace. space notNil ] whileTrue ! ! !RootNamespace methodsFor: 'printing'! defaultName "Private - Answer the name to be used if the receiver is not attached to an association in the superspace" ^'' ! name "Answer the receiver's name" ^(Smalltalk keyAtValue: self ifAbsent: [ self defaultName ]) asString ! printOn: aStream "Print a representation of the receiver" aStream nextPutAll: self name ! storeOn: aStream "Store Smalltalk code compiling to the receiver" | result name | aStream nextPutAll: 'Smalltalk '; nextPutAll: (Smalltalk keyAtValue: self name ifAbsent: [ self error: 'cannot print unnamed namespace' ]) ! ! !RootNamespace methodsFor: 'private'! hashFor: anElement "Answer the hash value for anElement" ^anElement identityHash ! is: anElement sameAs: searchedObject "Answer whether findIndex: should stop scanning the receiver: anElement has been found and findIndex:'s parameter was searchedObject" ^anElement key == searchedObject ! setSuperspace: superspace self at: #Super put: superspace. self at: #Undeclared put: Dictionary new. ! keysClass ^IdentitySet ! growBy: delta "Private - Grow by the receiver by delta places" | newSet | newSet := self class basicNew: self primSize + delta. newSet initialize: newSet basicSize. newSet copyAllFrom: self. ^self become: newSet ! removeSubspace: aNamespace self subspaces remove: aNamespace. aNamespace at: #Super put: nil. ! ! !RootNamespace methodsFor: 'testing'! isNamespace ^true ! isSmalltalk ^false ! species ^IdentityDictionary ! !