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'! |
Free forum by Nabble | Edit this page |