[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