[Pkg] The Trunk: Environments-cwp.1.mcz

[commits at source.squeak.org]

Colin Putney uploaded a new version of Environments to project The Trunk:
http://source.squeak.org/trunk/Environments-cwp.1.mcz

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

Name: Environments-cwp.1
Author: cwp
Time: 20 July 2012, 11:55:20.793 am
UUID: aa58b5e6-eb76-4ef3-9299-e2407616aebe
Ancestors: 

Introduce environments.

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

SystemOrganization addCategory: #'Environments-Core'!

Object subclass: #Environment
	instanceVariableNames: 'contents lookup undeclared exports info'
	classVariableNames: 'Default'
	poolDictionaries: ''
	category: 'Environments-Core'!

----- Method: Environment class>>default (in category 'as yet unclassified') -----
default
	^ Default!

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

----- Method: Environment class>>install (in category 'as yet unclassified') -----
install
	| smalltalk env |
	self environment class == self ifTrue: [self error: 'Already installed'].
	smalltalk := Smalltalk globals.
	env := self basicNew initializeWithSystemDictionary: smalltalk.
	(smalltalk at: #Undeclared) becomeForward: (env at: #Undeclared).
	smalltalk becomeForward: env.
	Smalltalk garbageCollect.!

----- Method: Environment class>>name: (in category 'as yet unclassified') -----
name: aString
	^ self basicNew initializeWithName: aString!

----- 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
	contents 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 'accessing') -----
associationAt: aSymbol
	"Senders of this should probably be using #bindingOf:"
	
	self flag: #review.
	^ contents associationAt: aSymbol!

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

----- Method: Environment>>associationOrUndeclaredAt: (in category 'compatibility') -----
associationOrUndeclaredAt: key
	lookup do:
		[:ns | (ns includesKey: key) ifTrue: [^ ns associationAt: key]].
	undeclared at: key put: nil.
	^ undeclared associationAt: key!

----- Method: Environment>>at: (in category 'accessing') -----
at: aSymbol
	^ contents at: aSymbol!

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

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

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

----- Method: Environment>>at:put: (in category 'accessing') -----
at: aSymbol put: anObject
	(contents includesKey: aSymbol) ifFalse:
		[contents declare: aSymbol from: undeclared].
	contents at: aSymbol put: anObject.
	anObject isBehavior ifTrue:
		[(contents associationAt: aSymbol) beReadOnlyBinding].
	^ anObject!

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

----- Method: Environment>>bindingOf:ifAbsent: (in category 'binding') -----
bindingOf: aSymbol ifAbsent: aBlock
	lookup do:
		[:dict | 
		(dict includesKey: aSymbol) ifTrue: 
			[^ dict associationAt: aSymbol]].
	^ undeclared associationAt: 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]].

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

----- Method: Environment>>destroy (in category 'initialize-release') -----
destroy
	self allClasses do: [:ea | ea removeFromSystem]!

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

----- Method: Environment>>export: (in category 'configuring') -----
export: aSymbol
	exports add: (contents associationAt: aSymbol)!

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

----- Method: Environment>>fileIn:announcing: (in category 'operations') -----
fileIn: aStream announcing: aString
	self shouldBeImplemented.
"	(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
	aBool ifTrue: 
		[SystemChangeNotifier uniqueInstance 
			classRemoved: aClass fromCategory: aClass category].
	self organization removeElement: aClass name.
	Smalltalk removeFromStartUpList: aClass.
	Smalltalk removeFromShutDownList: aClass.
	contents removeKey: aClass name ifAbsent: [].
	!

----- Method: Environment>>hasBindingThatBeginsWith: (in category 'binding') -----
hasBindingThatBeginsWith: aString
	lookup do:
		[:dict |
		dict associationsDo:
			[:asc | (asc key beginsWith: aString) ifTrue: 
				[^ true]]].
	^ false!

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

----- Method: Environment>>importEnvironment: (in category 'configuring') -----
importEnvironment: anEnvironment
	lookup := lookup copyWith: anEnvironment exports!

----- Method: Environment>>importSmalltalk (in category 'configuring') -----
importSmalltalk
	lookup := lookup copyWith: Smalltalk globals!

----- Method: Environment>>includes: (in category 'compatibility') -----
includes: key
	^ contents includes: key!

----- Method: Environment>>includesKey: (in category 'compatibility') -----
includesKey: key
	^ contents includesKey: key!

----- Method: Environment>>initialize (in category 'initialize-release') -----
initialize
	undeclared := IdentityDictionary new.
	contents := IdentityDictionary new.
	lookup := {contents}.
	exports := contents.
!

----- Method: Environment>>initializeWithName: (in category 'initialize-release') -----
initializeWithName: aString
	| smalltalk |
	self initialize.
	info := EnvironmentInfo name: aString.
.
	smalltalk := SmalltalkImage basicNew.
	smalltalk globals: self.
	contents at: #Smalltalk put: smalltalk.
	contents 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 | contents add: assc].
	(old at: #Undeclared) associationsDo: [:assc | undeclared add: assc].
	(contents at: #Smalltalk) instVarNamed: 'globals' put: self.
	contents at: #Undeclared put: undeclared.!

----- Method: Environment>>keyAtIdentityValue: (in category 'compatibility') -----
keyAtIdentityValue: anObject
	^ contents keyAtIdentityValue: anObject.!

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

----- Method: Environment>>keys (in category 'compatibility') -----
keys
	^ contents keys!

----- Method: Environment>>objectForDataStream: (in category 'compatibility') -----
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>>printOn: (in category 'printing') -----
printOn: aStream
	aStream nextPutAll: info name!

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

----- 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."

	| oldref category |
	category := self organization categoryOfElement: oldName.
	self organization classify: newName under: category suppressIfDefault: true.
	self organization removeElement: oldName.
	oldref := self associationAt: oldName.
	contents removeKey: oldName.
	oldref key: newName.
	contents add: oldref. 
	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
	contents
		at: oldName
		ifPresent: [:class | class rename: newName]
		ifAbsent:
			[Transcript cr; show: 'Class-rename for ', oldName, 
			' ignored because ', oldName, ' does not exist.']!

----- Method: Environment>>requireExplicitExports (in category 'configuring') -----
requireExplicitExports
	exports == contents ifTrue: 
		[exports := IdentityDictionary new]!

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

----- Method: Environment>>select: (in category 'compatibility') -----
select: aBlock
	^ contents select: aBlock!

----- Method: Environment>>storeDataOn: (in category 'compatibility') -----
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>>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
	lookup do:
		[:dict |
		dict at: aSymbol ifPresent: 
			[:value | ^ value]].
	^ aBlock value!

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

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

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

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

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

----- Method: EnvironmentInfo>>name (in category 'as yet unclassified') -----
name
	^ name!

----- Method: EnvironmentInfo>>organization (in category 'as yet unclassified') -----
organization
	^ organization!

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