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