[squeak-dev] Squeak 4.6: Environments-cmm.57.mcz
commits at source.squeak.org
commits at source.squeak.org
Fri Jun 5 20:24:06 UTC 2015
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]!
More information about the Squeak-dev
mailing list
|