The Inbox: Environments-cwp.1.mcz

A new version of Environments was added to project The Inbox:
http://source.squeak.org/inbox/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'!

On Fri, Jul 20, 2012 at 11:55 AM,  <[hidden email]> wrote:

This is a first step: basic implementation of Environment, plus a test
case (Tests-cwp.150) and a tweak to LookupKey (Collections-cwp.470)
that's necessary to let the tests pass.

Here's how I see the roadmap:

Replace SystemDictionary
    - move these packages over to trunk
    - replace the SystemDictionary in Smalltalk globals with an
Environment (see Environment class>>install)
    - fix bugs and tweak code that manipulates globals

Refactor the Compiler
    - introduce CompilationContext and the protocol that uses it
    - make the existing public protocol of Compiler call through the
new protocol
    - fix bugs and tweak Compiler clients where that makes sense

Implement FileIn
    - Introduce EnvironmentLoader
    - refactor the fileIn code to use it
    - fix bugs and tweak fileIn clients where that makes sense

Implement tool support
    - Update Browser and friends to be environment-aware
    - Update Monticello to be environment-aware
    - fix bugs

I think those are major bits needed for Squeak 4.4. There are
undoubtedly pieces that aren't obvious now, but I doubt there's
anything big hidden in the weeds. Note that there's nothing here that
requires multiple environments, or even exposes environments to the
casual programmer. Squeak 4.4 should ship with a single environment,
plus the capability to create more, if you know what you're doing.

Colin