[Pkg] The Trunk: System-cwp.663.mcz

commits at source.squeak.org commits at source.squeak.org
Sat Jan 18 15:50:02 UTC 2014

Colin Putney uploaded a new version of System to project The Trunk:

==================== Summary ====================

Name: System-cwp.663
Author: cwp
Time: 18 January 2014, 10:48:09.728 am
UUID: f3f0e545-2d39-4f63-aa7e-311e81892dfd
Ancestors: System-cmm.662

Remove direct references to Undeclared and route through the appropriate environment. Flag methods that need to be made environment-aware.

=============== Diff against System-cmm.662 ===============

Item was changed:
  ----- Method: Association>>objectForDataStream: (in category '*System-Object Storage-objects from disk') -----
  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."
+ 	self flag: #environments.
  	^ (Smalltalk globals associationAt: key ifAbsent: [nil]) == self 
  		ifTrue: [dp := DiskProxy global: #Smalltalk selector: #associationOrUndeclaredAt: 
  							args: (Array with: key).
  			refStrm replace: self with: dp.
  		ifFalse: [self]!

Item was changed:
  ----- Method: DiskProxy>>comeFullyUpOnReload: (in category 'i/o') -----
  comeFullyUpOnReload: smartRefStream
  	"Internalize myself into a fully alive object after raw loading from a DataStream. (See my class comment.)  DataStream will substitute the object from this eval for the DiskProxy."
  	| globalObj symbol pr nn arrayIndex |
+ 	self flag: #environments.
  	symbol := globalObjectName.
  	"See if class is mapped to another name"
  	(smartRefStream respondsTo: #renamed) ifTrue: [
  		"If in outPointers in an ImageSegment, remember original class name.  
  		 See mapClass:installIn:.  Would be lost otherwise."
  		((thisContext sender sender sender sender sender sender 
  			sender sender receiver class == ImageSegment) and: [ 
  		thisContext sender sender sender sender method == 
  			(DataStream compiledMethodAt: #readArray)]) ifTrue: [
  				arrayIndex := (thisContext sender sender sender sender) tempAt: 4.
  					"index var in readArray.  Later safer to find i on stack of context."
  				smartRefStream renamedConv at: arrayIndex put: symbol].	"save original name"
  		symbol := smartRefStream renamed at: symbol ifAbsent: [symbol]].	"map"
  	globalObj := Smalltalk at: symbol ifAbsent: [
  		preSelector == nil & (constructorSelector = #yourself) ifTrue: [
  			Transcript cr; show: symbol, ' is undeclared.'.
  			(Undeclared includesKey: symbol) ifTrue: [^ Undeclared at: symbol].
  			Undeclared at: symbol put: nil.
  			^ nil].
  		^ self error: 'Global "', symbol, '" not found'].
  	((symbol == #World) and: [Smalltalk isMorphic not]) ifTrue: [
  		self inform: 'These objects will work better if opened in a Morphic World.
  Dismiss and reopen all menus.'].
  	preSelector ifNotNil: [
  		Symbol hasInterned: preSelector ifTrue: [:selector |
  			[globalObj := globalObj perform: selector] on: Error do: [:ex |
  				ex messageText = 'key not found' ifTrue: [^ nil].
  				^ ex signal]]
  	symbol == #Project ifTrue: [
  		(constructorSelector = #fromUrl:) ifTrue: [
  			nn := (constructorArgs first findTokens: '/') last.
  			nn := (nn findTokens: '.|') first.
  			pr := Project named: nn. 
  			^ pr ifNil: [self] ifNotNil: [pr]].
  		pr := globalObj perform: constructorSelector withArguments: constructorArgs.
  		^ pr ifNil: [self] ifNotNil: [pr]].	"keep the Proxy if Project does not exist"
  	constructorSelector ifNil: [^ globalObj].
  	Symbol hasInterned: constructorSelector ifTrue: [:selector |
  		[^ globalObj perform: selector withArguments: constructorArgs] on: Error do: [:ex |
  			ex messageText = 'key not found' ifTrue: [^ nil].
  			^ ex signal]
  				"args not checked against Renamed"
  	^ nil 	"was not in proper form"!

Item was changed:
  ----- Method: ImageSegment>>prepareToBeSaved (in category 'fileIn/Out') -----
  	"Prepare objects in outPointers to be written on the disk.  They must be able to match up with existing objects in their new system.  outPointers is already a copy.
  	Classes are already converted to a DiskProxy.  
  	Associations in outPointers:
  1) in Smalltalk.
  2) in a classPool.
  3) in a shared pool.
  4) A pool dict pointed at directly"
  | left myClasses outIndexes |
+ self flag: #environments.
  myClasses := Set new.
  arrayOfRoots do: [:aRoot | aRoot class class == Metaclass ifTrue: [myClasses add: aRoot]].
  outIndexes := IdentityDictionary new.
  outPointers withIndexDo: [:anOut :ind | | key | 
  	anOut isVariableBinding ifTrue: [
  		(myClasses includes: anOut value)
  			ifFalse: [outIndexes at: anOut put: ind]
  			ifTrue: [(Smalltalk globals associationAt: anOut key ifAbsent: [3]) == anOut 
  				ifTrue: [outPointers at: ind put: 
  					(DiskProxy global: #Smalltalk selector: #associationDeclareAt: 
  						args: (Array with: anOut key))]
  				ifFalse: [outIndexes at: anOut put: ind]
  	(anOut isKindOf: Dictionary) ifTrue: ["Pools pointed at directly"
  		(key := Smalltalk globals keyAtIdentityValue: anOut ifAbsent: [nil]) ifNotNil: [
  			outPointers at: ind put: 
  				(DiskProxy global: key selector: #yourself args: #())]].
  	anOut isMorph ifTrue: [outPointers at: ind put: 
  		(StringMorph contents: anOut printString, ' that was not counted')]
  left := outIndexes keys asSet.
  left size > 0 ifTrue: ["Globals"
  	(left copy) do: [:assoc |	"stay stable while delete items"
  		(Smalltalk globals associationAt: assoc key ifAbsent: [3]) == assoc ifTrue: [
  			outPointers at: (outIndexes at: assoc) put: 
  				(DiskProxy global: #Smalltalk selector: #associationAt: 
  					args: (Array with: assoc key)).
  			left remove: assoc]]].
  left size > 0 ifTrue: ["Class variables"
  	Smalltalk allClassesDo: [:cls | cls classPool size > 0 ifTrue: [
  		(left copy) do: [:assoc |	"stay stable while delete items"
  			(cls classPool associationAt: assoc key ifAbsent: [3]) == assoc ifTrue: [
  				outPointers at: (outIndexes at: assoc) put: 
  					(DiskProxy new global: cls name
  						preSelector: #classPool
  						selector: #associationAt: 
  						args: (Array with: assoc key)).
  				left remove: assoc]]]]].
  left size > 0 ifTrue: ["Pool variables"
  	Smalltalk globals associationsDo: [:poolAssoc | | pool |
  		poolAssoc value class == Dictionary ifTrue: ["a pool"
  			pool := poolAssoc value.
  			(left copy) do: [:assoc |	"stay stable while delete items"
  				(pool associationAt: assoc key ifAbsent: [3]) == assoc ifTrue: [
  					outPointers at: (outIndexes at: assoc) put: 
  						(DiskProxy global: poolAssoc key selector: #associationAt: 
  							args: (Array with: assoc key)).
  					left remove: assoc]]]]].
  left size > 0 ifTrue: [
  	"If points to class in arrayOfRoots, must deal with it separately"
  	"OK to have obsolete associations that just get moved to the new system"
  	self inform: 'extra associations'.
  	left inspect].

Item was changed:
  ----- Method: ObjectScanner>>rename:toBe: (in category 'utilities') -----
  rename: existingName toBe: newName
  	"See if there is a conflict between what the fileIn wants to call the new UniClass (Player23) and what already exists for another unique instance.  If conflict, make a class variable to intercept the existingName and direct it to class newName."
+ 	self flag: #environments.
  	existingName = newName ifFalse: [
  		self class ensureClassPool.	"create the dictionary"
  		"can't use addClassVarName: because it checks for conflicts with Smalltalk"
  		(self class classPool includesKey: existingName) ifFalse: 
  			["Pick up any refs in Undeclared"
  			self class classPool declare: existingName from: Undeclared].
  		self class classPool at: existingName put: (Smalltalk at: newName).
  		pvt3SmartRefStrm renamed at: existingName put: newName]!

Item was changed:
  ----- Method: SmalltalkImage class>>cleanUp (in category 'class initialization') -----
  	"Flush caches"
- 	Smalltalk flushClassNameCache.
- 	Undeclared removeUnreferencedKeys.
  	Smalltalk removeObsoleteClassesFromCompactClassesArray!

Item was changed:
  ----- Method: SmalltalkImage>>associationDeclareAt: (in category 'dictionary access') -----
  associationDeclareAt: aKey
  	"DO NOT DEPRECATE - used by ImageSegments"
+ 	self flag: #environments.
  	^globals associationDeclareAt: aKey!

Item was changed:
  ----- Method: SmalltalkImage>>cleanOutUndeclared (in category 'housekeeping') -----
+ 	"This should be deprecated, and senders rewritten to deal with environments directly"
+ 	self flag: #environments.
+ 	globals purgeUndeclared.!
- 	globals undeclared removeUnreferencedKeys!

Item was changed:
  ----- Method: SystemDictionary>>associationOrUndeclaredAt: (in category 'dictionary access') -----
  associationOrUndeclaredAt: key 
  	"return an association or install in undeclared.  Used for mating up ImageSegments."
+ 	self flag: #environments.
  	^ self associationAt: key ifAbsent: [
  		Undeclared at: key put: nil.
  		Undeclared associationAt: key]!

Item was changed:
  ----- Method: SystemNavigation>>methodsWithUnboundGlobals (in category 'query') -----
  	"Get all methods that use undeclared global objects that are not listed in Undeclared. For a clean image the result should be empty."
  	"SystemNavigation new methodsWithUnboundGlobals"
+ 	self flag: #environments.
  	^self allSelect:
  		m literals anySatisfy:
  			l isVariableBinding
  			and: [l key isSymbol "avoid class-side methodClass literals"
  			and: [(m methodClass bindingOf: l key)
  					ifNil: [(Undeclared associationAt: l key ifAbsent: []) ~~ l]
  					ifNotNil: [:b| b ~~ l]]]]]!

Item was changed:
  Object subclass: #Utilities
  	instanceVariableNames: ''
+ 	classVariableNames: 'AuthorInitials AuthorName CommonRequestStrings LastStats ScrapsBook'
- 	classVariableNames: 'AuthorInitials AuthorName CommonRequestStrings LastStats'
  	poolDictionaries: ''
  	category: 'System-Support'!
  !Utilities commentStamp: '<historical>' prior: 0!
  A repository for general and miscellaneous utilities; much of what is here are in effect global methods that don't naturally attach to anything else.  1/96 sw!

More information about the Packages mailing list