The Trunk: System-ul.393.mcz

Levente Uzonyi uploaded a new version of System to project The Trunk:
http://source.squeak.org/trunk/System-ul.393.mcz

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

Name: System-ul.393
Author: ul
Time: 16 November 2010, 5:11:01.011 am
UUID: ee4afd6d-fcb8-2d42-976e-4a4c427a2213
Ancestors: System-ul.392

- use #= for integer comparison instead of #== (http://bugs.squeak.org/view.php?id=2788 )

=============== Diff against System-ul.392 ===============

Item was changed:
  ----- Method: ChangeSet class>>scanVersionsOf:class:meta:category:selector: (in category 'scanning') -----
  scanVersionsOf: method class: class meta: meta category: cat selector: selector
  | position prevPos prevFileIndex preamble tokens sourceFilesCopy stamp changeList file |
  changeList := OrderedCollection new.
  position := method filePosition.
  sourceFilesCopy := SourceFiles collect:[:x | x ifNotNil:[x readOnlyCopy]].
+ method fileIndex = 0 ifTrue: [^ nil].
- method fileIndex == 0 ifTrue: [^ nil].
  file := sourceFilesCopy at: method fileIndex.
  [position notNil & file notNil] whileTrue:[
  preamble := method getPreambleFrom: file at: (0 max: position - 3).
  "Preamble is likely a linked method preamble, if we're in
  a changes file (not the sources file).  Try to parse it
  for prior source position and file index"
  prevPos := nil.
  stamp := ''.
  (preamble findString: 'methodsFor:' startingAt: 1) > 0
  ifTrue: [tokens := [Scanner new scanTokens: preamble] on: Error do:[#()]]
  ifFalse: [tokens := Array new  "ie cant be back ref"].
  ((tokens size between: 7 and: 8)
  and: [(tokens at: tokens size-5) = #methodsFor:]) ifTrue:[
  (tokens at: tokens size-3) = #stamp: ifTrue:[
  "New format gives change stamp and unified prior pointer"
  stamp := tokens at: tokens size-2.
  prevPos := tokens last.
  prevFileIndex := sourceFilesCopy fileIndexFromSourcePointer: prevPos.
  prevPos := sourceFilesCopy filePositionFromSourcePointer: prevPos.
  ] ifFalse: ["Old format gives no stamp; prior pointer in two parts"
  prevPos := tokens at: tokens size-2.
  prevFileIndex := tokens last.
  ].
  (prevPos = 0 or: [prevFileIndex = 0]) ifTrue: [prevPos := nil]
  ].
  ((tokens size between: 5 and: 6)
  and: [(tokens at: tokens size-3) = #methodsFor:]) ifTrue:[
  (tokens at: tokens size-1) = #stamp: ifTrue: [
  "New format gives change stamp and unified prior pointer"
  stamp := tokens at: tokens size.
  ]
  ].
    changeList add: (ChangeRecord new file: file position: position type: #method
  class: class name category: cat meta: meta stamp: stamp).
  position := prevPos.
  prevPos notNil ifTrue:[file := sourceFilesCopy at: prevFileIndex].
  ].
  sourceFilesCopy do: [:x | x ifNotNil:[x close]].
  ^changeList!

Item was changed:
  ----- Method: ChangeSet>>lookForSlips (in category 'fileIn/Out') -----
  lookForSlips
  "Scan the receiver for changes that the user may regard as slips to be remedied"
 
  | slips nameLine msg |
  nameLine := '
  "', self name, '"
  '.
+ (slips := self checkForSlips) size = 0 ifTrue:
- (slips := self checkForSlips) size == 0 ifTrue:
  [^ self inform: 'No slips detected in change set', nameLine].
 
+ msg := slips size = 1
- msg := slips size == 1
  ifTrue:
  [ 'One method in change set', nameLine,
  'has a halt, reference to the Transcript,
  and/or some other ''slip'' in it.
  Would you like to browse it? ?']
  ifFalse:
  [ slips size printString,
  ' methods in change set', nameLine, 'have halts or references to the
  Transcript or other ''slips'' in them.
  Would you like to browse them?'].
 
  (UIManager default  chooseFrom: #('Ignore' 'Browse slips') title: msg) = 2
  ifTrue: [self systemNavigation  browseMessageList: slips
  name: 'Possible slips in ', name]!

Item was changed:
  ----- Method: DataStream>>next (in category 'write and read') -----
  next
  "Answer the next object in the stream."
  | type selector anObject isARefType pos internalObject |
 
  type := byteStream next.
  type ifNil: [pos := byteStream position. "absolute!!!!"
  byteStream close. "clean up"
  byteStream position = 0
  ifTrue: [self error: 'The file did not exist in this directory']
  ifFalse: [self error: 'Unexpected end of object file'].
  pos. "so can see it in debugger"
  ^ nil].
  type = 0 ifTrue: [pos := byteStream position. "absolute!!!!"
  byteStream close. "clean up"
  self error: 'Expected start of object, but found 0'.
  ^ nil].
  isARefType := self noteCurrentReference: type.
  selector := #(readNil readTrue readFalse readInteger "<-4"
  readStringOld readSymbol readByteArray "<-7"
  readArray readInstance readReference readBitmap "<-11"
  readClass readUser readFloat readRectangle readShortInst "<-16"
  readString readWordArray readWordArrayForSegment "<-19"
+ readWordLike readMethod "<-21") at: type ifAbsent: [
+ pos := byteStream position. "absolute!!!!"
+ byteStream close.
+ self error: 'file is more recent than this system'. ^ nil].
- readWordLike readMethod "<-21") at: type.
- selector == 0 ifTrue: [pos := byteStream position. "absolute!!!!"
- byteStream close.
- self error: 'file is more recent than this system'. ^ nil].
  anObject := self perform: selector. "A method that recursively
  calls next (readArray, readInstance, objectAt:) must save &
  restore the current reference position."
  isARefType ifTrue: [self beginReference: anObject].
 
  "After reading the externalObject, internalize it.
  #readReference is a special case. Either:
    (1) We actually have to read the object, recursively calling
    next, which internalizes the object.
    (2) We just read a reference to an object already read and
    thus already interalized.
  Either way, we must not re-internalize the object here."
  selector == #readReference ifTrue: [^ anObject].
  internalObject := anObject comeFullyUpOnReload: self.
  internalObject == String ifTrue:[
  "This is a hack to figure out if we're loading a String class
  that really should be a ByteString. Note that these days this
  will no longer be necessary since we use #withClassVersion:
  for constructing the global thus using a different classVersion
  will perfectly do the trick."
  ((anObject isKindOf: DiskProxy)
  and:[anObject globalObjectName == #String
  and:[anObject constructorSelector == #yourself]]) ifTrue:[
  internalObject := ByteString]].
  ^ self maybeBeginReference: internalObject!

Item was changed:
  ----- Method: ExternalDropHandler>>handle:in:dropEvent: (in category 'accessing') -----
  handle: dropStream in: pasteUp dropEvent: anEvent
  | numArgs |
  numArgs := action numArgs.
+ numArgs = 1
- numArgs == 1
  ifTrue: [^action value: dropStream].
+ numArgs = 2
- numArgs == 2
  ifTrue: [^action value: dropStream value: pasteUp].
+ numArgs = 3
- numArgs == 3
  ifTrue: [^action value: dropStream value: pasteUp value: anEvent].
  self error: 'Wrong number of args for dop action.'!

Item was changed:
  ----- Method: ImageSegment>>copySmartRootsExport: (in category 'read/write segment') -----
  copySmartRootsExport: rootArray
  "Use SmartRefStream to find the object.  Make them all roots.  Create the segment in memory.  Project should be in first five objects in rootArray."
  | newRoots list segSize symbolHolder replacements naughtyBlocks allClasses sizeHint proj dummy |
  Smalltalk forgetDoIts.
 
  "self halt."
  symbolHolder := Symbol allSymbols. "Hold onto Symbols with strong pointers,
  so they will be in outPointers"
 
  dummy := ReferenceStream on: (DummyStream on: nil).
  "Write to a fake Stream, not a file"
  "Collect all objects"
  dummy insideASegment: true. "So Uniclasses will be traced"
  dummy rootObject: rootArray. "inform him about the root"
  dummy nextPut: rootArray.
  (proj :=dummy project) ifNotNil: [self dependentsSave: dummy].
  allClasses := SmartRefStream new uniClassInstVarsRefs: dummy.
  "catalog the extra objects in UniClass inst vars.  Put into dummy"
  allClasses do: [:cls |
  dummy references at: cls class put: false. "put Player5 class in roots"
  dummy blockers removeKey: cls class ifAbsent: []].
  "refs := dummy references."
  arrayOfRoots := self smartFillRoots: dummy. "guaranteed none repeat"
  self savePlayerReferences: dummy references. "for shared References table"
  replacements := dummy blockers.
  dummy project "recompute it" ifNil: [self error: 'lost the project!!'].
  dummy project class == DiskProxy ifTrue: [self error: 'saving the wrong project'].
  dummy := nil. "force GC?"
  naughtyBlocks := arrayOfRoots select: [ :each |
  (each isKindOf: ContextPart) and: [each hasInstVarRef]
  ].
 
  "since the caller switched ActiveWorld, put the real one back temporarily"
  naughtyBlocks isEmpty ifFalse: [
  World becomeActiveDuring: [ | goodToGo |
  goodToGo := (UIManager default
  chooseFrom: #('keep going' 'stop and take a look')
  title:
  'Some block(s) which reference instance variables
  are included in this segment. These may fail when
  the segment is loaded if the class has been reshaped.
+ What would you like to do?') = 1.
- What would you like to do?') == 1.
  goodToGo ifFalse: [
  naughtyBlocks inspect.
  self error: 'Here are the bad blocks'].
  ].
  ].
  "Creation of the segment happens here"
 
  "try using one-quarter of memory min: four megs to publish (will get bumped later)"
  sizeHint := (Smalltalk garbageCollect // 4 // 4) min: 1024*1024.
  self copyFromRoots: arrayOfRoots sizeHint: sizeHint areUnique: true.
  segSize := segment size.
  [(newRoots := self rootsIncludingBlockMethods) == nil] whileFalse: [
  arrayOfRoots := newRoots.
  self copyFromRoots: arrayOfRoots sizeHint: segSize areUnique: true].
  "with methods pointed at from outside"
  [(newRoots := self rootsIncludingBlocks) == nil] whileFalse: [
  arrayOfRoots := newRoots.
  self copyFromRoots: arrayOfRoots sizeHint: segSize areUnique: true].
  "with methods, blocks from outPointers"
  list := self compactClassesArray.
  outPointers := outPointers, ((list select: [:cls | cls ~~ nil]), (Array with: 1717 with: list)).
  1 to: outPointers size do: [:ii |
  (outPointers at: ii) isBlock ifTrue: [outPointers at: ii put: nil].
  (outPointers at: ii) class == MethodContext ifTrue: [outPointers at: ii put: nil].
  "substitute new object in outPointers"
  (replacements includesKey: (outPointers at: ii)) ifTrue: [
  outPointers at: ii put: (replacements at: (outPointers at: ii))]].
  proj ifNotNil: [self dependentsCancel: proj].
  symbolHolder.!

Item was changed:
  ----- Method: Locale>>fetchISO2Language (in category 'private') -----
  fetchISO2Language
  "Locale current fetchISO2Language"
  | lang isoLang |
  lang := self primLanguage.
  lang ifNil: [^nil].
  lang := lang copyUpTo: 0 asCharacter.
+ lang size = 2
- lang size == 2
  ifTrue: [^lang].
  isoLang := ISOLanguageDefinition iso3LanguageDefinition: lang.
  ^isoLang
  ifNil: [nil]
  ifNotNil: [isoLang iso2]!

Item was changed:
  ----- Method: ReferenceStream>>isAReferenceType: (in category 'writing') -----
  isAReferenceType: typeID
  "Return true iff typeID is one of the classes that can be written as a reference to an instance elsewhere in the stream."
 
  "too bad we can't put Booleans in an Array literal"
+ ^ (RefTypes at: typeID) = 1
- ^ (RefTypes at: typeID) == 1
  "NOTE: If you get a bounds error here, the file probably has bad bits in it.  The most common cause is a file unpacking program that puts linefeeds after carriage returns."!

Item was changed:
  ----- Method: SmartRefStream>>restoreClassInstVars (in category 'read write') -----
  restoreClassInstVars
  "Install the values of the class instance variables of UniClasses
  (i.e. scripts slotInfo).  classInstVars is ((#Player25 scripts slotInfo)
  ...).  Thank you Mark Wai for the bug fix."
 
  | normal trans classPlayer |
 
  self flag: #bobconv.
 
  classPlayer := Smalltalk at: #Player ifAbsent:[^self].
 
  self moreObjects ifFalse: [^ self]. "are no UniClasses with class inst vars"
  classInstVars := super next. "Array of arrays"
  normal := Object class instSize. "might give trouble if Player class superclass changes size"
  (structures at: #Player ifAbsent: [#()]) = #(0 'dependents' 'costume') ifTrue:
  [trans := 1]. "now (0 costume costumes).  Do the conversion of Player class
  inst vars in Update 509."
  classInstVars do: [:list | | aName newCls rList newName start |
  aName := (list at: 1) asSymbol.
  rList := list.
  newName := renamed at: aName ifAbsent: [aName].
  newCls := Smalltalk at: newName
  ifAbsent: [self error: 'UniClass definition missing'].
+ ("old conversion" trans = 1 and: [newCls inheritsFrom: classPlayer]) ifTrue: [
- ("old conversion" trans == 1 and: [newCls inheritsFrom: classPlayer]) ifTrue: [
  "remove costumeDictionary from Player class inst vars"
  rList := rList asOrderedCollection.
  rList removeAt: 4]. "costumeDictionary's value"
  start := list second = 'Update to read classPool' ifTrue: [4] ifFalse: [2].
  newCls class instSize = (normal + (rList size) - start + 1) ifFalse:
  [self error: 'UniClass superclass class has changed size'].
  "Need to install a conversion method mechanism"
  start = 4 ifTrue: [newCls instVarAt: normal - 1 "classPool" put: (list at: 3)].
  start to: rList size do: [:ii |
  newCls instVarAt: normal + ii - start + 1 put: (rList at: ii)]].
  !

Item was changed:
  ----- Method: SystemNavigation>>confirmRemovalOf:on: (in category 'ui') -----
  confirmRemovalOf: aSelector on: aClass
  "Determine if it is okay to remove the given selector. Answer 1 if it  
  should be removed, 2 if it should be removed followed by a senders  
  browse, and 3 if it should not be removed."
  | count answer caption allCalls |
  allCalls := self allCallsOn: aSelector.
+ (count := allCalls size) = 0
- (count := allCalls size) == 0
  ifTrue: [^ 1].
  "no senders -- let the removal happen without warning"
+ count = 1
- count == 1
  ifTrue: [(allCalls first actualClass == aClass
  and: [allCalls first methodSymbol == aSelector])
  ifTrue: [^ 1]].
  "only sender is itself"
  caption := 'This message has ' , count printString , ' sender'.
  count > 1
  ifTrue: [caption := caption copyWith: $s].
  answer := UIManager default
  chooseFrom: #('Remove it'
  'Remove, then browse senders'
  'Don''t remove, but show me those senders'
  'Forget it -- do nothing -- sorry I asked') title: caption.
+ answer = 3
- answer == 3
  ifTrue: [self
  browseMessageList: allCalls
  name: 'Senders of ' , aSelector
  autoSelect: aSelector keywords first].
+ answer = 0
- answer == 0
  ifTrue: [answer := 3].
  "If user didn't answer, treat it as cancel"
  ^ answer min: 3!

Item was changed:
  ----- Method: Utilities class>>applyUpdatesFromDiskToUpdateNumber:stopIfGap: (in category 'fetching updates') -----
  applyUpdatesFromDiskToUpdateNumber: lastUpdateNumber stopIfGap: stopIfGapFlag
  "To use this mechanism, be sure all updates you want to have considered
  are in a folder named 'updates' which resides in the same directory as  
  your image. Having done that, simply evaluate:  
 
  Utilities applyUpdatesFromDiskToUpdateNumber: 1234 stopIfGap: false  
 
  and all numbered updates <= lastUpdateNumber not yet in the image will
  be loaded in numerical order."
  | previousHighest currentUpdateNumber done fileNames aMessage updateDirectory loaded |
  updateDirectory := self getUpdateDirectoryOrNil.
  updateDirectory ifNil: [^ self].
  previousHighest := SystemVersion current highestUpdate.
  currentUpdateNumber := previousHighest.
  done := false.
  loaded := 0.
  [done]
  whileFalse: [currentUpdateNumber := currentUpdateNumber + 1.
  currentUpdateNumber > lastUpdateNumber
  ifTrue: [done := true]
  ifFalse: [fileNames := updateDirectory fileNamesMatching: currentUpdateNumber printString , '*'.
  fileNames size > 1
  ifTrue: [^ self inform: 'ambiguity -- two files both start with ' , currentUpdateNumber printString , '
  (at this point it is probably best to remedy
  the situation on disk, then try again.)'].
+ fileNames size = 0
- fileNames size == 0
  ifTrue: [Transcript cr; show: 'gap in updates from disk for update number '; print: currentUpdateNumber; show: ' found...'.
  done := stopIfGapFlag]
  ifFalse: [ChangeSet
  newChangesFromStream: (updateDirectory readOnlyFileNamed: fileNames first)
  named: fileNames first.
  SystemVersion current registerUpdate: currentUpdateNumber.
  loaded := loaded + 1]]].
  aMessage := loaded = 0
  ifTrue: ['No new updates found.']
  ifFalse: [loaded printString , ' update(s) loaded.'].
  self inform: aMessage , '
  Highest numbered update is now ' , (currentUpdateNumber - 1) printString , '.'!

Item was changed:
  ----- Method: Utilities class>>instanceComparisonsBetween:and: (in category 'miscellaneous') -----
  instanceComparisonsBetween: fileName1 and: fileName2
  "For differential results, run printSpaceAnalysis twice with different fileNames,
  then run this method...
  Smalltalk printSpaceAnalysis: 0 on: 'STspace.text1'.
  --- do something that uses space here ---
  Smalltalk printSpaceAnalysis: 0 on: 'STspace.text2'.
  Smalltalk instanceComparisonsBetween: 'STspace.text1' and 'STspace.text2'"
 
  | instCountDict report f aString items className newInstCount oldInstCount newSpace oldPair oldSpace |
  instCountDict := Dictionary new.
  report := ReadWriteStream on: ''.
  f := FileStream readOnlyFileNamed: fileName1.
  [f atEnd] whileFalse:
  [aString := f nextLine.
  items := aString findTokens: ' '.
+ (items size = 4 or: [items size = 5]) ifTrue:
- (items size == 4 or: [items size == 5]) ifTrue:
  [instCountDict at: items first put: (Array with: items third asNumber with: items fourth asNumber)]].
  f close.
 
  f := FileStream readOnlyFileNamed: fileName2.
  [f atEnd] whileFalse:
  [aString := f nextLine.
  items := aString findTokens: ' '.
+ (items size = 4 or: [items size = 5]) ifTrue:
- (items size == 4 or: [items size == 5]) ifTrue:
  [className := items first.
  newInstCount := items third asNumber.
  newSpace := items fourth asNumber.
  oldPair := instCountDict at: className ifAbsent: [nil].
  oldInstCount := oldPair ifNil: [0] ifNotNil: [oldPair first].
  oldSpace := oldPair ifNil: [0] ifNotNil: [oldPair second].
  oldInstCount ~= newInstCount ifTrue:
  [report nextPutAll: (newInstCount - oldInstCount) printString; tab; nextPutAll: (newSpace - oldSpace) printString; tab; nextPutAll: className asString; cr]]].
  f close.
 
  (StringHolder new contents: report contents)
  openLabel: 'Instance count differentials between ', fileName1, ' and ', fileName2!

Item was changed:
  ----- Method: Utilities class>>offerCommonRequests (in category 'common requests') -----
  offerCommonRequests
  "Offer up the common-requests menu.  If the user chooses one, then evaluate it, and -- provided the value is a number or string -- show it in the Transcript."
 
  "Utilities offerCommonRequests"
 
  | reply result aMenu index normalItemCount strings |
 
  Smalltalk isMorphic ifTrue: [^ self offerCommonRequestsInMorphic].
 
  (CommonRequestStrings == nil or: [CommonRequestStrings isKindOf: Array])
  ifTrue:
  [self initializeCommonRequestStrings].
 
  strings := CommonRequestStrings contents.
  normalItemCount := strings asString lineCount.
  aMenu := UIManager default
  chooseFrom: (strings asString lines copyWith: 'edit this menu')
  lines: (Array with: normalItemCount).
 
  index := aMenu startUp.
+ index = 0 ifTrue: [^ self].
- index == 0 ifTrue: [^ self].
  reply := aMenu labelString lineNumber: index.
+ reply size = 0 ifTrue: [^ self].
- reply size == 0 ifTrue: [^ self].
  index > normalItemCount ifTrue:
  [^ self editCommonRequestStrings].
 
  result := self evaluate: reply in: nil to: nil.
  (result isNumber) | (result isString)
  ifTrue:
  [Transcript cr; nextPutAll: result printString]!

Item was changed:
  ----- Method: Utilities class>>revertLastMethodSubmission (in category 'recent method submissions') -----
  revertLastMethodSubmission
  | changeRecords lastSubmission theClass theSelector |
  "If the most recent method submission was a method change, revert
  that change, and if it was a submission of a brand-new method,
  remove that method."
 
  RecentSubmissions isEmptyOrNil ifTrue: [^ Beeper beep].
  lastSubmission := RecentSubmissions last.
  theClass := lastSubmission actualClass ifNil: [^ Beeper beep].
  theSelector := lastSubmission methodSymbol.
  changeRecords := theClass changeRecordsAt: theSelector.
  changeRecords isEmptyOrNil ifTrue: [^ Beeper beep].
+ changeRecords size = 1
- changeRecords size == 1
  ifTrue:
  ["method has no prior version, so reverting in this case means removing"
  theClass removeSelector: theSelector]
  ifFalse:
  [changeRecords second fileIn].
 
  "Utilities revertLastMethodSubmission"!