"======================================================================
|
|   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"
    ^'<no name>'
!

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
! !
