[Modules] From here to there

Henrik Gedenryd Henrik.Gedenryd at lucs.lu.se
Sat Aug 25 18:00:23 UTC 2001


> it would be very helpful if you were cut a bit of slack in the early stages.
> A lot of slack would be better.  In particular, I've been thinking that it
> might be useful if you were to go ahead and introduce modules now, but in a
> fashion where they are more or less just decorations.

Les,

this is an excellent point! The 'modularity of modules' faction awards you
an instant honorary doctorate. (It's probably one of those dubious degrees
that spam emails want to sell you, but hey, it's the thought that counts.)

In bringing this idea forward, I think the crucial point is to decide just
how much 'real meaning' (vs. just decorations) these lightweight modules
should have. There is a trade-off here: functionality that we leave out will
not be debugged and improved to working quality. So a Goldilocks balance
would be desirable.

So what we need next is to figure out just what would go into such a
solution. If you recall my posting "[Modules] Let's get things rolling
soon", much of it applies to this question. The idea was to put out
something soon that contains just precisely what has to be there at first,
and then collectively build from there.

I have been hacking up a Modules prototype derived from Dan's Environments,
and after thinking just a little about just what would go into your
lightweight scheme, and with the KISS approach I took, I don't think they
are very far apart.

I'd like to see others' thoughts as well about what should go into this
lightweight scheme. But I think as much of the modularity functionality as
possible should be placed there, but be designed with a consistent 'opt-in',
non-forcive policy.

And we could use some code analysis tools rather early on, too. (There are
some seeds already.)

Ok, I have more comments but I'll post the code now for your weekend hacking
pleasure, and return with more comments later. This is Squeak3.1a-4261 code,
it should work with 4282 but I just haven't tried it.

A couple of notes:

1. This is a prototype/hack-up, don't take it too seriously. It is highly
incomplete, buggy, unfinished, etc etc. Beware of the two-headed calf!

2. Compare it with my writeup of a modularity proposal. This follows to the
proposal but does not cover it all yet though. There are some hints for an
all-encompassing name space, such as Andrew Black suggested. These are just
hints so far.

3. Instructions in the first preamble.

4. Note Dan's rudimentary code analysis tools, and his beautiful solution
that hunts down and rewrites global references in the source code.

5. The core is in the category System-Modules, it is rather small. The rest
is a bunch of patches to make the rest of the system follow this regime (but
just barely so far).

Henrik



-------------- next part --------------
'From Squeak3.1alpha of 7 March 2001 [latest update: #4261] on 22 August 2001 at 10:46:30 pm'!
"Change Set:		Dog Days Modules prototype
Date:			22 August 2001
Author:			Henrik Gedenryd

This is a one-day hacked-up prototype for a Module system, based on Dan Ingalls' Environments code. The core is in the category System-Modules, it is rather small. The rest is a bunch of patches to make the rest of the system follow this regime.

After filing in all change sets, in the Explorer that opens on the module hierarchy, try:

	'hack to create a module'
	
Module fromPath: #(Test Module1) forceCreate: true.

	'create class in it'

Object subclass: #TestClass
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	module: Test Module1
	category: 'Modules-Test'

- now browse to this module in the explorer, see the class there, the change set, etc.

- Converting some system categories to this scheme:

Module reorganizeSome.

(You can now open a change sorter to see the rewritten references in the various change sets (there is one set per module). The change sorter can't find them yet, do cmd-m on a selector to get the method.).

-- A demo of the crude repository prototype:

- look at root module's repository object, and send it #url (look at returned string)

- now try it on Module1's repository

- now set an explicit repository for the Test module:

self repository:(HTTPRepository new url: 'http://repository.test.org/Test')

- now send url to Module1's repository to see the new location

-- The point of this is to have a shared module hierarchy for all Squeak content, while allowing different subtrees to use different repositories in a free manner

"!

 Object subclass: #Module
	instanceVariableNames: 'name parentModule submodules usedModules importedModules definedNames exportedNames annotations repository activeChangeSet '
	classVariableNames: 'VirtualRoot '
	poolDictionaries: ''
	category: 'System-Modules'!

!Module commentStamp: 'hg 8/20/2001 21:02' prior: 0!
This is the Dog Days prototype for a Module and Repository system for Squeak. It was hacked up in an afternoon. The Swedish term RštmŒnad is really more suitable than the English "Dog Days".



"The period between 23 July and 23 August is nicknamed 'RštmŒnad' - literally 'rotting month', but also referred to as 'dog days', when food rots quicker than usual (...)

In damp, warm weather, bacteria thrive. If you hurt yourself, the wound is more likely to become infected than usual. 

In the old days, this particular month was known as a time when anything could happen. People thought for instance that calves could be born with two heads. Such strange occurences became known as 'rotting-month events'." <http://www.inv.se/svefa/tradition/engtrad/engrotmanad.html>!
]style[(709 58 1)f1,f1Rhttp://www.inv.se/svefa/tradition/engtrad/engrotmanad.html;,f1!

 Object subclass: #Repository
	instanceVariableNames: 'module '
	classVariableNames: 'Root '
	poolDictionaries: ''
	category: 'System-Modules'!
 Repository subclass: #HTTPRepository
	instanceVariableNames: 'url '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Modules'!
 Repository subclass: #RemoteRepository
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Modules'!
 SystemDictionary subclass: #RootDictionary
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Modules'!

!RootDictionary commentStamp: 'hg 8/22/2001 18:46' prior: 0!
This is a replacement for SystemDictionary that should handle backward compatibility with the old-style use of #Smalltalk as the global SystemDictionary.

In the new scheme, the many roles of the old-style Smalltalk should be split up into the proper places. For example, many methods have to do with communication with the VM and such. 

All accesses to Smalltalk in the role of a global namespace should be rerouted to the Root module (not the RootDictionary). Even when global names haven't been moved into modules, there should be a Root module installed to handle things properly.!

Smalltalk renameClassNamed: #RootModule as: #VirtualRootModule!
 Module subclass: #VirtualRootModule
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Modules'!

!VirtualRootModule commentStamp: 'hg 8/22/2001 18:52' prior: 0!
This is the special Module that is the virtual root of the whole Module hierarchy. This is based on the notion of a "virtual module hierarchy".

The idea is to use a single, shared "virtual" Module hierarchy for all Squeak modules, so that all Squeak modules will have unique "canonical" names. This does not mean that all modules need to physically reside in the same place (hence a "virtual" hierarchy). 

For instance, if Company X wants to set up its own private server which no one else can access, they can do so, but the module tree at this server will still have a special place in the virtual hierarchy. They get this place by simply reserving e.g. the Module #(com CompanyX) in the registry for the virtual hierarchy. Thus a top-level ModuleY that they develop will have the "canonical" name #(com CompanyX ModuleY) Hence there will not be a name clash if someone else develops a module having the name ModuleY.

This class also has the unrewarding role of superseding Smalltalk in the role of a global namespace. Thus old-style messages to Smalltalk in that role should be rerouted to the Root module (not the RootDictionary). Even when global names haven't been moved into modules, there should be a Root module installed to handle things properly.!

 RemoteRepository subclass: #VirtualRootRepository
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Modules'!

!Class methodsFor: 'organization' stamp: 'hg 8/21/2001 22:02'!
module

	^environment ifNil: [Root]! !

!Class methodsFor: 'organization' stamp: 'hg 8/21/2001 14:18'!
module: aModule

	environment _ aModule! !


!Metaclass methodsFor: 'accessing' stamp: 'hg 8/21/2001 14:15'!
module
	^thisClass module! !


!Module methodsFor: 'accessing' stamp: 'hg 8/21/2001 22:01'!
definedNames

	^definedNames! !

!Module methodsFor: 'accessing' stamp: 'hg 8/21/2001 14:05'!
exportedDictionary
	"return the dictionary of external definitions"

	^exportedNames! !

!Module methodsFor: 'accessing' stamp: 'hg 8/21/2001 14:13'!
importedDictionaries
	"return the dictionaries that contain the definitions for all my imports"

	^importedModules collect: [:mod | mod exportedDictionary]! !

!Module methodsFor: 'accessing' stamp: 'squeak 8/20/2001 18:02'!
name

	^ name ifNil: ['no name #' , self hash printString]! !

!Module methodsFor: 'accessing' stamp: 'squeak 8/20/2001 19:07'!
parentModule

	^parentModule! !

!Module methodsFor: 'accessing' stamp: 'squeak 8/20/2001 18:51'!
repository 

	^repository! !

!Module methodsFor: 'accessing' stamp: 'hg 8/22/2001 21:56'!
repository: aRepository

	repository _ aRepository! !

!Module methodsFor: 'accessing' stamp: 'hg 8/21/2001 16:43'!
submodules

	^submodules! !

!Module methodsFor: 'initializing' stamp: 'squeak 8/20/2001 17:23'!
initialize

	submodules _ OrderedCollection new.
	usedModules _ OrderedCollection new.
	importedModules _ OrderedCollection new.

	definedNames _ IdentityDictionary new.
	exportedNames _ IdentityDictionary new.

	annotations _ Dictionary new.
! !

!Module methodsFor: 'initializing' stamp: 'squeak 8/20/2001 18:53'!
name: aString parentModule: parent
	parentModule _ parent.
	name _ aString asSymbol.
	
	repository _ parent repository subrepositorySpecies on: self
! !

!Module methodsFor: 'compatibility' stamp: 'hg 8/22/2001 22:16'!
doesNotUnderstand: aMessage
	"emulate uppercase accessor messages for exports"

	| accessedName |
	accessedName _ aMessage selector.
	^self exportedDefinitionFor: accessedName ifAbsent: [
			submodules detect: [:sub | sub name = accessedName] 
						ifNone: [super doesNotUnderstand: aMessage]]
	! !

!Module methodsFor: 'compatibility' stamp: 'hg 8/22/2001 22:16'!
organization

	^SystemOrganization ! !

!Module methodsFor: 'compatibility' stamp: 'hg 8/22/2001 20:07'!
removeClassFromSystem: aClass logged: aBool
	"Delete the class, aClass, from the system, but log the removal neither to the current change set nor to the changes log"
	aBool ifTrue:[
		aClass wantsChangeSetLogging ifTrue:
			[self changes noteRemovalOf: aClass].
		aClass acceptsLoggingOfCompilation ifTrue:
			[Smalltalk logChange:  self fullPathAsMessages, ' removeClassNamed: #', aClass name].
	].
	SystemOrganization removeElement: aClass name.
	Smalltalk removeFromStartUpList: aClass.
	Smalltalk removeFromShutDownList: aClass.
	self removeName: aClass name.
	Smalltalk flushClassNameCache
! !

!Module methodsFor: 'accessing defined names' stamp: 'hg 8/21/2001 18:31'!
allClassesDo: aBlock
	"Evaluate the argument, aBlock, for each class in this module."

	definedNames valuesDo: [:value | 
		(value isKindOf: Class) ifTrue: [aBlock value: value]]
! !

!Module methodsFor: 'accessing defined names' stamp: 'hg 8/21/2001 13:50'!
associationFor: aString ifAbsent: aBlock
	"look up definition for the given symbol, and proceed into imported modules"

	| assoc |
	^self localAssocFor: aString ifAbsent: [
		importedModules do: [:module |
				"should really use ifPresent: instead of nil test to be picky"
			assoc _ module exportedAssocFor: aString ifAbsent: [nil].
			assoc ifNotNil: [^assoc]].
		^aBlock value].	"not found"
	! !

!Module methodsFor: 'accessing defined names' stamp: 'hg 8/21/2001 13:41'!
definitionFor: aString ifAbsent: aBlock
	"look up definition for the given symbol, and proceed into imported modules"

	| noHit def |
	^self localDefinitionFor: aString ifAbsent: [
		noHit _ #'!!!!notFound'.
		importedModules do: [:module |
				"should really use ifPresent: instead of nil test to be picky"
			def _ module exportedDefinitionFor: aString ifAbsent: [noHit].
			def == noHit ifFalse: [^def]].
		^aBlock value].	"not found"
	! !

!Module methodsFor: 'accessing defined names' stamp: 'hg 8/21/2001 22:15'!
definitionFor: aString ifPresent: aBlock

	| v |
	v _ self definitionFor: aString ifAbsent: [^ nil].
	^ aBlock value: v	! !

!Module methodsFor: 'accessing defined names' stamp: 'hg 8/21/2001 13:51'!
exportedAssocFor: aString ifAbsent: aBlock
	"look up external definition for the given name"

	^exportedNames associationAt: aString asSymbol ifAbsent: aBlock
	! !

!Module methodsFor: 'accessing defined names' stamp: 'hg 8/21/2001 13:44'!
exportedDefinitionFor: aString ifAbsent: aBlock
	"look up external definition for the given name"

	^exportedNames at: aString asSymbol ifAbsent: aBlock
	! !

!Module methodsFor: 'accessing defined names' stamp: 'hg 8/21/2001 14:13'!
keyAtIdentityValue: value ifAbsent: exceptionBlock
	"Answer the key that is the external name for the argument.
	SystemDictionary compatibility."
 
	| key |
	^definedNames keyAtIdentityValue: value ifAbsent: [
		self importedDictionaries do: [:dict |
			key _ dict keyAtIdentityValue: value ifAbsent: [nil].
			key ifNotNil: [^key]].
		^exceptionBlock value]
	! !

!Module methodsFor: 'accessing defined names' stamp: 'hg 8/21/2001 15:56'!
localAssocFor: aString ifAbsent: aBlock
	"look up assoc for the given name. only look locally"

	^definedNames associationAt: aString asSymbol ifAbsent: aBlock
	! !

!Module methodsFor: 'accessing defined names' stamp: 'hg 8/21/2001 13:42'!
localDefinitionFor: aString ifAbsent: aBlock
	"look up definition for the given name. only look locally"

	^definedNames at: aString asSymbol ifAbsent: aBlock
	! !

!Module methodsFor: 'changing defined names' stamp: 'hg 8/21/2001 22:40'!
addAssoc: assoc export: exportIt

	assoc key first isUppercase ifFalse: [self error: 'global names must be Capitalized'].
	definedNames add: assoc.
	exportIt ifTrue: [exportedNames add: assoc]
	! !

!Module methodsFor: 'changing defined names' stamp: 'hg 8/21/2001 18:19'!
defineName: aString as: value export: exportIt

	self addAssoc: (aString asSymbol)->value export: exportIt! !

!Module methodsFor: 'changing defined names' stamp: 'hg 8/21/2001 15:13'!
exportName: aString

	| assoc |
	assoc _ definedNames associationAt: aString asSymbol.
	exportedNames add: assoc
	! !

!Module methodsFor: 'changing defined names' stamp: 'hg 8/21/2001 14:35'!
removeName: aString

	definedNames removeKey: aString asSymbol.
	exportedNames removeKey: aString asSymbol ifAbsent: [].
! !

!Module methodsFor: 'module composition' stamp: 'hg 8/21/2001 18:14'!
addSubmoduleNamed: aString importNames: importNames

	|  submodule |
	submodule _ self species new name: aString parentModule: self.
	submodules add: submodule.
	importNames ifTrue: [
		self importModule: submodule].
	self defineName: aString as: submodule export: false.
	^submodule
! !

!Module methodsFor: 'module composition' stamp: 'hg 8/21/2001 18:27'!
deepSubmodulesDo: aBlock
	"evaluate aBlock for each module in my entire hierarchy of submodules"

	aBlock value: self.
	self submodules do: [:mod | mod deepSubmodulesDo: aBlock]! !

!Module methodsFor: 'module composition' stamp: 'hg 8/21/2001 18:15'!
importModule: module

	(importedModules includes: module) 
		ifFalse: [importedModules add: module]! !

!Module methodsFor: 'module composition' stamp: 'squeak 8/20/2001 17:01'!
species

	^Module! !

!Module methodsFor: 'change sets' stamp: 'hg 8/22/2001 20:48'!
changes
	"there is no longer a global active change set.
	All changes should be placed in the active change set of the module where the change belongs."

	^activeChangeSet ifNil: [self createChanges. activeChangeSet]! !

!Module methodsFor: 'change sets' stamp: 'hg 8/21/2001 21:38'!
changes: cs

	activeChangeSet _ cs! !

!Module methodsFor: 'change sets' stamp: 'hg 8/21/2001 21:28'!
createChanges
	"there is no longer a global active change set.
	All changes should be placed in the active change set of the module where the change belongs."

	self newChanges: (ChangeSet basicNewNamed: self fullPathAsMessages).! !

!Module methodsFor: 'change sets' stamp: 'hg 8/21/2001 21:37'!
newChanges: aChangeSet 
	"Set the module ChangeSet to be the argument, aChangeSet. " 

	self changes: aChangeSet	

"SystemDicitonary>>newChanges was:
Tell the current project that aChangeSet is now its change set.  When called from Project enter:, the setChangeSet: call is redundant but harmless; when called from code that changes the current-change-set from within a project, it's vital"

	"SystemChanges isolationSet: nil.
	SystemChanges _ aChangeSet.
	Smalltalk currentProjectDo:
		[:proj |
		proj setChangeSet: aChangeSet.
		aChangeSet isolationSet: proj isolationSet]"! !

!Module methodsFor: 'printing' stamp: 'hg 8/21/2001 18:44'!
printOn: aStream
	"a simple pretty-printer"

	aStream nextPutAll: 'Module ', '#('.
	aStream nextPutAll: self fullPathAsMessages.
	aStream nextPutAll: ')'! !

!Module methodsFor: 'fileIn/Out' stamp: 'hg 8/21/2001 15:45'!
addRootsTo: roots
	"Add roots for me and my submodules for writing out on the disk as an ImageSegment. "

	definedNames valuesDo: [:value | 
		value == self ifFalse: [roots addLast: value].
		value class class == Metaclass ifTrue: [roots addLast: value class]].
	submodules do: [:mod | 
		roots addLast: mod.
		mod writeToSegment: roots].

! !

!Module methodsFor: 'fileIn/Out' stamp: 'hg 8/21/2001 22:09'!
isInMemory
	definedNames associationsDo:
		[:a | ^ a value isInMemory].
	^ true! !

!Module methodsFor: 'fileIn/Out' stamp: 'hg 8/21/2001 15:34'!
stillOut		"Smalltalk stillOut"
	"Write transcript the names of the Modules in the list who are still out on disk."

	Transcript clear.
	submodules do: [:mod |
		Transcript cr; 
			nextPutAll: mod fullPath printString , 
				(mod isInMemory
					ifTrue: [':  in']
					ifFalse: [':  out'])].
	Transcript endEntry! !

!Module methodsFor: 'fileIn/Out' stamp: 'hg 8/21/2001 15:46'!
storeSegment
	"Store me and my submodules out on the disk as an ImageSegment.  Keep the outPointers in memory.  Name it <my path>.seg."

	| is roots |
	is _ ImageSegment new.
	is segmentName: self fullPathAsMessages.
	roots _ OrderedCollection new: definedNames size * 2.
	"roots addFirst: self."

	"this is recursive over my sybmodules"
	self addRootsTo: roots.
	
	is copyFromRootsLocalFileFor: roots sizeHint: 0.

	"NOTE: self is now an ISRootStub..."
	is state = #tooBig ifTrue: [^ false].
	is extract.
	is state = #active ifFalse: [^ false].
	is writeToFile: is segmentName.
	^ true
! !

!Module methodsFor: 'system conversion' stamp: 'hg 8/21/2001 16:17'!
categoryNameToModule: catName
	"Module root moduleForCategory:'Morphic'"
	"Accepts a category name which may be a symbol or a string,
	and which may have trailing parts of the form '-zort'.
	Returns the module object of that name."

	| table |
	table _ #(
		(Kernel	(Squeak Kernel))
		(Collections))! !

!Module methodsFor: 'system conversion' stamp: 'hg 8/21/2001 18:25'!
deepIndirectRefs  
	"SystemDictionary new 
		browseMessageList: self deepIndirectRefs asSortedCollection
		name: 'Indirect Global References from', self name
		autoSelect: nil"

	| list n mods |

	mods _ OrderedCollection new.
	list _ OrderedCollection new.
	self deepSubmodulesDo: [:mod | mods add: mod].
	'Locating methods with indirect global references...'
		displayProgressAt: Sensor cursorPoint
		from: 0 to: mods size
		during:
		[:bar | n _ 0.
		mods do: [:mod | 
			bar value: (n_ n+1).
			list addAll: mod localIndirectRefs]].

	^list! !

!Module methodsFor: 'system conversion' stamp: 'hg 8/21/2001 22:11'!
generateSubmodules: moduleList
	"a utility method, see Module>>topLevelModuleList"

	| modName submods |
	moduleList do: [:item |
		item class == Array
			ifFalse: [modName _ item. submods _ #()]
			ifTrue: [modName _ item first. submods _ item second].

		self addSubmoduleNamed: modName importNames: false.
		(self definitionFor: modName ifAbsent: [self error: 'module not found']) 
			generateSubmodules: submods].! !

!Module methodsFor: 'system conversion' stamp: 'hg 8/21/2001 19:01'!
localIndirectRefs  
	"all external references from code in this Module"
	"Smalltalk localIndirectRefs"

	| cm lits list foundOne allClasses |

	self flag: #mref.		"no senders at the moment. also no Environments at the moment"

	list _ OrderedCollection new.
	allClasses _ OrderedCollection new.
	self allClassesDo: [:cls | allClasses addLast: cls; addLast: cls class].

	allClasses do: [:cl | 
		cl selectors do: [:sel | 
			cm _ cl compiledMethodAt: sel.
			lits _ cm literals.
			foundOne _ false.
			lits do:
				[:lit | lit isVariableBinding ifTrue:
					[(lit value == cl or: [cl scopeHas: lit key ifTrue: [:ignored]])
						ifFalse: [foundOne _ true]]].
			foundOne ifTrue: [
				list add: (
					MethodReference new
						setStandardClass: cl 
						methodSymbol: sel)]
			]].
	^list! !

!Module methodsFor: 'system conversion' stamp: 'hg 8/21/2001 19:59'!
moduleForCategory: catString
	"Module root moduleForCategory:'Morphic'"
	"Accepts a category name which may be a symbol or a string,
	and which may have trailing parts of the form '-zort'.
	Returns the module object of that name."

	| major module minor modulePath |
	Module reorgCategories detect: [:pair | pair first = catString] ifNone: [^Smalltalk"Module root"].
	major _ (catString copyUpTo: $-) asSymbol.
	minor _ (catString copyAfter: $-) asSymbol.
	modulePath _ Array with: #Squeak with: major with: minor.
	module _ Module fromPath: modulePath.
	module ifNil: [self error: 'No module for category ', modulePath printString].
	^ module! !

!Module methodsFor: 'system conversion' stamp: 'hg 8/21/2001 15:29'!
rewriteIndirectRefs   
	"Smalltalk rewriteIndirectRefs"
	"For all classes, identify all methods with references to globals outside their direct access path.
	For each of these, call another method to rewrite the source with proper references."

	| n refsList |

	"Allow compiler to compile refs to globals out of the direct reference path"
	Preferences enable: #lenientScopeForGlobals.

	refsList _ self deepIndirectRefs.

	'Updating indirect global references in source code...'
		displayProgressAt: Sensor cursorPoint
		from: 0 to: refsList size
		during:
		[:bar | n _ 0.
		refsList do:
			[:ref | bar value: (n_ n+1).
			self rewriteSourceForSelector: ref methodSymbol inClass: ref actualClass]].

	Preferences disable: #lenientScopeForGlobals.

! !

!Module methodsFor: 'system conversion' stamp: 'hg 8/21/2001 19:25'!
rewriteSourceForSelector: selector inClass: aClass
	"Rewrite the source code for the method in question so that all out-of-scope references are converted to explicit references to the defining module (which is added as an import of this module). This is done by parsing the source with a lenient parser able to find variables in any module.  Then the parse tree is consulted for the source code ranges of each reference that needs to be rewritten and the pattern to which it should be rewritten.  Note that assignments, which will take the form
	envt setValueOf: #GlobalName to: ...
may generate spurious message due to agglutination of keywords with the value expression."

	| code methodNode edits varName definingModule |

	code _ aClass sourceCodeAt: selector.
	methodNode _ Compiler new parse: code in: aClass notifying: nil.
	edits _ OrderedCollection new.
	methodNode encoder globalSourceRanges do:
		[:tuple |   "{ varName. srcRange. store }"
		(aClass scopeHas: (varName _ tuple first asSymbol) ifTrue: [:ignored]) ifFalse:
			["This is a remote global.  Add it as reference to be edited."
			edits addLast: { varName. tuple at: 2. tuple at: 3 }]].

	"Sort the edits by source position."
	edits _ edits asSortedCollection: [:a :b | a second first < b second first].
	edits reverseDo: [:edit | 
		varName _ edit first.
		"if name isn't defined in this module"
		(aClass scopeHas: varName ifTrue: [:ignore]) ifFalse: [
			"look in all modules in the system"
			definingModule _ Module root moduleDefining: varName.
			definingModule ifNotNil: [
				"ensure that defining module exports it"
				definingModule exportName: varName.

				self importModule: definingModule.

				"Replace access out of scope with a full-path remote reference"
				code _ code copyReplaceFrom: edit second first
							to: edit second last
							with: definingModule fullPathAsMessages, ' ' , varName]]].

	aClass compile: code classified: (aClass organization categoryOfElement: selector)! !

!Module methodsFor: 'system conversion' stamp: 'hg 8/21/2001 18:22'!
transferBindingsNamedIn: nameList from: otherModule
	| assoc class |
	nameList do:
		[:aName |
		assoc _ otherModule associationFor: aName ifAbsent: [self error: 'name not found'].
		self addAssoc: assoc export: true.
		class _ assoc value.
		class module: self.
		"Support SystemDicitonary"
		(otherModule respondsTo: #removeName:)
			ifTrue: [otherModule removeName: aName]
			ifFalse: [otherModule removeKey: aName]]! !

!Module methodsFor: 'module name and path' stamp: 'hg 8/21/2001 18:16'!
fullPath
	"Return my full path in the virtual Module hierarchy.
	 Note that this is an Array of symbols. "

	^parentModule 
		ifNotNil: [parentModule fullPath copyWith: self name]
		ifNil: [#('stray Module named ') copyWith: self name]! !

!Module methodsFor: 'module name and path' stamp: 'hg 8/21/2001 19:26'!
fullPathAsMessages
	"return the full path as the source code for a sequence of messages to refer to me.
	eg. #(Morphic Cat1) --> 'Morphic Cat1'"

	| string path |
	path _ self fullPath.
	string _ path first asString.
	path allButFirst do: [:s | string _ string, ' ', s].
	^string
! !


!Module class methodsFor: 'instance creation' stamp: 'squeak 8/20/2001 17:19'!
new

	^super new initialize! !

!Module class methodsFor: 'class initialization' stamp: 'hg 8/22/2001 21:03'!
initialize
	"prepare system for change of regime"

	Smalltalk allClassesDo: [:cl | cl module: nil]! !

!Module class methodsFor: 'virtual hierarchy' stamp: 'hg 8/21/2001 18:10'!
fromPath: modulePath
	"return the module with the given path"

	^self fromPath: modulePath forceCreate: false! !

!Module class methodsFor: 'virtual hierarchy' stamp: 'hg 8/21/2001 18:14'!
fromPath: modulePath forceCreate: force
	"return the module with the given path"

	^modulePath inject: self root into: [:module :localName |
		module submodules 
			detect: [:sub | sub name = localName] 
			ifNone: [
				force
					ifFalse: [module error: module name, 'has no submodule named ', localName]
					ifTrue: [module addSubmoduleNamed: localName importNames: false]]]! !

!Module class methodsFor: 'virtual hierarchy' stamp: 'hg 8/22/2001 18:44'!
root

	^Root! !

!Module class methodsFor: 'test setup' stamp: 'hg 8/21/2001 16:49'!
createTopLevels

	self root generateSubmodules: Module topLevelModuleList! !

!Module class methodsFor: 'test setup' stamp: 'hg 8/21/2001 19:01'!
reorgCategories

	^#(('Morphic-Components' (Morphic Components))
		('Morphic-Components Built' (Morphic Components Built))
		('Morphic-Scripting' (Morphic Scripting))
		('Morphic-Scripting Tiles' (Morphic Scripting Tiles))
		('Morphic-Palettes' (Morphic Palettes))
		('Morphic-Games' (Morphic Games))
		('Morphic-Experimental' (Morphic Experimental))
		('Morphic-Postscript Canvases' (Morphic Postscript Canvases))
		('Morphic-Postscript Filters' (Morphic Postscript Filters))
		('Morphic-UserObjects' (Morphic UserObjects))
		('Morphic-GeeMail' (Morphic GeeMail))
		('Morphic-PDA' (Morphic PDA))
		('Morphic-Events' (Morphic Events))
		('Morphic-Tile Scriptors' (Morphic TileScriptors))
		('Morphic-Navigators' (Morphic Navigators))
		('Morphic-Outliner' (Morphic Outliner))
		('Morphic-Remote' (Morphic Remote)))
! !

!Module class methodsFor: 'test setup' stamp: 'hg 8/21/2001 18:07'!
reorganizeEverything
	"Module reorganizeEverything."

	| bigCat envt pool s |
	"First check for clashes between environment names and existing globals..."
	SystemOrganization categories do:
		[:cat | bigCat _ (cat asString copyUpTo: '-' first) asSymbol.
		(Smalltalk kernelCategories includes: bigCat) ifFalse:
			[(Smalltalk includesKey: bigCat) ifTrue:
				[^ self error: bigCat , ' cannot be used to name
both a package and a class or other global variable.
No reorganization will be attempted.']]].

	(PopUpMenu confirm:
'Your image is about to be partitioned into environments.
Many things may not work after this, so you should be
working in a throw-away copy of your working image.
Are you really ready to procede?
(choose ''no'' to stop here safely)')
		ifFalse: [^ PopUpMenu notify: 'No changes were made'].

	Smalltalk newChanges: (ChangeSet basicNewNamed: 'Reorganization').

	"Recreate the Smalltalk dictionary as the top-level Environment."
	"Smalltalk _ SmalltalkEnvironment newFrom: Smalltalk."
	Smalltalk setName: #Smalltalk inOuterEnvt: nil.

	"Don't hang onto old copy of Smalltalk ."
	Smalltalk recreateSpecialObjectsArray.

	Smalltalk allClassesDo:
		[:c | c environment: nil. "Flush any old values"].

	"Run through all categories making up new sub-environments"
	SystemOrganization categories do:
		[:cat | bigCat _ (cat asString copyUpTo: '-' first) asSymbol.
		(Smalltalk kernelCategories includes: bigCat) ifFalse:
			["Not a kernel category ..."
			envt _ Smalltalk at: bigCat
						ifAbsent: ["... make up a new environment if necessary ..."
									Smalltalk makeSubEnvironmentNamed: bigCat].
			"... and install the member classes in that category"
			envt transferBindingsNamedIn: (SystemOrganization listAtCategoryNamed: cat)
									from: Smalltalk].
		].

	"Move all shared pools that are only referred to in sub environments"
	Smalltalk associationsDo:
		[:assn | ((pool _ assn value) isMemberOf: Dictionary) ifTrue:
			[s _ IdentitySet new.
			Smalltalk allClassesAnywhereDo:
				[:c | c sharedPools do:
					[:p | p == pool ifTrue:
						[s add: c environment]]].
			(s size = 1 and: [(envt _ s someElement) ~~ Smalltalk]) ifTrue:
				[envt declare: assn key from: Smalltalk]]].

	Smalltalk rewriteIndirectRefs.
	Smalltalk newChanges: (ChangeSet basicNewNamed: 'PostReorganization').
	ChangeSorter initialize.
	Preferences enable: #browserShowsPackagePane.

! !

!Module class methodsFor: 'test setup' stamp: 'hg 8/22/2001 22:08'!
reorganizeSome
	"Module reorganizeSome."

	| categories timeStamp cat path module |

	categories _ self reorgCategories.

	timeStamp _ Time now hours printString,'.', Time now seconds printString.
	Smalltalk newChanges: (ChangeSet basicNewNamed: 'Reorganization', timeStamp).

	"Run through all categories making up new sub-environments"
	categories do:
		[:pair | 
		cat _ pair first. path _ pair second.
		module _ Module fromPath: path forceCreate: true.
		module parentModule importModule: module.
		module transferBindingsNamedIn: (SystemOrganization listAtCategoryNamed: cat)
				from: Root].


	(Module fromPath: #(Morphic)) rewriteIndirectRefs.
	Smalltalk newChanges: (ChangeSet basicNewNamed: 'PostReorganization ', timeStamp).
	ChangeSorter initialize.
	Preferences enable: #browserShowsPackagePane.

! !

!Module class methodsFor: 'test setup' stamp: 'hg 8/20/2001 19:45'!
topLevelModuleList
	"return a list of names for the top level modules of the virtual repository.
	Items are either symbols or pairs of a symbol and a list of subitems"

	"This is just a first food-for-thought example. hg 8/20/2001 19:44"

	^#(
		(Smalltalk80		"For the contents of standard Smalltalk-80"
			(Collections Magnitudes "etc."))
		(Squeak			"For e.g. Squeak major and minor releases"
			 (MVC Morphic releases config "for example"))
		(contrib
			())
		(org ()) (com ()) "For organizations to reserve names in"
	)! !


!ReadOnlyVariableBinding methodsFor: 'accessing' stamp: 'hg 8/21/2001 19:21'!
value: aValue
	"disable during Environments work"

	"(AttemptToWriteReadOnlyGlobal signal: 'Cannot store into read-only bindings') ==" true ifTrue:[
		value _ aValue.
	].! !


!Repository methodsFor: 'accessing' stamp: 'squeak 8/20/2001 19:05'!
module

	^module! !

!Repository methodsFor: 'initializing' stamp: 'squeak 8/20/2001 16:40'!
initialize

	^self! !

!Repository methodsFor: 'initializing' stamp: 'squeak 8/20/2001 18:55'!
module: aModule

	module _ aModule! !

!Repository methodsFor: 'initializing' stamp: 'squeak 8/20/2001 18:52'!
subrepositorySpecies
	"return the default class to use as the repository for a submodule to my module."

	^self class! !

!Repository methodsFor: 'URLs' stamp: 'squeak 8/20/2001 19:09'!
parentRepository

	^self module parentModule 
		ifNotNil: [self module parentModule repository]! !

!Repository methodsFor: 'URLs' stamp: 'squeak 8/20/2001 19:04'!
relativeUrl
	"return the url of this repository relative to its parent"

	^self module name! !

!Repository methodsFor: 'URLs' stamp: 'squeak 8/20/2001 19:08'!
url
	"return the url of the location for this repository"

	| parentUrl myUrl |
	parentUrl _ self parentRepository urlObject.
	myUrl _ parentUrl path: (parentUrl path copyWith: self relativeUrl).
	^myUrl toText! !

!Repository methodsFor: 'URLs' stamp: 'squeak 8/20/2001 18:46'!
urlObject
	"return an URL object for the url of the location for this repository"

	^Url absoluteFromText: self url! !


!HTTPRepository methodsFor: 'URLs' stamp: 'hg 8/22/2001 21:54'!
isRelative
	"hack: relative if nil, otherwise url hold string"

	^url isNil! !

!HTTPRepository methodsFor: 'URLs' stamp: 'hg 8/22/2001 21:53'!
url
	"return the url of the location for this repository"

	| parentUrl myUrl |
	^self isRelative 
		ifTrue: [
			parentUrl _ self parentRepository urlObject.
			myUrl _ parentUrl path: (parentUrl path copyWith: self relativeUrl).
			myUrl toText]
		ifFalse: [
			url]! !

!HTTPRepository methodsFor: 'URLs' stamp: 'hg 8/22/2001 21:57'!
url: fullURLstring
	"set url to make this the root of an actual repository at this URL"

	url _ fullURLstring! !


!RemoteRepository methodsFor: 'URLs' stamp: 'squeak 8/20/2001 18:25'!
localUrl
	"return the url for the local cache for this repository"

	^self subclassResponsibility ! !


!Repository class methodsFor: 'instance creation' stamp: 'squeak 8/20/2001 16:38'!
new

	^super new initialize! !

!Repository class methodsFor: 'instance creation' stamp: 'squeak 8/20/2001 18:55'!
on: aModule
	"return an instance of me for the given module"

	^self new module: aModule! !

!Repository class methodsFor: 'repository hierarchy' stamp: 'squeak 8/20/2001 16:44'!
root

	^Root! !


!VirtualRootModule methodsFor: 'module name and path' stamp: 'hg 8/21/2001 16:26'!
fullPath
	"I am the root of the virtual Module hierarchy.
	 Note that a fullPath is an Array of symbols. "

	^#()! !

!VirtualRootModule methodsFor: 'module name and path' stamp: 'hg 8/22/2001 20:31'!
fullPathAsMessages
	"return the full path as the source code for a sequence of messages to refer to me.
	Names defined in the Root require no prefixing (at least for now)"

	^''! !

!VirtualRootModule methodsFor: 'module name and path' stamp: 'squeak 8/20/2001 17:45'!
name

	^'/ (the virtual root Module)'! !

!VirtualRootModule methodsFor: 'initializing' stamp: 'hg 8/21/2001 22:44'!
convertSmalltalk
	"Change the class of the Smalltalk dictionary to RootDictionary, 
	which handles backward compatibility for Modules.
	Also set my definedNames dictionary to point to the new Smalltalk"

	definedNames _ exportedNames _ RootDictionary newFrom: Smalltalk.
	Smalltalk at: #Smalltalk put: definedNames.	"subvert Andreas' compiler hack"
	Smalltalk at: #Root put: self! !

!VirtualRootModule methodsFor: 'initializing' stamp: 'hg 8/21/2001 20:08'!
initialize

	super initialize.
	self convertSmalltalk.
	repository _ VirtualRootRepository new.! !

!VirtualRootModule methodsFor: 'accessing defined names' stamp: 'hg 8/21/2001 21:57'!
allModules

	| all |
	all _ OrderedCollection with: self.
	self deepSubmodulesDo: [:mod | all add: mod].
	^all! !

!VirtualRootModule methodsFor: 'accessing defined names' stamp: 'hg 8/21/2001 22:08'!
classNames
	"Answer a SortedCollection of all class names."
	| names mods |
	mods _ self allModules.
	names _ OrderedCollection new: mods size * 5.
	mods do: [:mod |
		mod definedNames do: 
		[:cl | (cl isInMemory and: [(cl isKindOf: Class) and: [(cl name beginsWith: 'AnObsolete') not]])
			ifTrue: [names add: cl name]]].
	^names asSortedCollection! !

!VirtualRootModule methodsFor: 'accessing defined names' stamp: 'hg 8/21/2001 21:11'!
definitionAnywhereFor: aString ifAbsent: aBlock
	"look up definition for the given symbo in all modules in the system"

	| noHit def |
	^self localDefinitionFor: aString ifAbsent: [
		noHit _ #'!!!!notFound'.
		self deepSubmodulesDo: [:module |
				"should really use ifPresent: instead of nil test to be picky"
			def _ module definitionFor: aString ifAbsent: [noHit].
			def == noHit ifFalse: [^def]].
		^aBlock value].	"not found"
	! !

!VirtualRootModule methodsFor: 'accessing defined names' stamp: 'hg 8/21/2001 18:37'!
definitionFor: aString ifAbsent: aBlock
	"look up definition for the given symbol, and proceed into imported modules"

	| noHit def |
	^self localDefinitionFor: aString ifAbsent: [
		noHit _ #'!!!!notFound'.
		self deepSubmodulesDo: [:module |
				"should really use ifPresent: instead of nil test to be picky"
			def _ module exportedDefinitionFor: aString ifAbsent: [noHit].
			def == noHit ifFalse: [^def]].
		^aBlock value].	"not found"
	! !

!VirtualRootModule methodsFor: 'accessing defined names' stamp: 'hg 8/21/2001 16:00'!
lenientScopeHas: varName ifTrue: assocBlock
	"Compatibility hack -- find things in all modules for now"
	| mod |
	mod _ self moduleDefining: varName.
	mod ifNotNil: [
		assocBlock value: (mod localAssocFor: varName ifAbsent: [nil]).
		^true].
	^ false! !

!VirtualRootModule methodsFor: 'accessing defined names' stamp: 'hg 8/21/2001 21:07'!
moduleDefining: varName
	"search all modules in the system regardless of composition or accessibility"
	
	| assoc |
	definedNames at: varName ifAbsent: [
		self deepSubmodulesDo: [:mod | 
			assoc _ mod localAssocFor: varName ifAbsent: [nil].
			assoc ifNotNil: [^mod]].
		^nil].
	^self! !

!VirtualRootModule methodsFor: 'printing' stamp: 'squeak 8/20/2001 18:00'!
printOn: aStream

	aStream nextPutAll: self name! !


!VirtualRootModule class methodsFor: 'instance creation' stamp: 'hg 8/22/2001 18:43'!
createRoot
	"create the single instance"

	Root _ super new.
	^Root! !

!VirtualRootModule class methodsFor: 'instance creation' stamp: 'hg 8/22/2001 18:42'!
new

	^self error: 'There should only be one Root module'! !

!VirtualRootModule class methodsFor: 'class initialization' stamp: 'hg 8/22/2001 20:44'!
initialize

	"self initialize"
	self createRoot.! !


!VirtualRootRepository methodsFor: 'initializing' stamp: 'squeak 8/20/2001 18:57'!
subrepositorySpecies
	"return the default class to use as the repository for a submodule to my module."

	^self class superclass! !

!VirtualRootRepository methodsFor: 'URLs' stamp: 'squeak 8/20/2001 18:37'!
url

	^'http://', self server, self path! !

!VirtualRootRepository methodsFor: 'SqueakFoundation registry server' stamp: 'squeak 8/20/2001 18:38'!
path

	^'/'! !

!VirtualRootRepository methodsFor: 'SqueakFoundation registry server' stamp: 'squeak 8/20/2001 18:37'!
server

	^'repository.squeakfoundation.org'! !

VirtualRootRepository removeSelector: #urlString!
VirtualRootRepository removeSelector: #virtualRootServer!
VirtualRootModule initialize!
VirtualRootModule removeSelector: #createTopLevels!
VirtualRootModule removeSelector: #fullName!
VirtualRootModule removeSelector: #moduleFromPath:!

!VirtualRootModule reorganize!
('accessing')
('module name and path' fullPath fullPathAsMessages name)
('initializing' convertSmalltalk initialize)
('accessing defined names' allModules classNames definitionAnywhereFor:ifAbsent: definitionFor:ifAbsent: lenientScopeHas:ifTrue: moduleDefining:)
('printing' printOn:)
!

Repository class removeSelector: #initialize!
Module initialize!
Module class removeSelector: #topLevelModules!

!Module class reorganize!
('instance creation' new)
('class initialization' initialize)
('virtual hierarchy' fromPath: fromPath:forceCreate: root)
('test setup' createTopLevels reorgCategories reorganizeEverything reorganizeSome topLevelModuleList)
!

Module removeSelector: #activeChangeSet!
Module removeSelector: #browseIndirectRefs!
Module removeSelector: #canonicalName!
Module removeSelector: #definitionAt:ifAbsent:!
Module removeSelector: #fullName!
Module removeSelector: #importedDicitonaries!
Module removeSelector: #localDefinitionAt:ifAbsent:!
Module removeSelector: #name:inModule:!
Module removeSelector: #rewriteSourceForSelector:inClass:using:!
Module removeSelector: #writeToSegment:!

!Module reorganize!
('accessing' definedNames exportedDictionary importedDictionaries name parentModule repository repository: submodules)
('initializing' initialize name:parentModule:)
('compatibility' doesNotUnderstand: organization removeClassFromSystem:logged:)
('accessing defined names' allClassesDo: associationFor:ifAbsent: definitionFor:ifAbsent: definitionFor:ifPresent: exportedAssocFor:ifAbsent: exportedDefinitionFor:ifAbsent: keyAtIdentityValue:ifAbsent: localAssocFor:ifAbsent: localDefinitionFor:ifAbsent:)
('changing defined names' addAssoc:export: defineName:as:export: exportName: removeName:)
('module composition' addSubmoduleNamed:importNames: deepSubmodulesDo: importModule: species)
('change sets' changes changes: createChanges newChanges:)
('printing' printOn:)
('fileIn/Out' addRootsTo: isInMemory stillOut storeSegment)
('system conversion' categoryNameToModule: deepIndirectRefs generateSubmodules: localIndirectRefs moduleForCategory: rewriteIndirectRefs rewriteSourceForSelector:inClass: transferBindingsNamedIn:from:)
('module name and path' fullPath fullPathAsMessages)
!

"Postscript:
"

Root explore!

-------------- next part --------------
'From Squeak3.1alpha of 7 March 2001 [latest update: #4261] on 22 August 2001 at 10:46:37 pm'!
"Change Set:		Dog Days Modules prototype
Date:			22 August 2001
Author:			Henrik Gedenryd

See text in first change set"!

 SystemDictionary subclass: #Environment
	instanceVariableNames: 'envtName outerEnvt '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Modules'!

!Association methodsFor: 'objects from disk' stamp: 'hg 8/21/2001 13:56'!
objectForDataStream: refStrm
	| dp |
	"I am about to be written on an object file.  If I am a known global, write a proxy that will hook up with the same resource in the destination system."

	^ (Smalltalk associationAt: key ifAbsent: [nil]) == self 
		ifTrue: [dp _ DiskProxy global: #Smalltalk selector: #associationOrUndeclaredFor: 
							args: (Array with: key).
			refStrm replace: self with: dp.
			dp]
		ifFalse: [self]! !


!Behavior methodsFor: 'accessing' stamp: 'hg 8/21/2001 21:32'!
module
	"Return the module in which the receiver is visible"
	^Root! !

!Behavior methodsFor: 'testing method dictionary' stamp: 'hg 8/14/2001 17:51'!
scopeHas: name ifTrue: assocBlock 
	"If the argument name is a variable known to the receiver, then evaluate 
	the second argument, assocBlock."

	^superclass notNil and: [superclass scopeHas: name ifTrue: assocBlock]! !


!ClassBuilder methodsFor: 'class definition' stamp: 'hg 8/21/2001 13:57'!
class: oldClass instanceVariableNames: instVarString unsafe: unsafe
	"This is the basic initialization message to change the definition of
	an existing Metaclass"
	| instVars newClass |
	environ _ oldClass module.
	instVars _ Scanner new scanFieldNames: instVarString.
	unsafe ifFalse:[
		"Run validation checks so we know that we have a good chance for recompilation"
		(self validateInstvars: instVars from: oldClass forSuper: oldClass superclass) ifFalse:[^nil].
		(self validateSubclassFormat: oldClass typeOfClass from: oldClass forSuper: oldClass superclass extra: instVars size) ifFalse:[^nil]].
	"Create a template for the new class (will return oldClass when there is no change)"
	newClass _ self 
		newSubclassOf: oldClass superclass 
		type: oldClass typeOfClass
		instanceVariables: instVars
		from: oldClass
		unsafe: unsafe.

	newClass == nil ifTrue:[^nil]. "Some error"
	newClass _ self recompile: false from: oldClass to: newClass mutate: false.
	self doneCompiling: newClass.
	^newClass! !

!ClassBuilder methodsFor: 'class definition' stamp: 'hg 8/22/2001 18:55'!
name: className inEnvironment: mod subclassOf: newSuper type: type instanceVariableNames: instVarString classVariableNames: classVarString poolDictionaries: poolString category: category unsafe: unsafe
	"Define a new class in the given environment.
	If unsafe is true do not run any validation checks.
	This facility is provided to implement important system changes."
	| oldClass newClass organization instVars classVars force |
	environ _ mod.
	instVars _ Scanner new scanFieldNames: instVarString.
	classVars _ (Scanner new scanFieldNames: classVarString) collect: [:x | x asSymbol].

	"Validate the proposed name"
	unsafe ifFalse:[(self validateClassName: className inModule: environ) ifFalse:[^nil]].
	oldClass _ environ definitionFor: className ifAbsent:[nil].
	oldClass isBehavior 
		ifFalse:[oldClass _ nil]. "Already checked in #validateClassName:"

	unsafe ifFalse:[
		"Run validation checks so we know that we have a good chance for recompilation"
		(self validateSuperclass: newSuper forSubclass: oldClass) ifFalse:[^nil].
		(self validateInstvars: instVars from: oldClass forSuper: newSuper) ifFalse:[^nil].
		(self validateClassvars: classVars from: oldClass forSuper: newSuper) ifFalse:[^nil].
		(self validateSubclassFormat: type from: oldClass forSuper: newSuper extra: instVars size) ifFalse:[^nil]].

	"Create a template for the new class (will return oldClass when there is no change)"
	newClass _ self 
		newSubclassOf: newSuper 
		type: type 
		instanceVariables: instVars
		from: oldClass
		unsafe: unsafe.

	newClass == nil ifTrue:[^nil]. "Some error"

	newClass == oldClass ifFalse:[newClass setName: className].

	"Install the class variables and pool dictionaries... "
	force _ (newClass declare: classVarString) | (newClass sharing: poolString).

	"... classify ..."
	organization _ environ ifNotNil:[environ organization].
	organization classify: newClass name under: category asSymbol.
	newClass module: environ.

	"... recompile ..."
	newClass _ self recompile: force from: oldClass to: newClass mutate: false.

	"... export if not yet done ..."
	(environ definitionFor: newClass name ifAbsent:[nil]) == newClass ifFalse:[
		[environ defineName: newClass name as: newClass export: true ]
			on: AttemptToWriteReadOnlyGlobal do:[:ex| ex resume: true].
		Smalltalk flushClassNameCache.
	].

	self doneCompiling: newClass.
	^newClass
! !

!ClassBuilder methodsFor: 'class definition' stamp: 'hg 8/22/2001 18:57'!
recompile: force from: oldClass to: aClass mutate: forceMutation
	"Do the necessary recompilation after changine oldClass to newClass.
	If required (e.g., when oldClass ~~ newClass) mutate oldClass to newClass
	and all its subclasses. If forceMutation is true force a mutation even
	if oldClass and newClass are the same."
	| newClass |
	newClass _ aClass.

	oldClass == nil ifTrue:[
		"newClass has an empty method dictionary
		so we don't need to recompile"
		newClass module changes addClass: newClass.
		newClass superclass addSubclass: newClass.
		^newClass].

	(newClass == oldClass and:[force not and:[forceMutation not]]) ifTrue:[
		"No recompilation necessary but we might have added
		class vars or class pools so record the change"
		oldClass module changes changeClass: newClass from: oldClass.
		^newClass].

	currentClassIndex _ 0.
	maxClassIndex _ oldClass withAllSubclasses size.

	(oldClass == newClass and:[forceMutation not]) ifTrue:[
		oldClass module changes changeClass: newClass from: oldClass.
		"Recompile from newClass without mutating"
		self informUserDuring:[
			newClass isSystemDefined ifFalse:[progress _ nil].
			newClass withAllSubclassesDo:[:cl|
				self showProgressFor: cl.
				cl compileAll]].
		^newClass].
	"Recompile and mutate oldClass to newClass"
	self informUserDuring:[
		newClass isSystemDefined ifFalse:[progress _ nil].
		self showProgressFor: oldClass.
		newClass _ self reshapeClass: oldClass to: newClass super: newClass superclass.
		oldClass module changes changeClass: newClass from: oldClass.
		self mutate: oldClass to: newClass.
		"And do the magic become"
		self update: oldClass to: newClass.
	].
	^newClass! !

!ClassBuilder methodsFor: 'class definition' stamp: 'hg 8/22/2001 21:48'!
reshapeClass: aClass to: templateClass super: newSuper
	"Reshape the given class to the new super class.
	If templateClass is not nil then it defines the shape of the new class"
	| fmt newClass newMeta newSuperMeta oldMeta instVars oldClass |
	templateClass == nil
		ifTrue:[oldClass _ aClass]
		ifFalse:[oldClass _ templateClass].
	aClass becomeUncompact.
	"Compute the new format of the class"
	instVars _ instVarMap at: aClass name ifAbsent:[oldClass instVarNames].
	fmt _ self computeFormat: oldClass typeOfClass
				instSize: instVars size
				forSuper: newSuper
				ccIndex: 0."Known to be 0 since we uncompacted aClass first"
	fmt == nil ifTrue:[^nil].
	aClass isMeta ifFalse:["Create a new meta class"
		oldMeta _ aClass class.
		newMeta _ oldMeta clone.
		newSuperMeta _ newSuper ifNil:[Class] ifNotNil:[newSuper class].
		newMeta 
			superclass: newSuperMeta
			methodDictionary: MethodDictionary new
			format: (self computeFormat: oldMeta typeOfClass 
							instSize: oldMeta instVarNames size 
							forSuper: newSuperMeta
							ccIndex: 0);
			setInstVarNames: oldMeta instVarNames;
			organization: oldMeta organization.
		"Recompile the meta class"
		oldMeta hasMethods 
			ifTrue:[newMeta compileAllFrom: oldMeta].
		"Fix up meta class structure"
		oldMeta superclass addObsoleteSubclass: oldMeta.
		(oldMeta superclass subclasses includes: oldMeta) ifTrue:[
			oldMeta superclass removeSubclass: oldMeta.
			newMeta superclass addSubclass: newMeta].
		"And record the change so we can fix global refs later"
		self recordClass: oldMeta replacedBy: newMeta.
	].
	newClass _ newMeta == nil
		ifTrue:[oldClass clone]
		ifFalse:[newMeta adoptInstance: oldClass from: oldMeta].
	newClass
		superclass: newSuper
		methodDictionary: MethodDictionary new
		format: fmt;
		setInstVarNames: instVars;
		organization: aClass organization.

	"Recompile the new class"
	aClass hasMethods 
		ifTrue:[newClass compileAllFrom: aClass].

	"Export the new class into the environment"
	aClass isMeta ifFalse:[
		"Derefence super sends in the old class"
		self fixSuperSendsFrom: aClass.
		"Export the class"
		[environ defineName: newClass name as: newClass export: true ]
			on: AttemptToWriteReadOnlyGlobal do:[:ex| ex resume: true].
		"And use the ST association in the new class"
		self fixSuperSendsTo: newClass].

	"Fix up the class hierarchy"
	(aClass superclass subclasses includes: aClass) ifTrue:[
		aClass superclass removeSubclass: aClass.
		newClass superclass addSubclass: newClass.
	].
	"And record the change"
	self recordClass: aClass replacedBy: newClass.

	^newClass! !

!ClassBuilder methodsFor: 'validation' stamp: 'hg 8/21/2001 23:03'!
validateClassName: aString inModule: module
	"Validate the new class name"
	
	| defModule |
	aString first isUppercase ifFalse:[
		self error: 'Class names must be capitalized'.
		^false].

	"name already defined in same module for a non-class value"
	module definitionFor: aString ifPresent:[:old|
		(old isKindOf: Behavior) ifFalse:[
			self notify: aString asText allBold, 
						' already exists!!\Proceed will store over it.' withCRs].
			^true].

	"name already used by a class in a different module"
	(defModule _ Root moduleDefining: aString) ifNotNil: [
		self notify: aString asText allBold, 
			' is already defined in ', defModule fullPathAsMessages,
			'.!!\Proceed will create a duplicate definition in ',
			module fullPathAsMessages, '.' withCRs].
	^true! !

!ClassBuilder methodsFor: 'private' stamp: 'hg 8/22/2001 18:58'!
recordClass: oldClass replacedBy: newClass
	"Keep the changes up to date when we're moving instVars around"
	(instVarMap includesKey: oldClass name) ifTrue:[
		newClass module changes changeClass: newClass from: oldClass.
	].! !

!ClassBuilder methodsFor: 'public' stamp: 'hg 8/21/2001 22:27'!
superclass: newSuper
	subclass: t instanceVariableNames: f 
	classVariableNames: d poolDictionaries: s module: mod category: cat 
	"This is the standard initialization message for creating a new class as a 
	subclass of an existing class."
	^self 
		name: t
		inEnvironment: mod
		subclassOf: newSuper
		type: newSuper typeOfClass
		instanceVariableNames: f
		classVariableNames: d
		poolDictionaries: s
		category: cat! !

!ClassBuilder methodsFor: 'public' stamp: 'hg 8/21/2001 13:57'!
superclass: aClass
	variableByteSubclass: t instanceVariableNames: f 
	classVariableNames: d poolDictionaries: s category: cat
	"This is the standard initialization message for creating a new class as a 
	subclass of an existing class in which the subclass is to 
	have indexable byte-sized nonpointer variables."
	(aClass instSize > 0)
		ifTrue: [^self error: 'cannot make a byte subclass of a class with named fields'].
	(aClass isVariable and: [aClass isWords])
		ifTrue: [^self error: 'cannot make a byte subclass of a class with word fields'].
	(aClass isVariable and: [aClass isPointers])
		ifTrue: [^self error: 'cannot make a byte subclass of a class with pointer fields'].

	^self 
		name: t
		inEnvironment: aClass module
		subclassOf: aClass
		type: #bytes
		instanceVariableNames: f
		classVariableNames: d
		poolDictionaries: s
		category: cat! !

!ClassBuilder methodsFor: 'public' stamp: 'hg 8/21/2001 13:58'!
superclass: aClass
	variableSubclass: t instanceVariableNames: f 
	classVariableNames: d poolDictionaries: s category: cat
	"This is the standard initialization message for creating a new class as a 
	subclass of an existing class in which the subclass is to 
	have indexable pointer variables."
	aClass isBits 
		ifTrue: [^self error: 'cannot make a pointer subclass of a class with non-pointer fields'].
	^self 
		name: t
		inEnvironment: aClass module
		subclassOf: aClass
		type: #variable
		instanceVariableNames: f
		classVariableNames: d
		poolDictionaries: s
		category: cat! !

!ClassBuilder methodsFor: 'public' stamp: 'hg 8/21/2001 13:58'!
superclass: aClass
	variableWordSubclass: t instanceVariableNames: f 
	classVariableNames: d poolDictionaries: s category: cat
	"This is the standard initialization message for creating a new class as a 
	subclass of an existing class in which the subclass is to 
	have indexable word-sized nonpointer variables."
	(aClass instSize > 0)
		ifTrue: [^self error: 'cannot make a word subclass of a class with named fields'].
	(aClass isVariable and: [aClass isBytes])
		ifTrue: [^self error: 'cannot make a word subclass of a class with byte fields'].
	(aClass isVariable and: [aClass isPointers])
		ifTrue: [^self error: 'cannot make a word subclass of a class with pointer fields'].

	^self 
		name: t
		inEnvironment: aClass module
		subclassOf: aClass
		type: #words
		instanceVariableNames: f
		classVariableNames: d
		poolDictionaries: s
		category: cat! !

!ClassBuilder methodsFor: 'public' stamp: 'hg 8/21/2001 13:58'!
superclass: aClass
	weakSubclass: t instanceVariableNames: f 
	classVariableNames: d poolDictionaries: s category: cat
	"This is the standard initialization message for creating a new class as a 
	subclass of an existing class (the receiver) in which the subclass is to 
	have weak indexable pointer variables."
	aClass isBits 
		ifTrue: [^self error: 'cannot make a pointer subclass of a class with non-pointer fields'].
	^self 
		name: t
		inEnvironment: aClass module
		subclassOf: aClass
		type: #weak
		instanceVariableNames: f
		classVariableNames: d
		poolDictionaries: s
		category: cat! !


!ClassDescription methodsFor: 'accessing' stamp: 'hg 8/21/2001 21:31'!
comment: aStringOrText
	"Set the receiver's comment to be the argument, aStringOrText."

	self theNonMetaClass classComment: aStringOrText.
	self module changes commentClass: self! !

!ClassDescription methodsFor: 'accessing' stamp: 'hg 8/21/2001 21:31'!
comment: aStringOrText stamp: aStamp
	"Set the receiver's comment to be the argument, aStringOrText."

	self theNonMetaClass classComment: aStringOrText stamp: aStamp.
	self module changes commentClass: self theNonMetaClass! !

!ClassDescription methodsFor: 'printing' stamp: 'hg 8/21/2001 14:14'!
sharedPoolsString
	"Answer a string of my shared pool names separated by spaces."

	| aStream |
	aStream _ WriteStream on: (String new: 100).
	self sharedPools do: [:x | aStream nextPutAll: (self module keyAtIdentityValue: x ifAbsent: ['private']); space].
	^ aStream contents! !

!ClassDescription methodsFor: 'method dictionary' stamp: 'hg 8/21/2001 21:31'!
removeSelector: selector 
	| priorMethod | 
	"Remove the message whose selector is given from the method 
	dictionary of the receiver, if it is there. Answer nil otherwise."

	(self methodDict includesKey: selector) ifFalse: [^ nil].
	priorMethod _ self compiledMethodAt: selector.
	self module changes removeSelector: selector class: self
		priorMethod: priorMethod
		lastMethodInfo: {priorMethod sourcePointer.
						(self whichCategoryIncludesSelector: selector)}.
	super removeSelector: selector.
	self organization removeElement: selector.
	self acceptsLoggingOfCompilation ifTrue:
		[Smalltalk logChange: self name , ' removeSelector: #' , selector]! !

!ClassDescription methodsFor: 'compiling' stamp: 'hg 8/21/2001 21:30'!
compile: code notifying: requestor trailer: bytes 
		ifFail: failBlock
		elseSetSelectorAndNode: selAndNodeBlock
	"Intercept this message in order to remember system changes.
	 5/15/96 sw: modified so that if the class does not wish its methods logged in the changes file, then they also won't be accumulated in the current change set.
	7/12/96 sw: use wantsChangeSetLogging to determine whether to put in change set"

	| methodNode selector newMethod priorMethodOrNil |
	methodNode _ self compilerClass new
				compile: code
				in: self
				notifying: requestor
				ifFail: failBlock.
	selector _ methodNode selector.
	selAndNodeBlock value: selector value: methodNode.
	requestor ifNotNil:
		["Note this change for recent submissions list"
		Utilities noteMethodSubmission: selector forClass: self].
	methodNode encoder requestor: requestor.  "Why was this not preserved?"
	newMethod _ methodNode generate: bytes.
	priorMethodOrNil _ (self methodDict includesKey: selector)
		ifTrue: [self compiledMethodAt: selector]
		ifFalse: [nil].
	self module changes noteNewMethod: newMethod forClass: self
		selector: selector priorMethod: priorMethodOrNil.
	self addSelector: selector withMethod: newMethod.
	^ newMethod! !

!ClassDescription methodsFor: 'fileIn/Out' stamp: 'hg 8/21/2001 21:32'!
classComment: aString stamp: aStamp
	"Store the comment, aString or Text or RemoteString, associated with the class we are organizing.  Empty string gets stored only if had a non-empty one before."

	| ptr header file oldCommentRemoteStr |
	(aString isKindOf: RemoteString) ifTrue: [^ self organization classComment: aString].
	oldCommentRemoteStr _ self organization commentRemoteStr.
	(aString size = 0) & (oldCommentRemoteStr == nil) ifTrue: [^ organization classComment: nil].
		"never had a class comment, no need to write empty string out"

	ptr _ oldCommentRemoteStr ifNil: [0] ifNotNil: [oldCommentRemoteStr sourcePointer].
	SourceFiles ifNotNil: [(file _ SourceFiles at: 2) ifNotNil: [
		file setToEnd; cr; nextPut: $!!.	"directly"
		"Should be saying (file command: 'H3') for HTML, but ignoring it here"
		header _ String streamContents: [:strm | strm nextPutAll: self name;
			nextPutAll: ' commentStamp: '.
			aStamp storeOn: strm.
			strm nextPutAll: ' prior: '; nextPutAll: ptr printString].
		file nextChunkPut: header]].
	self module changes commentClass: self.
	aStamp size > 0 ifTrue: [self commentStamp: aStamp].
	organization classComment: (RemoteString newString: aString onFileNumber: 2).
! !

!ClassDescription methodsFor: 'fileIn/Out' stamp: 'hg 8/21/2001 22:48'!
definitionST80
	"Answer a String that defines the receiver."

	| aStream |
	aStream _ WriteStream on: (String new: 300).
	superclass == nil
		ifTrue: [aStream nextPutAll: 'nil']
		ifFalse: [aStream nextPutAll: superclass module fullPathAsMessages , ' ', superclass name].
	aStream nextPutAll: self kindOfSubclass;
			store: self name.
	aStream cr; tab; nextPutAll: 'instanceVariableNames: ';
			store: self instanceVariablesString.
	aStream cr; tab; nextPutAll: 'classVariableNames: ';
			store: self classVariablesString.
	aStream cr; tab; nextPutAll: 'poolDictionaries: ';
			store: self sharedPoolsString.
	self module == Root ifFalse: [
		aStream cr; tab; nextPutAll: 'module: ';
			nextPutAll: self module fullPathAsMessages].
	aStream cr; tab; nextPutAll: 'category: ';
			store: (SystemOrganization categoryOfElement: self name) asString.
	^ aStream contents! !

!ClassDescription methodsFor: 'fileIn/Out' stamp: 'hg 8/21/2001 22:50'!
definitionST80: isST80
	"Answer a String that defines the receiver."

	| aStream |
	isST80 ifTrue: [^ self definitionST80].

	aStream _ WriteStream on: (String new: 300).
	superclass == nil
		ifTrue: [aStream nextPutAll: 'nil']
		ifFalse: [aStream nextPutAll: superclass module fullPathAsMessages , ' ', superclass name].
	aStream nextPutKeyword: self kindOfSubclass
			withArg: self name.
	aStream cr; tab; nextPutKeyword: 'instanceVariableNames: '
			withArg: self instanceVariablesString.
	aStream cr; tab; nextPutKeyword: 'classVariableNames: 'withArg: self classVariablesString.
	aStream cr; tab; nextPutKeyword: 'poolDictionaries: '
			withArg: self sharedPoolsString.
	self module == Root ifFalse: [
		aStream cr; tab; nextPutAll: 'module: ';
			nextPutAll: self module fullPathAsMessages].
	aStream cr; tab; nextPutKeyword: 'category: '
			withArg: (SystemOrganization categoryOfElement: self name) asString.
	^ aStream contents! !

!ClassDescription methodsFor: 'fileIn/Out' stamp: 'hg 8/21/2001 21:31'!
reorganize
	"During fileIn, !!Rectangle reorganize!! allows Rectangle to seize control and treat the next chunk as its organization.  See the transfer of control where ReadWriteStream fileIn calls scanFrom:"

	self module changes reorganizeClass: self.
	^self organization!
]style[(10 156 22 82)f1b,f1,f1LReadWriteStream fileIn;,f1! !


!Class methodsFor: 'initialize-release' stamp: 'hg 8/21/2001 13:34'!
removeFromSystem: logged
	"Forget the receiver from the Smalltalk global dictionary. Any existing 
	instances will refer to an obsolete version of the receiver."
	self superclass ifNotNil:[
		"If we have no superclass there's nothing to be remembered"
		self superclass addObsoleteSubclass: self].
	self module removeClassFromSystem: self logged: logged.
	self obsolete! !

!Class methodsFor: 'testing' stamp: 'hg 8/22/2001 21:47'!
isObsolete
	"Return true if the receiver is obsolete."
	^(self module definitionFor: name ifAbsent:[nil]) ~~ self! !

!Class methodsFor: 'instance variables' stamp: 'hg 8/21/2001 13:34'!
addInstVarName: aString
	"Add the argument, aString, as one of the receiver's instance variables."
	^(ClassBuilder new)
		name: self name
		inEnvironment: self module
		subclassOf: superclass
		type: self typeOfClass
		instanceVariableNames: self instanceVariablesString , aString
		classVariableNames: self classVariablesString
		poolDictionaries: self sharedPoolsString
		category: self category
! !

!Class methodsFor: 'instance variables' stamp: 'hg 8/21/2001 13:34'!
removeInstVarName: aString 
	"Remove the argument, aString, as one of the receiver's instance variables."

	| newInstVarString |
	(self instVarNames includes: aString)
		ifFalse: [self error: aString , ' is not one of my instance variables'].
	newInstVarString _ ''.
	(self instVarNames copyWithout: aString) do: 
		[:varName | newInstVarString _ newInstVarString , ' ' , varName].
	^(ClassBuilder new)
		name: self name
		inEnvironment: self module
		subclassOf: superclass
		type: self typeOfClass
		instanceVariableNames: newInstVarString
		classVariableNames: self classVariablesString
		poolDictionaries: self sharedPoolsString
		category: self category! !

!Class methodsFor: 'class variables' stamp: 'hg 8/21/2001 21:41'!
addClassVarName: aString 
	"Add the argument, aString, as a class variable of the receiver.
	Signal an error if the first character of aString is not capitalized,
	or if it is already a variable named in the class."
	| symbol |
	aString first isLowercase
		ifTrue: [^self error: aString, ' class variable name should be capitalized; proceed to include anyway.'].
	symbol _ aString asSymbol.
	self withAllSubclasses do: 
		[:subclass | 
		subclass scopeHas: symbol
			ifTrue: [:temp | 
					^ self error: aString 
						, ' is already used as a variable name in class ' 
						, subclass name]].
	classPool == nil ifTrue: [classPool _ Dictionary new].
	(classPool includesKey: symbol) ifFalse: 
		["Pick up any refs in Undeclared"
		self module changes changeClass: self from: self.
		classPool declare: symbol from: Undeclared]! !

!Class methodsFor: 'compiling' stamp: 'hg 8/14/2001 17:49'!
definesName: varName lookInSuper: lookInSuper ifTrue: assocBlock
	"Look up the first argument, varName, in the the receiver. If it is there,
	pass the association to the second argument, assocBlock, and answer true."

	| assoc |
	"First look in classVar dictionary."
	(assoc _ self classPool associationAt: varName ifAbsent: []) == nil
		ifFalse: [assocBlock value: assoc.
				^ true].

	"Next look in shared pools."
	self sharedPools do: 
		[:pool | 
		assoc _ pool associationAt: varName ifAbsent: [
			"String key hack from Hypersqueak now used in Wonderland  **Eliminate this**"
			pool associationAt: varName asString ifAbsent: []].
		assoc ifNotNil: [
				assocBlock value: assoc.
				^true]].

	"Finally look higher up the superclass chain if appropriate, and fail at the end."
	(lookInSuper and: [superclass notNil])
		ifTrue: [^ superclass definesName: varName lookInSuper: true ifTrue: assocBlock].

	^false! !

!Class methodsFor: 'compiling' stamp: 'hg 8/21/2001 18:58'!
scopeHas: varName ifTrue: assocBlock
	"Look up the first argument, varName, in the context of the receiver. If it is there,
	pass the association to the second argument, assocBlock, and answer true.
	Do NOT look in superclasses' modules!!"

	| assoc |
	self definesName: varName lookInSuper: true ifTrue: [:a |
		assocBlock value: a.
		^ true].

	"Next look in home module."
	assoc _ self module associationFor: varName ifAbsent: [nil].
	assoc ifNotNil: [
		assocBlock value: assoc.
		^ true].

	"Finally look it up in Smalltalk. This is a compatibility patch for now."
	(assoc _ Smalltalk associationAt: varName ifAbsent: []) == nil
		ifFalse: [assocBlock value: assoc.
				^ true].

	^false! !

!Class methodsFor: 'subclass creation' stamp: 'hg 8/22/2001 22:34'!
subclass: t instanceVariableNames: f classVariableNames: d poolDictionaries: s category: cat 
	"This is the standard initialization message for creating a new class as a 
	subclass of an existing class (the receiver)."
	^(ClassBuilder new)
		superclass: self
		subclass: t
		instanceVariableNames: f
		classVariableNames: d
		poolDictionaries: s
		module: self module
		category: cat
! !

!Class methodsFor: 'subclass creation' stamp: 'hg 8/21/2001 22:26'!
subclass: t instanceVariableNames: f classVariableNames: d poolDictionaries: s module: mod category: cat 
	"This is the standard initialization message for creating a new class as a 
	subclass of an existing class (the receiver)."
	^(ClassBuilder new)
		superclass: self
		subclass: t
		instanceVariableNames: f
		classVariableNames: d
		poolDictionaries: s
		module: mod
		category: cat
! !

!Class methodsFor: 'fileIn/Out' stamp: 'hg 8/21/2001 21:41'!
removeFromChanges
	"References to the receiver, a class, and its metaclass should no longer be included in the system ChangeSet.
	7/18/96 sw: call removeClassAndMetaClassChanges:"

	self module changes removeClassAndMetaClassChanges: self! !


!Encoder methodsFor: 'private' stamp: 'hg 8/21/2001 15:49'!
lookupInPools: varName ifFound: assocBlock

	Symbol hasInterned: varName ifTrue:
		[:sym | (class scopeHas: sym ifTrue: assocBlock) ifTrue: [^ true].
		(Preferences valueOfFlag: #lenientScopeForGlobals)  "**Temporary**"
			ifTrue: [^ Module root lenientScopeHas: sym ifTrue: assocBlock]
			ifFalse: [^ false]].
	^ class scopeHas: varName ifTrue: assocBlock.  "Maybe a string in a pool  **Eliminate this**"! !


!HierarchicalUrl methodsFor: 'access' stamp: 'squeak 8/20/2001 19:28'!
path: anArray

	path _ (anArray size > 1 and: [anArray first = '']) 
		ifTrue: [anArray allButFirst]
		ifFalse: [anArray]! !


!ImageSegment methodsFor: 'read/write segment' stamp: 'hg 8/21/2001 14:15'!
rootsIncludingPlayers
	"Return a new roots array with more objects.  (Caller should store into rootArray.) Player (non-systemDefined) gets its class and metaclass put into the Roots array.  Then ask for the segment again."

| extras havePresenter players morphs env existing |
userRootCnt ifNil: [userRootCnt _ arrayOfRoots size].
extras _ OrderedCollection new.
arrayOfRoots do: [:root | 
	(root isKindOf: Presenter) ifTrue: [havePresenter _ root].
	(root isKindOf: PasteUpMorph) ifTrue: [
			root isWorldMorph ifTrue: [havePresenter _ root presenter]].
	(root isKindOf: Project) ifTrue: [havePresenter _ root world presenter]].
havePresenter ifNotNil: [
	havePresenter flushPlayerListCache.		"old and outside guys"
	morphs _ IdentitySet new: 400.
	havePresenter associatedMorph allMorphsAndBookPagesInto: morphs.
	players _ (morphs select: [:m | m player ~~ nil] 
				thenCollect: [:m | m player]) asArray.
	players _ players select: [:ap | (arrayOfRoots includes: ap class) not
		& (ap class isSystemDefined not)].
	extras addAll: (players collect: [:each | each class]).
	(env _ havePresenter world project module) ifNil: [
		extras addAll: (players collect: [:each | each class class])].
	extras addAll: morphs.	"Make then ALL roots!!"
	].
existing _ arrayOfRoots asIdentitySet.
extras _ extras reject: [ :each | existing includes: each].
extras isEmpty ifTrue: [^ nil].	"no change"
env 
	ifNil: ["old pre-module"
		havePresenter _ players _ morphs _ nil.
		^ arrayOfRoots, extras]	"will contain multiples of some, but reduced later"
	ifNotNil: [
		(env includesKey: #Object) ifTrue: [self error: 'only look in local env, not up chain'].
			"If get error, use a message other than includesKey:"
		extras do: [:cls | 
			(env includesKey: cls name) ifFalse: [
				env declare: cls name from: Smalltalk]].
		havePresenter _ players _ morphs _ env _ nil.
		^ arrayOfRoots, extras	"still need in roots in case outside pointers"
		]! !


!MethodReference methodsFor: 'queries' stamp: 'hg 8/21/2001 18:35'!
actualClass 

	| actualClass |

	actualClass _ Module root definitionFor: classSymbol ifAbsent: [^nil].
	classIsMeta ifTrue: [^actualClass class].
	^actualClass

! !


!Project methodsFor: 'accessing' stamp: 'hg 8/21/2001 13:33'!
module
	^ environment! !

!Project methodsFor: 'isolation layers' stamp: 'squeak 8/20/2001 16:07'!
beIsolated
	"Establish an isolation layer at this project.
	This requires clearing the current changeSet or installing a new one."

	isolatedHead ifTrue: [^ self error: 'Already isolated'].
	self isCurrentProject ifFalse:
		[^ self inform: 'Must be in this project to isolate it'.].
	changeSet isEmpty ifFalse: [changeSet _ ChangeSorter newChangeSet].
	changeSet beIsolationSetFor: self.
	isolatedHead _ true.
	inForce _ true.
	environment _ Environment new setName: self name inOuterEnvt: Smalltalk.

! !


!SmartRefStream methodsFor: 'import image segment' stamp: 'hg 8/21/2001 21:45'!
mapClass: newClass origName: originalName
	"See if instances changed shape.  If so, make a fake class for the old shape and return it.  Remember the original class name."

	| newName oldInstVars fakeClass |
	newClass isMeta ifTrue: [^ newClass].
	newName _ newClass name.
	(steady includes: newClass) & (newName == originalName) ifTrue: [^ newClass].
		"instances in the segment have the right shape"
	oldInstVars _ structures at: originalName ifAbsent: [
			self error: 'class is not in structures list'].	"Missing in object file"
	fakeClass _ Object subclass: ('Fake37', originalName) asSymbol
		instanceVariableNames: oldInstVars allButFirst
		classVariableNames: ''
		poolDictionaries: ''
		category: 'Obsolete'.
	fakeClass module changes removeClassChanges: fakeClass name.	"reduce clutter"
	^ fakeClass
! !


!StringHolder methodsFor: 'message list menu' stamp: 'hg 8/21/2001 21:46'!
removeFromCurrentChanges
	"Tell the changes mgr to forget that the current msg was changed."

	self selectedClassOrMetaClass changes removeSelectorChanges: self selectedMessageName 
			class: self selectedClassOrMetaClass.
	self changed: #annotation! !


!CodeHolder methodsFor: 'commands' stamp: 'hg 8/21/2001 21:44'!
adoptMessageInCurrentChangeset
	"Add the receiver's method to the current change set if not already there"

	self setClassAndSelectorIn: [:cl :sel |
		cl ifNotNil:
			[cl module changes adoptSelector: sel forClass: cl.
			self changed: #annotation]]
! !


!Browser methodsFor: 'class functions' stamp: 'hg 8/21/2001 21:42'!
addAllMethodsToCurrentChangeSet
	"Add all the methods in the selected class or metaclass to the current change set.  You ought to know what you're doing before you invoke this!!"

	| aClass |
	(aClass _ self selectedClassOrMetaClass) ifNotNil:
		[aClass selectors do:
			[:sel |
				self selectedClassOrMetaClass changes adoptSelector: sel forClass: aClass].
		self changed: #annotation]
! !

!Browser methodsFor: 'class functions' stamp: 'hg 8/21/2001 16:07'!
defineClass: defString notifying: aController  
	"The receiver's textual content is a request to define a new class. The
	source code is defString. If any errors occur in compilation, notify
	aController."
	| oldClass class newClassName defTokens keywdIx envt |
	oldClass _ self selectedClassOrMetaClass.
	defTokens _ defString findTokens: Character separators.
	keywdIx _ defTokens findFirst: [:x | x beginsWith: 'category'].
	envt _ Module root moduleForCategory: ((defTokens at: keywdIx+1) copyWithout: $').
	keywdIx _ defTokens findFirst: [:x | '*subclass*' match: x].
	newClassName _ (defTokens at: keywdIx+1) copyWithoutAll: '#()'.
	((oldClass isNil or: [oldClass name asString ~= newClassName])
		and: [envt includesKeyOrAbove: newClassName asSymbol]) ifTrue:
			["Attempting to define new class over existing one when
				not looking at the original one in this browser..."
			(self confirm: ((newClassName , ' is an existing class in this system.
Redefining it might cause serious problems.
Is this really what you want to do?') asText makeBoldFrom: 1 to: newClassName size))
				ifFalse: [^ false]].
	"ar 8/29/1999: Use oldClass superclass for defining oldClass
	since oldClass superclass knows the definerClass of oldClass."
	oldClass ifNotNil:[oldClass _ oldClass superclass].
	class _ oldClass subclassDefinerClass
				evaluate: defString
				notifying: aController
				logged: true.
	(class isKindOf: Behavior)
		ifTrue: [self changed: #classList.
				self classListIndex: 
					(self classList indexOf: 
						((class isKindOf: Metaclass)
							ifTrue: [class soleInstance name]
							ifFalse: [class name])).
				self clearUserEditFlag; editClass.
				^ true]
		ifFalse: [^ false]! !

!Browser methodsFor: 'class list' stamp: 'hg 8/21/2001 21:11'!
selectedClass
	"Answer the class that is currently selected. Answer nil if no selection 
	exists."

	| name |
	(name _ self selectedClassName) ifNil: [^ nil].
	^Root definitionAnywhereFor: name ifAbsent: [nil]! !

!Browser methodsFor: 'message category functions' stamp: 'hg 8/21/2001 21:42'!
alphabetizeMessageCategories
	classListIndex = 0 ifTrue: [^ false].
	self okToChange ifFalse: [^ false].
	self selectedClassOrMetaClass changes reorganizeClass: self selectedClassOrMetaClass.
	self classOrMetaClassOrganizer sortCategories.
	self clearUserEditFlag.
	self editClass.
	self classListIndex: classListIndex.
	^ true! !

!Browser methodsFor: 'message category functions' stamp: 'hg 8/21/2001 21:42'!
changeMessageCategories: aString 
	"The characters in aString represent an edited version of the the message 
	categories for the selected class. Update this information in the system 
	and inform any dependents that the categories have been changed. This 
	message is invoked because the user had issued the categories command 
	and edited the message categories. Then the user issued the accept 
	command."

	self selectedClassOrMetaClass changes reorganizeClass: self selectedClassOrMetaClass.
	self classOrMetaClassOrganizer changeFromString: aString.
	self clearUserEditFlag.
	self editClass.
	self classListIndex: classListIndex.
	^ true! !

!Browser methodsFor: 'message category functions' stamp: 'hg 8/21/2001 21:42'!
renameCategory
	"Prompt for a new category name and add it before the
	current selection, or at the end if no current selection"
	| oldIndex oldName newName |
	classListIndex = 0 ifTrue: [^ self].
	self okToChange ifFalse: [^ self].
	(oldIndex _ messageCategoryListIndex) = 0 ifTrue: [^ self].
	oldName _ self selectedMessageCategoryName.
	newName _ self
		request: 'Please type new category name'
		initialAnswer: oldName.
	newName isEmpty
		ifTrue: [^ self]
		ifFalse: [newName _ newName asSymbol].
	newName = oldName ifTrue: [^ self].
	self selectedClassOrMetaClass changes reorganizeClass: self selectedClassOrMetaClass.
	self classOrMetaClassOrganizer
		renameCategory: oldName
		toBe: newName.
	self classListIndex: classListIndex.
	self messageCategoryListIndex: oldIndex.
	self changed: #messageCategoryList.
! !

!Browser methodsFor: 'system category functions' stamp: 'hg 8/21/2001 21:55'!
potentialClassNames
	"Answer the names of all the classes that could be viewed in this browser.  This hook is provided so that HierarchyBrowsers can indicate their restricted subset.  For generic Browsers, the entire list of classes known to Smalltalk is provided, though of course that really only is accurate in the case of full system browsers."

	^ Root classNames! !


!SystemDictionary methodsFor: 'class names' stamp: 'hg 8/21/2001 21:52'!
removeClassFromSystem: aClass logged: aBool
	"Delete the class, aClass, from the system, but log the removal neither to the current change set nor to the changes log"
	aBool ifTrue:[
		aClass wantsChangeSetLogging ifTrue:
			[aClass module changes noteRemovalOf: aClass].
		aClass acceptsLoggingOfCompilation ifTrue:
			[Smalltalk logChange:  'Smalltalk removeClassNamed: #', aClass name].
	].
	SystemOrganization removeElement: aClass name.
	self removeFromStartUpList: aClass.
	self removeFromShutDownList: aClass.
	self removeKey: aClass name ifAbsent: [].
	self flushClassNameCache
! !

!SystemDictionary methodsFor: 'class names' stamp: 'hg 8/21/2001 21:51'!
renameClass: aClass as: newName 
	"Rename the class, aClass, to have the title newName."
	| oldref i |
	SystemOrganization classify: newName under: aClass category.
	SystemOrganization removeElement: aClass name.
	aClass module changes renameClass: aClass as: newName.
	oldref _ self associationAt: aClass name.
	self removeKey: aClass name.
	oldref key: newName.
	self add: oldref.  "Old association preserves old refs"
	(Array with: StartUpList with: ShutDownList) do:
		[:list |  i _ list indexOf: aClass name ifAbsent: [0].
		i > 0 ifTrue: [list at: i put: newName]].
	self flushClassNameCache! !

!SystemDictionary methodsFor: 'dictionary access' stamp: 'hg 8/21/2001 13:57'!
associationFor: varName ifAbsent: absentBlock 
	"Compatibility with module protocol."

	^ self associationAt: varName ifAbsent: absentBlock! !

!SystemDictionary methodsFor: 'dictionary access' stamp: 'hg 8/21/2001 13:56'!
associationOrUndeclaredFor: key 
	"return an association or install in undeclared.  Used for mating up ImageSegments."

	^ self associationFor: key ifAbsent: [
		Undeclared at: key put: nil.
		Undeclared associationAt: key]! !


!Environment class methodsFor: 'system conversion' stamp: 'hg 8/21/2001 17:13'!
reorganizeEverything
	"Environment reorganizeEverything."

	| bigCat envt pool s |
	"First check for clashes between environment names and existing globals..."
	SystemOrganization categories do:
		[:cat | bigCat _ (cat asString copyUpTo: '-' first) asSymbol.
		(Smalltalk kernelCategories includes: bigCat) ifFalse:
			[(Smalltalk includesKey: bigCat) ifTrue:
				[^ self error: bigCat , ' cannot be used to name
both a package and a class or other global variable.
No reorganization will be attempted.']]].

	(PopUpMenu confirm:
'Your image is about to be partitioned into environments.
Many things may not work after this, so you should be
working in a throw-away copy of your working image.
Are you really ready to procede?
(choose ''no'' to stop here safely)')
		ifFalse: [^ PopUpMenu notify: 'No changes were made'].

	Smalltalk newChanges: (ChangeSet basicNewNamed: 'Reorganization').

	"Recreate the Smalltalk dictionary as the top-level Environment."
! !


!UndefinedObject methodsFor: 'class hierarchy' stamp: 'hg 8/21/2001 13:34'!
module
	"Necessary to support disjoint class hierarchies."
	^Smalltalk! !

!UndefinedObject methodsFor: 'class hierarchy' stamp: 'hg 8/21/2001 22:28'!
subclass: nameOfClass  "Define root (superclass = nil) of a class hierarchy"
	instanceVariableNames: instVarNames
	classVariableNames: classVarNames
	poolDictionaries: poolDictnames
	category: category
	^(ClassBuilder new)
		superclass: self
		subclass: nameOfClass
		instanceVariableNames: instVarNames
		classVariableNames: classVarNames
		poolDictionaries: poolDictnames
		module: self module
		category: category
! !

UndefinedObject removeSelector: #environment!
Environment removeSelector: #associationAtOrAbove:ifAbsent:!
Environment removeSelector: #setName:outerEnvt:!
SystemDictionary removeSelector: #associationAtOrAbove:ifAbsent:!
SystemDictionary removeSelector: #associationOrUndeclaredAt:!
Browser removeSelector: #selectedEnvironment!
Project removeSelector: #environment!
Metaclass removeSelector: #environment!
Class removeSelector: #environment!
Class removeSelector: #environment:!
ClassBuilder removeSelector: #superclass:subclass:instanceVariableNames:classVariableNames:poolDictionaries:category:!
ClassBuilder removeSelector: #validateClassName:!
Behavior removeSelector: #environment!


More information about the Squeak-dev mailing list