The Trunk: System-cwp.663.mcz

Colin Putney uploaded a new version of System to project The Trunk:
http://source.squeak.org/trunk/System-cwp.663.mcz

==================== 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.
  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') -----
  prepareToBeSaved
  "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') -----
  cleanUp
  "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') -----
  cleanOutUndeclared
+ "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') -----
  methodsWithUnboundGlobals
  "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|
  m literals anySatisfy:
  [:l|
  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!