[squeak-dev] The Trunk: System-ul.393.mcz
commits at source.squeak.org
commits at source.squeak.org
Tue Nov 16 04:11:58 UTC 2010
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"!
More information about the Squeak-dev
mailing list
|