Squeak 4.6: Environments-cmm.57.mcz

Chris Muller uploaded a new version of Environments to project Squeak 4.6:
http://source.squeak.org/squeak46/Environments-cmm.57.mcz

==================== Summary ====================

Name: Environments-cmm.57
Author: cmm
Time: 24 March 2015, 2:15:46.253 pm
UUID: 9352873e-a424-44ef-b624-9bf6fbbf4b74
Ancestors: Environments-topa.56

Fix access to globals which were defined by:  Smalltalk at: #MyGlobal ifAbsentPut: [myValue].

==================== Snapshot ====================

(PackageInfo named: 'Environments') preamble: '"Fix ''Instances'' entry for Smalltalk Environment."
| dict |
dict := (Environment classPool at: ''Instances'').
dict keys
        do: [ : eachName | (eachName isSymbol not ) ifTrue: [ dict at: eachName asSymbol put: (dict removeKey: eachName) ] ].

"Let Environment names be, consistently, Symbols."
Environment allInstances do:
        [ : each |
        each info
                instVarNamed: ''name''
                put: (each name asSymbol) ]'!

SystemOrganization addCategory: #'Environments-Core'!
SystemOrganization addCategory: #'Environments-Policies'!
SystemOrganization addCategory: #'Environments-Loading'!

(PackageInfo named: 'Environments') postscript: '"Recompile all methods to fix errant bindings"
Compiler recompileAll.
'!

LookupKey subclass: #Binding
        instanceVariableNames: ''
        classVariableNames: ''
        poolDictionaries: ''
        category: 'Environments-Core'!

Binding subclass: #Alias
        instanceVariableNames: 'source'
        classVariableNames: ''
        poolDictionaries: ''
        category: 'Environments-Core'!

----- Method: Alias class>>key:source: (in category 'as yet unclassified') -----
key: aSymbol source: anAssociation
        ^ self basicNew initializeWithKey: aSymbol source: anAssociation!

----- Method: Alias>>asBinding: (in category 'converting') -----
asBinding: aSymbol
        ^ aSymbol = source key
                ifTrue: [source]
                ifFalse: [Alias key: aSymbol source: source]!

----- Method: Alias>>initializeWithKey:source: (in category 'initialization') -----
initializeWithKey: aSymbol source: anAssociation
        self initialize.
        key := aSymbol.
        source := anAssociation!

----- Method: Alias>>isSpecialReadBinding (in category 'testing') -----
isSpecialReadBinding
        ^ true!

----- Method: Alias>>isSpecialWriteBinding (in category 'testing') -----
isSpecialWriteBinding
        ^ true!

----- Method: Alias>>literalEqual: (in category 'error handling') -----
literalEqual: other
        "Two aliases are equal if they have the same source"

        ^ self species = other species and: [self source == other source]!

----- Method: Alias>>source (in category 'accessing') -----
source
        ^ source!

----- Method: Alias>>value (in category 'evaluating') -----
value
        ^ source value!

----- Method: Alias>>value: (in category 'accessing') -----
value: anObject
        source value: anObject!

----- Method: Binding class>>convertInstances (in category 'as yet unclassified') -----
convertInstances
        | new old |
        old := Binding allInstances.
        new := old collect: [:ea | ClassBinding key: ea key value: ea value].
        old elementsForwardIdentityTo: new.
       
        old := ReadOnlyVariableBinding allInstances.
        new := old collect: [:ea | ClassBinding key: ea key value: ea value].
        old elementsForwardIdentityTo: new.
       
        Environment allInstancesDo:
                [:env |
                #('contents' 'bindings' 'public' 'undeclared') do:
                        [:var || dict |
                        old := Array new writeStream.
                        new := Array new writeStream.
                        dict := env instVarNamed: var.
                        dict associations do:
                                [:binding |
                                binding class == Association ifTrue:
                                        [old nextPut: binding.
                                        new nextPut: binding key => binding value]].
                        old contents elementsForwardIdentityTo: new contents]]!

----- Method: Binding>>analogousCodeTo: (in category 'as yet unclassified') -----
analogousCodeTo: anObject
        "For MethodProperties comparison."
        ^anObject isVariableBinding
          and: [self key = anObject key
          and: [self value = anObject value]]!

----- Method: Binding>>canAssign (in category 'as yet unclassified') -----
canAssign
        ^ true!

----- Method: Binding>>isSpecialReadBinding (in category 'as yet unclassified') -----
isSpecialReadBinding
        ^ false!

----- Method: Binding>>isSpecialWriteBinding (in category 'as yet unclassified') -----
isSpecialWriteBinding
        ^ false!

----- Method: Binding>>objectForDataStream: (in category 'as yet unclassified') -----
objectForDataStream: refStream
        "It's not yet clear how serialization should work in the presence of environments"
       
        self shouldBeImplemented.!

----- Method: Binding>>printOn: (in category 'as yet unclassified') -----
printOn: aStream
        key printOn: aStream.
        aStream nextPutAll: '=>'.
        self value printOn: aStream!

----- Method: Binding>>source (in category 'as yet unclassified') -----
source
        ^ self!

Binding subclass: #ClassBinding
        instanceVariableNames: 'value'
        classVariableNames: ''
        poolDictionaries: ''
        category: 'Environments-Core'!

----- Method: ClassBinding class>>key:value: (in category 'as yet unclassified') -----
key: key value: value
        ^ self basicNew initializeWithKey: key value: value!

----- Method: ClassBinding>>asBinding: (in category 'as yet unclassified') -----
asBinding: aSymbol
        ^ aSymbol == key
                ifTrue: [self]
                ifFalse: [Alias key: aSymbol source: self]!

----- Method: ClassBinding>>canAssign (in category 'as yet unclassified') -----
canAssign
        ^ false!

