[Pkg] The Trunk: Environments-cwp.1.mcz
commits at source.squeak.org
commits at source.squeak.org
Fri Jul 27 00:33:16 UTC 2012
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'!
More information about the Packages
mailing list