----- Method: ClassBinding>>initializeWithKey:value: (in category 'as yet unclassified') -----
initializeWithKey: kObject value: vObject
        self initialize.
        key := kObject.
        value := vObject.!

----- Method: ClassBinding>>isSpecialWriteBinding (in category 'as yet unclassified') -----
isSpecialWriteBinding
        ^ true!

----- Method: ClassBinding>>literalEqual: (in category 'as yet unclassified') -----
literalEqual: other
        "Class bindings are equal when the bind the same class"
       
        ^ self species = other species and: [self value = other value]!

----- Method: ClassBinding>>value (in category 'as yet unclassified') -----
value
        ^ value!

----- Method: ClassBinding>>value: (in category 'as yet unclassified') -----
value: anObject
        (AttemptToWriteReadOnlyGlobal signal: 'Cannot store into read-only bindings')
                ifTrue: [value := anObject]!

Binding subclass: #Global
        instanceVariableNames: 'value'
        classVariableNames: ''
        poolDictionaries: ''
        category: 'Environments-Core'!

----- Method: Global class>>key:value: (in category 'as yet unclassified') -----
key: aSymbol value: anObject
        ^ self basicNew initializeWithKey: aSymbol value: anObject!

----- Method: Global>>asBinding: (in category 'as yet unclassified') -----
asBinding: aSymbol
        ^ aSymbol == key
                ifTrue: [self]
                ifFalse: [Alias key: aSymbol source: self]!

----- Method: Global>>initializeWithKey:value: (in category 'as yet unclassified') -----
initializeWithKey: aSymbol value: anObject
        self initialize.
        key := aSymbol.
        value := anObject!

----- Method: Global>>literalEqual: (in category 'as yet unclassified') -----
literalEqual: other
        "Globals are only equal to themselves, since another global with the same
        name could have a different value in the future."
       
        ^ self == other!

----- Method: Global>>value (in category 'as yet unclassified') -----
value
        ^ value!

----- Method: Global>>value: (in category 'as yet unclassified') -----
value: anObject
        value := anObject!

Notification subclass: #CurrentEnvironment
        instanceVariableNames: ''
        classVariableNames: ''
        poolDictionaries: ''
        category: 'Environments-Loading'!

----- Method: Symbol>>=> (in category '*environments') -----
=> anObject
       
        ^ anObject isBehavior
                ifTrue: [ClassBinding key: self value: anObject]
                ifFalse: [Global key: self value: anObject]!

Object subclass: #BindingPolicy
        instanceVariableNames: 'policy environment addSelector removeSelector'
        classVariableNames: ''
        poolDictionaries: ''
        category: 'Environments-Policies'!

----- Method: BindingPolicy class>>environment:policy:addSelector:removeSelector: (in category 'as yet unclassified') -----
environment: anEnvironment policy: aNamePolicy addSelector: addSelector removeSelector: removeSelector
        ^ self basicNew
                initializeWithEnvironment: anEnvironment
                policy: aNamePolicy
                addSelector: addSelector
                removeSelector: removeSelector!

----- Method: BindingPolicy>>binding:addedTo:notify: (in category 'events') -----
binding: aBinding addedTo: anEnvironment notify: anObject
        environment == anEnvironment ifTrue:
                [policy name: aBinding key do:
                        [:name || binding |
                        binding := aBinding asBinding: name.
                        anObject perform: addSelector with: binding]].
!

----- Method: BindingPolicy>>binding:removedFrom:notify: (in category 'events') -----
binding: aBinding removedFrom: anEnvironment notify: anObject
        environment == anEnvironment ifTrue:
                [policy name: aBinding key do:
                        [:name || binding |
                        binding := aBinding asBinding: name.
                        anObject perform: removeSelector with: binding]].
!

----- Method: BindingPolicy>>environment (in category 'accessing') -----
environment
        ^ environment!

----- Method: BindingPolicy>>initializeWithEnvironment:policy:addSelector:removeSelector: (in category 'initialize-release') -----
initializeWithEnvironment: anEnvironment
policy: aNamePolicy
addSelector: aSelector
removeSelector: rSelector
        self initialize.
        environment := anEnvironment.
        policy := aNamePolicy.
        addSelector := aSelector.
        removeSelector := rSelector!

----- Method: BindingPolicy>>name:do: (in category 'private') -----
name: aSymbol do: aBlock
        ^ policy name: aSymbol do: aBlock!

----- Method: BindingPolicy>>removeObserver: (in category 'initialize-release') -----
removeObserver: anEnvironment
        environment removeObserver: anEnvironment !

Object subclass: #Environment
        instanceVariableNames: 'info declarations bindings undeclared policies observers'
        classVariableNames: 'Default Instances'
        poolDictionaries: ''
        category: 'Environments-Core'!

!Environment commentStamp: 'cmm 12/20/2013 14:10' prior: 0!
I am a context for compiling methods. I maintain the namespace of classes and global variables that are visible to the methods compiled within me.

I have the following instance variables:

info <EnvironmentInfo>
Metadata about me and the code I contain.

imports <Import>
Rules for importing globals from other environments.

exports <Export>
Rules for exposing globals to other environments.

declarations <IdentityDictionary>
Bindings for globals that have been declared inside me.

references      <IdentityDictionary>
Bindings for globals that are used by methods compiled inside me.

public <IdentityDictionary>
Bindings for classes that have been declared inside me, and which satisfy the export rules contain in 'exports'.

undeclared      <Dictionary>
Bindings for globals that are used by methods compiled inside me, but which aren't present in 'references' and couldn't be found via the rules in 'imports'.!

----- Method: Environment class>>cleanUp (in category 'class initialization') -----
cleanUp
        self allInstancesDo:
                [:env | env purgeUndeclared]!

----- Method: Environment class>>current (in category 'accessing') -----
current
        ^ CurrentEnvironment signal ifNil: [self default]!

----- Method: Environment class>>default (in category 'accessing') -----
default
        ^ Default!

----- Method: Environment class>>default: (in category 'accessing') -----
default: anEnvironment
        Default := anEnvironment!

----- Method: Environment class>>initialize (in category 'class initialization') -----
initialize
        self install!

----- Method: Environment class>>install (in category 'class initialization') -----
install
        | smalltalk env |
        self environment class == self ifTrue:
                [Transcript
                        cr;
                        show: 'Can''t install environments; they''re already installed'.
                ^ self].

        smalltalk := Smalltalk globals.
        env := self basicNew initializeWithSystemDictionary: smalltalk.
        Default := env.
        Instances ifNil: [Instances := IdentityDictionary new].
        Instances at: env info name put: env.
        (smalltalk at: #Undeclared) becomeForward: (env at: #Undeclared).
        smalltalk becomeForward: env.
        Smalltalk garbageCollect.!

----- Method: Environment class>>named: (in category 'instance creation') -----
named: aSymbol
        | symbol |
        symbol := aSymbol asSymbol.
        ^ Instances
                at: symbol
                ifAbsentPut: [ self withName: symbol ]!

----- Method: Environment class>>uninstall (in category 'class initialization') -----
uninstall
        | globals sysdict |
        self environment class == self ifFalse:
                [Transcript
                        cr;
                        show: 'Can''t uninstall environments; they''re not currently installed'.
                ^ self].
       
        globals := Smalltalk globals instVarNamed: 'contents'.
        sysdict := SystemDictionary new: globals size.
        globals associationsDo: [:ea | sysdict add: ea].
        Smalltalk globals becomeForward: sysdict.!

----- Method: Environment class>>withName: (in category 'instance creation') -----
withName: aString
        ^ self basicNew initializeWithName: aString!

----- Method: Environment>>addAllBindings (in category 'updating') -----
addAllBindings
        declarations associationsDo:
                [:ea | self binding: ea addedTo: self]!

----- Method: Environment>>addObserver: (in category 'observing') -----
addObserver: anObject
        observers add: anObject!

----- Method: Environment>>allClasses (in category 'classes and traits') -----
allClasses
        ^ Array streamContents:
                [:out |
                self allClassesDo:
                        [:class |
                        out nextPut: class]]!

----- Method: Environment>>allClassesAndTraits (in category 'classes and traits') -----
allClassesAndTraits
        ^ Array streamContents:
                [:out | self allClassesAndTraitsDo:
                        [:value | out nextPut: value]]!

----- Method: Environment>>allClassesAndTraitsDo: (in category 'classes and traits') -----
allClassesAndTraitsDo: aBlock
        declarations keysAndValuesDo:
                [:key :value |
                ((value isBehavior) and: [key == value name]) ifTrue:
                        [aBlock value: value]]!

----- Method: Environment>>allClassesDo: (in category 'classes and traits') -----
allClassesDo: aBlock
        self allClassesAndTraitsDo:
                [:value | (value isKindOf: Class) ifTrue:
                        [aBlock value: value]]!

----- Method: Environment>>allTraits (in category 'classes and traits') -----
allTraits
        ^ Array streamContents:
                [:out |
                self allTraitsDo:
                        [:value | out nextPut: value]] !

----- Method: Environment>>allTraitsDo: (in category 'classes and traits') -----
allTraitsDo: aBlock
        self allClassesAndTraitsDo:
                [:value |
                value isTrait ifTrue:
                        [aBlock value: value]]!

----- Method: Environment>>associationAt: (in category 'emulating') -----
associationAt: aSymbol
        "Senders of this should probably be using #bindingOf:"
       
        self flag: #review.
        ^ declarations associationAt: aSymbol!

----- Method: Environment>>associationAt:ifAbsent: (in category 'emulating') -----
associationAt: aSymbol ifAbsent: aBlock
        "Senders of this should probably be using #bindingOf:"
       
        self flag: #review.
        ^ declarations associationAt: aSymbol ifAbsent: aBlock!

----- Method: Environment>>associationOrUndeclaredAt: (in category 'emulating') -----
associationOrUndeclaredAt: key
        ^ bindings associationAt: key ifAbsent:
                [undeclared at: key put: nil.
                undeclared associationAt: key]
        !

----- Method: Environment>>associationsDo: (in category 'emulating') -----
associationsDo: aBlock
        "Evaluate aBlock for each of the receiver's elements (key/value associations)."

        declarations associationsDo: aBlock!

----- Method: Environment>>at: (in category 'emulating') -----
at: aSymbol
        ^ declarations at: aSymbol!

----- Method: Environment>>at:ifAbsent: (in category 'emulating') -----
at: aSymbol ifAbsent: aBlock
        ^ declarations at: aSymbol ifAbsent: aBlock!

----- Method: Environment>>at:ifAbsentPut: (in category 'emulating') -----
at: aSymbol ifAbsentPut: aBlock
        ^self at: aSymbol ifAbsent: [
                self at: aSymbol put: aBlock value ]!

----- Method: Environment>>at:ifPresent: (in category 'emulating') -----
at: aSymbol ifPresent: aBlock
        ^ declarations at: aSymbol ifPresent: aBlock!

----- Method: Environment>>at:ifPresent:ifAbsent: (in category 'emulating') -----
at: aSymbol ifPresent: presentBlock ifAbsent: absentBlock
        ^ declarations
                at: aSymbol
                ifPresent: presentBlock
                ifAbsent: absentBlock.!

----- Method: Environment>>at:ifPresentAndInMemory: (in category 'emulating') -----
at: key ifPresentAndInMemory: aBlock
        ^ declarations
                at: key
                ifPresent:
                        [:v |
                        v isInMemory ifTrue:
                                [aBlock value: v]]!

----- Method: Environment>>at:put: (in category 'emulating') -----
at: aSymbol put: anObject
        ^ self bind: aSymbol to: anObject!

----- Method: Environment>>bind:to: (in category 'binding') -----
bind: aSymbol to: anObject
        | binding newBinding |
        newBinding := aSymbol => anObject.
       
        binding := declarations associationAt: aSymbol ifAbsent: [nil].
        binding ifNotNil:
                [binding class == newBinding class
                        ifTrue: [binding value: anObject]
                        ifFalse: [binding becomeForward: newBinding].
                ^anObject].
       
        binding := undeclared associationAt: aSymbol ifAbsent: [nil].
        binding
                ifNil: [binding := newBinding]
                ifNotNil:
                        [undeclared removeKey: aSymbol.
                        binding class == newBinding class
                                ifTrue: [binding value: anObject]
                                ifFalse: [binding becomeForward: newBinding]].
                       
        declarations add: binding.
        self binding: binding addedTo: self.
        ^anObject
!

----- Method: Environment>>binding:addedTo: (in category 'updating') -----
binding: aBinding addedTo: anEnvironment
        policies do:
                [:ea | ea binding: aBinding addedTo: anEnvironment notify: self]!

----- Method: Environment>>binding:removedFrom: (in category 'updating') -----
binding: aBinding removedFrom: anEnvironment
        policies do:
                [:ea | ea binding: aBinding removedFrom: anEnvironment notify: self]!

----- Method: Environment>>bindingOf: (in category 'binding') -----
bindingOf: aSymbol
        ^ self bindingOf: aSymbol ifAbsent: nil!

----- Method: Environment>>bindingOf:ifAbsent: (in category 'binding') -----
bindingOf: aSymbol ifAbsent: aBlock
        ^ bindings bindingOf: aSymbol ifAbsent: aBlock!

----- Method: Environment>>classAndTraitNames (in category 'classes and traits') -----
classAndTraitNames
        | names |
        names := Array streamContents:
                [:out |
                self allClassesAndTraitsDo:
                        [:value |
                        out nextPut: value name]].
        names sort.
        ^ names!

----- Method: Environment>>classNamed: (in category 'classes and traits') -----
classNamed: aString
        ^ self classOrTraitNamed: aString!

----- Method: Environment>>classNames (in category 'classes and traits') -----
classNames
        ^ (self allClasses collect: [:ea | ea name]) sort!

----- Method: Environment>>classOrTraitNamed: (in category 'classes and traits') -----
classOrTraitNamed: aString
        "aString is either a class or trait name or a class or trait name followed by ' class' or 'classTrait' respectively.
        Answer the class or metaclass it names."

        | meta baseName |
        (aString endsWith: ' class')
                ifTrue: [meta := true.
                                baseName := aString copyFrom: 1 to: aString size - 6]
                ifFalse: [
                        (aString endsWith: ' classTrait')
                                ifTrue: [
                                        meta := true.
                                        baseName := aString copyFrom: 1 to: aString size - 11]
                                ifFalse: [
                                        meta := false.
                                        baseName := aString]].

        ^declarations at: baseName asSymbol ifPresent:
                [ :global |
  global isBehavior ifTrue:
                        [ meta
                                ifFalse: [ global ]
                                ifTrue: [ global classSide ]]]!

----- Method: Environment>>declarationOf: (in category 'binding') -----
declarationOf: aSymbol
        ^ declarations bindingOf: aSymbol!

----- Method: Environment>>declarations (in category 'declaring') -----
declarations
        ^ Array streamContents:
                [:out | declarations associationsDo:
                        [:ea | out nextPut: ea]]!

----- Method: Environment>>destroy (in category 'initialize-release') -----
destroy
       
        self allClasses do: [:ea | ea removeFromSystem].
        declarations keys do: [:ea | self unbind: ea].
        policies do: [:ea | ea removeObserver: self].
        observers do: [:ea | ea stopObserving: self].!

----- Method: Environment>>do: (in category 'emulating') -----
do: aBlock
        "Evaluate aBlock for each of the receiver's values."

        self valuesDo: aBlock!

----- Method: Environment>>environment (in category 'emulating') -----
environment
        ^ self!

----- Method: Environment>>errorKeyNotFound: (in category 'private') -----
errorKeyNotFound: key
        "Signal KeyNotFound error"
        ^(KeyNotFound key: key) signal!

----- Method: Environment>>export: (in category 'configuring') -----
export: spec
        | policy |
        policy := BindingPolicy
                environment: self
                policy: (ExplicitNamePolicy spec: spec)
                addSelector: #notifyObserversOfBindingAdded:
                removeSelector: #notifyObserversOfBindingRemoved:.
        policies := policies copyWith: policy!

----- Method: Environment>>exportAddingPrefix: (in category 'configuring') -----
exportAddingPrefix: aString
        | policy |
        policy := BindingPolicy
                environment: self
                policy: (AddPrefixNamePolicy prefix: aString)
                addSelector: #notifyObserversOfBindingAdded:
                removeSelector: #notifyObserversOfBindingAdded:.
        policies := policies copyWith: policy!

----- Method: Environment>>exportRemovingPrefix: (in category 'configuring') -----
exportRemovingPrefix: aString
        | policy |
        policy := BindingPolicy
                environment: self
                policy: (RemovePrefixNamePolicy prefix: aString)
                addSelector: #notifyObserversOfBindingAdded:
                removeSelector: #notifyObserversOfBindingAdded:.
        policies := policies copyWith: policy!

----- Method: Environment>>exportSelf (in category 'configuring') -----
exportSelf
        | policy |
        policy := BindingPolicy
                environment: self
                policy: (AllNamePolicy new)
                addSelector: #notifyObserversOfBindingAdded:
                removeSelector: #notifyObserversOfBindingRemoved:.
        policies := policies copyWith: policy!

----- Method: Environment>>fileIn:announcing: (in category 'operations') -----
fileIn: aStream announcing: aString
        (EnvironmentLoader for: self)
                fileIn: aStream
                announcing: aString
!

----- Method: Environment>>flushClassNameCache (in category 'classes and traits') -----
flushClassNameCache
        "We don't have one"!

----- Method: Environment>>forgetClass:logged: (in category 'classes and traits') -----
forgetClass: aClass logged: aBool
        (self hasBindingOf: aClass name) ifFalse: [ ^ self ].
        aBool ifTrue:
                [SystemChangeNotifier uniqueInstance
                        classRemoved: aClass fromCategory: aClass category].
        self organization removeElement: aClass name.
        Smalltalk removeFromStartUpList: aClass.
        Smalltalk removeFromShutDownList: aClass.
        self unbind: aClass name!

----- Method: Environment>>from:import: (in category 'configuring') -----
from: anEnvironment import: spec
        | policy |
        policy := BindingPolicy
                environment: anEnvironment
                policy: (ExplicitNamePolicy spec: spec)
                addSelector: #showBinding:
                removeSelector: #hideBinding:.
        policies := policies copyWith: policy.
        anEnvironment addObserver: self.
        anEnvironment addAllBindings.!

----- Method: Environment>>hasBindingOf: (in category 'binding') -----
hasBindingOf: aSymbol
        ^ declarations includesKey: aSymbol!

----- Method: Environment>>hasClassNamed: (in category 'classes and traits') -----
hasClassNamed: aString
        Symbol hasInterned: aString ifTrue:
                [:symbol |
                ^ (declarations at: symbol ifAbsent: [nil])
                        isKindOf: Class].
        ^ false.!

----- Method: Environment>>hideBinding: (in category 'binding') -----
hideBinding: aBinding
        self undeclare: aBinding key from: bindings!

----- Method: Environment>>import: (in category 'configuring') -----
import: anEnvironment
        | policy |
        policy := BindingPolicy
                environment: anEnvironment
                policy: AllNamePolicy new
                addSelector: #showBinding:
                removeSelector: #hideBinding:.
        policies := policies copyWith: policy.
        anEnvironment addObserver: self.
        anEnvironment addAllBindings.!

----- Method: Environment>>import:addingPrefix: (in category 'configuring') -----
import: anEnvironment addingPrefix: aString
       
        | import |
        import := BindingPolicy
                environment: anEnvironment
                policy: (AddPrefixNamePolicy prefix: aString)
                addSelector: #showBinding:
                removeSelector: #hideBinding:.
        policies := policies copyWith: import.
        anEnvironment addObserver: self.
        anEnvironment addAllBindings.!

----- Method: Environment>>import:removingPrefix: (in category 'configuring') -----
import: anEnvironment removingPrefix: aString
       
        | import |
        import := BindingPolicy
                environment: anEnvironment
                policy: (RemovePrefixNamePolicy prefix: aString)
                addSelector: #showBinding:
                removeSelector: #hideBinding:.
        policies := policies copyWith: import.
        anEnvironment addObserver: self.
        anEnvironment addAllBindings.!

----- Method: Environment>>importSelf (in category 'configuring') -----
importSelf
        | policy |
        policy := BindingPolicy
                environment: self
                policy: AllNamePolicy new
                addSelector: #showBinding:
                removeSelector: #hideBinding:.
        policies := policies copyWith: policy.
       
        declarations associationsDo:
                [:ea | (bindings includesKey: ea key) ifFalse:
                        [bindings add: ea]]!

----- Method: Environment>>includes: (in category 'emulating') -----
includes: value
        ^ declarations includes: value!

----- Method: Environment>>includesKey: (in category 'emulating') -----
includesKey: key
        ^ declarations includesKey: key!

----- Method: Environment>>info (in category 'accessing') -----
info
        ^ info!

----- Method: Environment>>initialize (in category 'initialize-release') -----
initialize
        declarations := IdentityDictionary new.
        bindings := IdentityDictionary new.
        undeclared := IdentityDictionary new.
        policies := Array new.
        observers := IdentitySet new.!

----- Method: Environment>>initializeWithName: (in category 'initialize-release') -----
initializeWithName: aString
        | smalltalk |
        self initialize.
        info := EnvironmentInfo name: aString.
.
        smalltalk := SmalltalkImage basicNew.
        smalltalk globals: self.
        declarations at: #Smalltalk put: smalltalk.
        declarations at: #Undeclared put: undeclared.!

----- Method: Environment>>initializeWithSystemDictionary: (in category 'initialize-release') -----
initializeWithSystemDictionary: old
       
        self initialize.
        info := EnvironmentInfo
                name: 'Smalltalk'
                organization: old organization
                packages: PackageOrganizer default.
        old associationsDo: [:assc | declarations add: assc].
        (old at: #Undeclared) associationsDo: [:assc | undeclared add: assc].
        (declarations at: #Smalltalk) instVarNamed: 'globals' put: self.
        declarations at: #Undeclared put: undeclared.!

----- Method: Environment>>isUndeclared: (in category 'declaring') -----
isUndeclared: aSymbol
        ^ undeclared includesKey: aSymbol!

----- Method: Environment>>keyAtIdentityValue: (in category 'emulating') -----
keyAtIdentityValue: anObject
        ^ declarations keyAtIdentityValue: anObject.!

----- Method: Environment>>keyAtIdentityValue:ifAbsent: (in category 'emulating') -----
keyAtIdentityValue: anObject ifAbsent: aBlock
        ^ declarations keyAtIdentityValue: anObject ifAbsent: aBlock!

----- Method: Environment>>keyAtValue: (in category 'emulating') -----
keyAtValue: anObject
        ^ self keyAtIdentityValue: anObject!

----- Method: Environment>>keys (in category 'emulating') -----
keys
        ^ declarations keys!

----- Method: Environment>>keysAndValuesDo: (in category 'emulating') -----
keysAndValuesDo: aBlock
        ^self associationsDo: [:assoc |
                aBlock value: assoc key value: assoc value].!

----- Method: Environment>>keysDo: (in category 'emulating') -----
keysDo: aBlock
        "Evaluate aBlock for each of the receiver's keys."

        declarations keysDo: aBlock!

----- Method: Environment>>notifyObserversOfBindingAdded: (in category 'updating') -----
notifyObserversOfBindingAdded: aBinding
        observers do: [:ea | ea binding: aBinding addedTo: self]!

----- Method: Environment>>notifyObserversOfBindingRemoved: (in category 'updating') -----
notifyObserversOfBindingRemoved: aBinding
        observers do: [:ea | ea binding: aBinding removedFrom: self]!

----- Method: Environment>>objectForDataStream: (in category 'emulating') -----
objectForDataStream: refStrm
        | dp |
        "I am about to be written on an object file.  Write a reference to Smalltalk instead."

        dp := DiskProxy global: #Smalltalk selector: #globals args: #().
        refStrm replace: self with: dp.
        ^ dp!

----- Method: Environment>>organization (in category 'accessing') -----
organization
        ^ info organization!

----- Method: Environment>>poolUsers (in category 'emulating') -----
poolUsers
        "Answer a dictionary of pool name -> classes that refer to it.
        Also includes any globally know dictionaries (such as
        Smalltalk, Undeclared etc) which although not strictly
        accurate is potentially useful information"
        "Smalltalk poolUsers"
        | poolUsers |
        poolUsers := Dictionary new.
        self keys
                do: [:k | "yes, using isKindOf: is tacky but for reflective code like
                        this it is very useful. If you really object you can:-
                        a) go boil your head.
                        b) provide a better answer.
                        your choice."
                        | pool refs |
                        (((pool := self at: k) isKindOf: Dictionary)
                                        or: [pool isKindOf: SharedPool class])
                                ifTrue: [refs := (self systemNavigation allClasses
                                                                select: [:c | c sharedPools identityIncludes: pool]
                                                                thenCollect: [:c | c name]) asOrderedCollection.
                                        refs
                                                add: (self systemNavigation
                                                                allCallsOn: (self associationAt: k)).
                                        poolUsers at: k put: refs]].
        ^ poolUsers!

----- Method: Environment>>printOn: (in category 'printing') -----
printOn: aStream
        aStream nextPutAll: info name!

----- Method: Environment>>purgeUndeclared (in category 'declaring') -----
purgeUndeclared
        undeclared removeUnreferencedKeys!

----- Method: Environment>>recompileAll (in category 'operations') -----
recompileAll
        self allClassesAndTraits
                do: [:classOrTrait | classOrTrait compileAll]
                displayingProgress:[:classOrTrait| 'Recompiling ', classOrTrait]


!

----- Method: Environment>>remove:from:readdAfter: (in category 'private') -----
remove: binding from: aDictionary readdAfter: aBlock

        aDictionary
                removeKey: binding key
                ifAbsent: [ ^aBlock value ].
        ^aBlock ensure: [ aDictionary add: binding ]!

----- Method: Environment>>removeClassNamed: (in category 'classes and traits') -----
removeClassNamed: aString
        declarations
                at: aString asSymbol
                ifPresent: [:class | class removeFromSystem]
                ifAbsent:
                        [Transcript cr; show: 'Removal of class named ', aString,
                        ' ignored because ', aString, ' does not exist.']!

----- Method: Environment>>removeKey: (in category 'emulating') -----
removeKey: key
        "Remove key from the receiver.
        If key is not in the receiver, notify an error."
        self flag: #review.
        ^ self removeKey: key ifAbsent: [self errorKeyNotFound: key].!

----- Method: Environment>>removeKey:ifAbsent: (in category 'emulating') -----
removeKey: aSymbol ifAbsent: aBlock
        | binding |
        self flag: #review.

        (declarations includesKey: aSymbol) ifFalse: [^aBlock value].
        binding := (declarations associationAt: aSymbol).
        declarations removeKey: aSymbol.
        self
                binding: binding
                removedFrom: self.
        ^ binding value!

----- Method: Environment>>removeObserver: (in category 'observing') -----
removeObserver: anObject
        observers remove: anObject ifAbsent: []!

----- Method: Environment>>renameClass:as: (in category 'classes and traits') -----
renameClass: aClass as: newName
        ^self renameClass: aClass from: aClass name to: newName!

----- Method: Environment>>renameClass:from: (in category 'classes and traits') -----
renameClass: aClass from: oldName
        ^self renameClass: aClass from: oldName to: aClass name!

----- Method: Environment>>renameClass:from:to: (in category 'classes and traits') -----
renameClass: aClass from: oldName to: newName
        "Rename the class, aClass, to have the title newName."

        | oldBinding newBinding category |
        category := self organization categoryOfElement: oldName.
        self organization classify: newName under: category suppressIfDefault: true.
        self organization removeElement: oldName.
       
        oldBinding := self declarationOf: oldName.
        declarations removeKey: oldName.
        self binding: oldBinding removedFrom: self.
        " re-route now undeclared oldBinding "
        oldBinding value: aClass.

        newBinding := newName => aClass.
        aClass updateMethodBindingsTo: newBinding.
        declarations add: newBinding.
        self binding: newBinding addedTo: self.
       
        Smalltalk renamedClass: aClass from: oldName to: newName.
        SystemChangeNotifier uniqueInstance
                classRenamed: aClass
                from: oldName
                to: newName
                inCategory: category!

----- Method: Environment>>renameClassNamed:as: (in category 'classes and traits') -----
renameClassNamed: oldName as: newName
        declarations
                at: oldName
                ifPresent: [:class | class rename: newName]
                ifAbsent:
                        [Transcript cr; show: 'Class-rename for ', oldName,
                        ' ignored because ', oldName, ' does not exist.']!

----- Method: Environment>>scopeFor:from:envtAndPathIfFound: (in category 'emulating') -----
scopeFor: aSymbol from: lower envtAndPathIfFound: aBlock
        ^ (declarations includesKey: aSymbol)
                ifTrue: [aBlock value: self value: String new]
                !

----- Method: Environment>>select: (in category 'emulating') -----
select: aBlock
        ^ declarations select: aBlock!

----- Method: Environment>>showBinding: (in category 'binding') -----
showBinding: aBinding
        | binding |
        binding := undeclared associationAt: aBinding key ifAbsent: [nil].
        binding ifNotNil:
                [undeclared removeKey: binding key.
                binding becomeForward: aBinding].
       
        binding := bindings associationAt: aBinding key ifAbsent: [nil].
        binding ifNotNil:
                [bindings removeKey: binding key].
       
        bindings add: aBinding.!

----- Method: Environment>>stopObserving: (in category 'observing') -----
stopObserving: anEnvironment
        policies := policies reject: [:ea | ea environment == anEnvironment].!

----- Method: Environment>>storeDataOn: (in category 'emulating') -----
storeDataOn: aDataStream
        "I don't get stored.  Use a DiskProxy"

        self error: 'use a DiskProxy to store me'!

----- Method: Environment>>traitNames (in category 'classes and traits') -----
traitNames
        ^ self allTraits collect: [:ea | ea name]!

----- Method: Environment>>unbind: (in category 'binding') -----
unbind: aSymbol
        | binding |
        binding := declarations bindingOf: aSymbol ifAbsent: [^ self].
        undeclared declare: aSymbol from: declarations.
        declarations removeKey: aSymbol ifAbsent: [  ].
        [ undeclared at: aSymbol put: nil ]
                on: AttemptToWriteReadOnlyGlobal
                do: [ :n | n resume: true ].
        self binding: binding removedFrom: self!

----- Method: Environment>>undeclare: (in category 'declaring') -----
undeclare: aSymbol
        ^ (undeclared bindingOf: aSymbol) ifNil:
                [undeclared add: aSymbol => nil]!

----- Method: Environment>>undeclare:from: (in category 'declaring') -----
undeclare: aSymbol from: aNamespace
        | binding |
        binding := self undeclare: aSymbol.
        (aNamespace bindingOf: aSymbol) ifNotNil:
                [:old |
                aNamespace removeKey: aSymbol.
                old becomeForward: binding].
        ^ binding!

----- Method: Environment>>undeclared (in category 'accessing') -----
undeclared
        ^ undeclared!

----- Method: Environment>>valueOf: (in category 'binding') -----
valueOf: aSymbol
        ^ self valueOf: aSymbol ifAbsent: nil!

----- Method: Environment>>valueOf:ifAbsent: (in category 'binding') -----
valueOf: aSymbol ifAbsent: aBlock
        ^ (self bindingOf: aSymbol ifAbsent: [^ aBlock value]) value!

----- Method: Environment>>valuesDo: (in category 'emulating') -----
valuesDo: aBlock
        "Evaluate aBlock for each of the receiver's values."

        declarations valuesDo: aBlock!

----- Method: Environment>>veryDeepCopyWith: (in category 'emulating') -----
veryDeepCopyWith: aCopier
        ^ self!

Object subclass: #EnvironmentInfo
        instanceVariableNames: 'name organization packages'
        classVariableNames: ''
        poolDictionaries: ''
        category: 'Environments-Core'!

----- Method: EnvironmentInfo class>>name: (in category 'create') -----
name: aString
        ^ self
                name: aString
                organization: (SystemOrganizer defaultList: Array new)
                packages: PackageOrganizer new.
        !

----- Method: EnvironmentInfo class>>name:organization:packages: (in category 'create') -----
name: aString organization: aSystemOrganizer packages: aPackageOrganizer
        ^ self basicNew
                initializeWithName: aString
                organization: aSystemOrganizer
                packages: aPackageOrganizer!

----- Method: EnvironmentInfo>>initializeWithName:organization:packages: (in category 'initializing') -----
initializeWithName: aString organization: aSystemOrganizer packages: aPackageOrganizer
        self initialize.
        name := aString asSymbol.
        organization := aSystemOrganizer.
        packages := aPackageOrganizer.!

----- Method: EnvironmentInfo>>name (in category 'access') -----
name
        ^ name!

----- Method: EnvironmentInfo>>organization (in category 'access') -----
organization
        ^ organization!

----- Method: EnvironmentInfo>>packages (in category 'access') -----
packages
        ^ packages!

----- Method: EnvironmentInfo>>printOn: (in category 'printing') -----
printOn: aStream
        aStream nextPutAll: name.
        aStream nextPutAll: 'Info'!

Object subclass: #EnvironmentLoader
        instanceVariableNames: 'environment'
        classVariableNames: ''
        poolDictionaries: ''
        category: 'Environments-Loading'!

----- Method: EnvironmentLoader class>>for: (in category 'as yet unclassified') -----
for: anEnvironment
        ^ self basicNew initializeWithEnvironment: anEnvironment!

----- Method: EnvironmentLoader>>evaluate: (in category 'as yet unclassified') -----
evaluate: chunk
        ^ [Compiler evaluate: chunk environment: environment]
                on: CurrentEnvironment
                do: [:req | req resume: environment]!

----- Method: EnvironmentLoader>>evaluate:logged: (in category 'as yet unclassified') -----
evaluate: chunk logged: aBoolean
        ^ [Compiler evaluate: chunk environment: environment logged: aBoolean]
                on: CurrentEnvironment
                do: [:req | req resume: environment]!

----- Method: EnvironmentLoader>>fileIn:announcing: (in category 'as yet unclassified') -----
fileIn: aStream announcing: aString
        | val |
        self logStart: aStream name.
        aString displayProgressFrom: 0 to: aStream size during:
                [:bar |
                [aStream atEnd] whileFalse:
                        [bar value: aStream position.
                        aStream skipSeparators.
                        [val := self fileInChunkFrom: aStream]
                                on: InMidstOfFileinNotification
                                do: [:ex | ex resume: true].
                        aStream skipStyleChunk].
                aStream close].
        self logEnd: aStream name.
        ^ val!

----- Method: EnvironmentLoader>>fileInChunkFrom: (in category 'as yet unclassified') -----
fileInChunkFrom: aStream
        | chunk |
        ^ (aStream peekFor: $!!)
                ifTrue: [
                        | reader |
                        chunk := aStream nextChunk.
                        reader := self evaluate: chunk logged: false.
                        reader scanFrom: aStream environment: environment]
                ifFalse: [
                        chunk := aStream nextChunk.
                        aStream checkForPreamble: chunk.
                        self evaluate: chunk logged: true ]!

----- Method: EnvironmentLoader>>initializeWithEnvironment: (in category 'as yet unclassified') -----
initializeWithEnvironment: anEnvironment
        self initialize.
        environment := anEnvironment!

----- Method: EnvironmentLoader>>logEnd: (in category 'as yet unclassified') -----
logEnd: filename
        "Note:  The main purpose of this banner is to flush the changes file."
        Smalltalk logChange: '----End fileIn of ' , filename , ' into ', environment name, '----' !

----- Method: EnvironmentLoader>>logStart: (in category 'as yet unclassified') -----
logStart: filename
        Smalltalk logChange: '----Start fileIn of ' , filename , ' into ' , environment name , '----'!

Object subclass: #NamePolicy
        instanceVariableNames: ''
        classVariableNames: ''
        poolDictionaries: ''
        category: 'Environments-Policies'!

NamePolicy subclass: #AddPrefixNamePolicy
        instanceVariableNames: 'prefix'
        classVariableNames: ''
        poolDictionaries: ''
        category: 'Environments-Policies'!

----- Method: AddPrefixNamePolicy class>>prefix: (in category 'as yet unclassified') -----
prefix: aString
        ^ self basicNew initializeWithPrefix: aString!

----- Method: AddPrefixNamePolicy>>initializeWithPrefix: (in category 'as yet unclassified') -----
initializeWithPrefix: aString
        self initialize.
        prefix := aString!

----- Method: AddPrefixNamePolicy>>name:do: (in category 'overriding') -----
name: aSymbol do: aBlock
        ^ (aSymbol beginsWith: prefix) ifFalse:
                [aBlock value: (prefix, aSymbol) asSymbol].
        !

NamePolicy subclass: #AllNamePolicy
        instanceVariableNames: ''
        classVariableNames: ''
        poolDictionaries: ''
        category: 'Environments-Policies'!

----- Method: AllNamePolicy>>name:do: (in category 'as yet unclassified') -----
name: aSymbol do: aBlock
        ^ aBlock value: aSymbol!

NamePolicy subclass: #ExplicitNamePolicy
        instanceVariableNames: 'aliases'
        classVariableNames: ''
        poolDictionaries: ''
        category: 'Environments-Policies'!

----- Method: ExplicitNamePolicy class>>aliases: (in category 'as yet unclassified') -----
aliases: aCollection
        ^ self basicNew initializeWithAliases: aCollection!

----- Method: ExplicitNamePolicy class>>flattenSpec:into: (in category 'create') -----
flattenSpec: anObject into: names
        anObject isSymbol ifTrue:
                [^ names at: anObject put: anObject].
        anObject isVariableBinding ifTrue:
                [^ names add: anObject].
        anObject isDictionary ifTrue:
                [^ names addAll: anObject].
        anObject do:
                [:ea | self flattenSpec: ea into: names]!

----- Method: ExplicitNamePolicy class>>spec: (in category 'create') -----
spec: anObject
        | aliases |
        (anObject isKindOf: NamePolicy) ifTrue: [^ anObject].
        aliases := IdentityDictionary new.
        self flattenSpec: anObject into: aliases.
        ^ self aliases: aliases!

----- Method: ExplicitNamePolicy>>initializeWithAliases: (in category 'as yet unclassified') -----
initializeWithAliases: aCollection
        self initialize.
        aliases := IdentityDictionary withAll: aCollection!

----- Method: ExplicitNamePolicy>>name:do: (in category 'overriding') -----
name: aSymbol do: aBlock
        ^ aBlock value: (aliases at: aSymbol ifAbsent: [^ nil])!

----- Method: NamePolicy>>name:do: (in category 'as yet unclassified') -----
name: aSymbol do: aBlock
        self subclassResponsibility!

NamePolicy subclass: #RemovePrefixNamePolicy
        instanceVariableNames: 'prefix'
        classVariableNames: ''
        poolDictionaries: ''
        category: 'Environments-Policies'!

----- Method: RemovePrefixNamePolicy class>>prefix: (in category 'as yet unclassified') -----
prefix: aString
        ^ self basicNew initializeWithPrefix: aString!

----- Method: RemovePrefixNamePolicy>>initializeWithPrefix: (in category 'as yet unclassified') -----
initializeWithPrefix: aString
        self initialize.
        prefix := aString!

----- Method: RemovePrefixNamePolicy>>name:do: (in category 'overriding') -----
name: aSymbol do: aBlock
        ^ (aSymbol beginsWith: prefix)
                ifTrue: [aBlock value: (aSymbol allButFirst: prefix size) asSymbol]!

----- Method: ReadOnlyVariableBinding>>asBinding: (in category '*environments') -----
asBinding: aSymbol
        ^ ClassBinding key: aSymbol value: value!

----- Method: Association>>asBinding: (in category '*environments') -----
asBinding: aSymbol
        ^ aSymbol == key
                ifTrue: [self]
                ifFalse: [Alias key: aSymbol source: self]!