[etoys-dev] Etoys Inbox: System-Richo.14.mcz
commits at source.squeak.org
commits at source.squeak.org
Tue May 18 10:19:23 EDT 2010
A new version of System was added to project Etoys Inbox:
http://source.squeak.org/etoysinbox/System-Richo.14.mcz
==================== Summary ====================
Name: System-Richo.14
Author: Richo
Time: 18 May 2010, 11:18:11 am
UUID: 41194def-f628-b449-9345-410709ac8424
Ancestors: System-Richo.12, System-bf.13
* Added TextDomainManager>>#domainForClass:. This method should be removed later, but I can't load the package without it.
=============== Diff against System-Richo.12 ===============
Item was changed:
----- Method: BooleanPreferenceView>>representativeButtonWithColor:inPanel: (in category 'user interface') -----
representativeButtonWithColor: aColor inPanel: aPreferencesPanel
"Return a button that controls the setting of prefSymbol. It will keep up to date even if the preference value is changed in a different place"
| outerButton aButton str miniWrapper |
outerButton := AlignmentMorph newRow height: 24.
outerButton color: (aColor ifNil: [Color r: 0.645 g: 1.0 b: 1.0]).
outerButton hResizing: (aPreferencesPanel ifNil: [#shrinkWrap] ifNotNil: [#spaceFill]).
outerButton vResizing: #shrinkWrap.
outerButton addMorph: (aButton := UpdatingThreePhaseButtonMorph checkBox).
aButton
target: self preference;
actionSelector: #togglePreferenceValue;
getSelector: #preferenceValue.
outerButton addTransparentSpacerOfSize: (2 @ 0).
+ str := StringMorph contents: self preference name font: Preferences standardButtonFont.
- str := StringMorph contents: self preference name font: (StrikeFont familyName: 'NewYork' size: 12).
self preference localToProject ifTrue:
[str emphasis: 1].
miniWrapper := AlignmentMorph newRow hResizing: #shrinkWrap; vResizing: #shrinkWrap.
+ miniWrapper layoutInset: 0.
miniWrapper beTransparent addMorphBack: str lock.
aPreferencesPanel
ifNotNil: "We're in a Preferences panel"
[miniWrapper on: #mouseDown send: #offerPreferenceNameMenu:with:in: to: self withValue: aPreferencesPanel.
miniWrapper on: #mouseEnter send: #menuButtonMouseEnter: to: miniWrapper.
miniWrapper on: #mouseLeave send: #menuButtonMouseLeave: to: miniWrapper.
miniWrapper setBalloonText: 'Click here for a menu of options regarding this preference. Click on the checkbox to the left to toggle the setting of this preference' translated]
ifNil: "We're a naked button, not in a panel"
[miniWrapper setBalloonText: self preference helpString translated; setProperty: #balloonTarget toValue: aButton].
outerButton addMorphBack: miniWrapper.
outerButton setNameTo: self preference name.
aButton setBalloonText: self preference helpString.
^ outerButton
+ !
-
- "(Preferences preferenceAt: #balloonHelpEnabled) view tearOffButton"!
Item was changed:
----- Method: Preferences class>>openNewPreferencesPanel (in category 'preferences panel') -----
openNewPreferencesPanel
"Create and open a new Preferences Panel"
+ | window |
+ window := self preferencesControlPanel.
+ self currentWorld addMorphFront: window.
+ window center: self currentWorld center.
+ window activateAndForceLabelToShow.
- self openFactoredPanelWithWidth: 370
"Preferences openNewPreferencesPanel"!
Item was changed:
----- Method: Preferences class>>initializePreferencePanel:in: (in category 'preferences panel') -----
initializePreferencePanel: aPanel in: aPasteUpMorph
"Initialize the given Preferences panel. in the given pasteup, which is the top-level panel installed in the container window. Also used to reset it after some change requires reformulation"
| tabbedPalette controlPage aColor aFont maxEntriesPerCategory tabsMorph anExtent prefObjects cc |
aPasteUpMorph removeAllMorphs.
+ aFont := Preferences standardListFont.
- aFont := StrikeFont familyName: 'NewYork' size: 19.
-
aColor := aPanel defaultBackgroundColor.
tabbedPalette := TabbedPalette newSticky.
tabbedPalette dropEnabled: false.
(tabsMorph := tabbedPalette tabsMorph) color: aColor darker;
highlightColor: Color red regularColor: Color brown darker darker.
tabbedPalette on: #mouseDown send: #yourself to: #().
maxEntriesPerCategory := 0.
self listOfCategories do:
[:aCat |
controlPage := AlignmentMorph newColumn beSticky color: aColor.
controlPage on: #mouseDown send: #yourself to: #().
controlPage dropEnabled: false.
Preferences alternativeWindowLook ifTrue:
[cc := Color transparent.
controlPage color: cc].
controlPage borderColor: aColor;
layoutInset: 4.
(prefObjects := self preferenceObjectsInCategory: aCat) do:
[:aPreference | | button |
button _ aPreference representativeButtonWithColor: cc inPanel: aPanel.
button ifNotNil: [controlPage addMorphBack: button]].
controlPage setNameTo: aCat asString.
aCat = #?
ifTrue: [aPanel addHelpItemsTo: controlPage].
tabbedPalette addTabFor: controlPage font: aFont.
aCat = 'search results' ifTrue:
[(tabbedPalette tabNamed: aCat) setBalloonText:
'Use the ? category to find preferences by keyword; the results of your search will show up here' translated].
maxEntriesPerCategory := maxEntriesPerCategory max: prefObjects size].
tabbedPalette selectTabNamed: '?'.
tabsMorph rowsNoWiderThan: aPasteUpMorph width.
aPasteUpMorph on: #mouseDown send: #yourself to: #().
+ anExtent := aPasteUpMorph width @ (490 max: (25 + tabsMorph height + (24 * maxEntriesPerCategory))).
- anExtent := aPasteUpMorph width @ (490 max: (25 + tabsMorph height + (20 * maxEntriesPerCategory))).
aPasteUpMorph extent: anExtent.
aPasteUpMorph color: aColor.
aPasteUpMorph addMorphBack: tabbedPalette.!
Item was added:
+ ----- Method: CurrentProjectRefactoring classSide>>currentInterruptName:preemptedProcess: (in category 'revectoring to current') -----
+ currentInterruptName: aString preemptedProcess: theInterruptedProcess
+
+ ^ Project interruptName: aString preemptedProcess: theInterruptedProcess!
Item was changed:
----- Method: Utilities class>>versionNumberAndDateFromConfig: (in category 'fetching updates') -----
versionNumberAndDateFromConfig: anMCConfiguration
"Answer the latest date found in anMCConfiguration (or the associated working copy), and the sum of its version numbers."
| versionNumbers versionDates |
versionNumbers := anMCConfiguration dependencies collect: [:d |
(d versionInfo name copyAfterLast: $.) asInteger].
versionDates := anMCConfiguration dependencies collect: [:d |
d versionInfo date
+ ifNil: [((d package workingCopy ancestry findAncestor: d versionInfo)
+ ifNotNilDo: [:v | v date])
+ ifNil: [Date fromDays: 0]]].
- ifNil: [d package workingCopy ancestors first date
- ifNil: [Date fromDays: 0]]].
^{versionNumbers sum. versionDates max}.
!
Item was added:
+ ----- Method: TextDomainManager classSide>>domainForClass: (in category 'accessing') -----
+ domainForClass: aClass
+ ^'etoys'!
Item was changed:
----- Method: SystemDictionary>>recreateSpecialObjectsArray (in category 'special objects') -----
recreateSpecialObjectsArray
"Smalltalk recreateSpecialObjectsArray"
"The Special Objects Array is an array of object pointers used
by the
Squeak virtual machine. Its contents are critical and
unchecked, so don't even think of playing here unless you
know what you are doing."
| newArray |
newArray := Array new: 50.
"Nil false and true get used throughout the interpreter"
newArray at: 1 put: nil.
newArray at: 2 put: false.
newArray at: 3 put: true.
"This association holds the active process (a ProcessScheduler)"
+ newArray at: 4 put: (self associationAt: #Processor).
+ "Numerous classes below used for type checking and instantiation"
- newArray
- at: 4
- put: (self associationAt: #Processor).
- "Numerous classes below used for type checking and
- instantiation"
newArray at: 5 put: Bitmap.
newArray at: 6 put: SmallInteger.
newArray at: 7 put: ByteString.
newArray at: 8 put: Array.
newArray at: 9 put: Smalltalk.
newArray at: 10 put: Float.
newArray at: 11 put: MethodContext.
newArray at: 12 put: BlockContext.
newArray at: 13 put: Point.
newArray at: 14 put: LargePositiveInteger.
+ newArray at: 15 put: ((Display respondsTo: #actualDisplay)
+ ifTrue: [Display actualDisplay] ifFalse: [Display]).
- newArray at: 15 put: Display.
newArray at: 16 put: Message.
newArray at: 17 put: CompiledMethod.
+ newArray at: 18 put: (self specialObjectsArray at: 18).
- newArray
- at: 18
- put: (self specialObjectsArray at: 18).
"(low space Semaphore)"
newArray at: 19 put: Semaphore.
newArray at: 20 put: Character.
newArray at: 21 put: #doesNotUnderstand:.
newArray at: 22 put: #cannotReturn:.
newArray at: 23 put: nil.
+ "An array of the 32 selectors that are compiled as special bytecodes,
+ paired alternately with the number of arguments each takes."
+ newArray at: 24 put: #( #+ 1 #- 1 #< 1 #> 1 #<= 1 #>= 1 #= 1 #~= 1
+ #* 1 #/ 1 #\\ 1 #@ 1 #bitShift: 1 #// 1 #bitAnd: 1 #bitOr: 1
+ #at: 1 #at:put: 2 #size 0 #next 0 #nextPut: 1 #atEnd 0 #== 1 #class 0
+ #blockCopy: 1 #value 0 #value: 1 #do: 1 #new 0 #new: 1 #x 0 #y 0 ).
- "*unused*"
- "An array of the 32 selectors that are compiled as special
- bytecodes, paired alternately with the number of arguments
- each takes."
- newArray at: 24 put: #(#+ 1 #- 1 #< 1 #> 1 #<= 1 #>= 1 #= 1 #~= 1 #* 1 #/ 1 #\\ 1 #@ 1 #bitShift: 1 #// 1 #bitAnd: 1 #bitOr: 1 #at: 1 #at:put: 2 #size 0 #next 0 #nextPut: 1 #atEnd 0 #== 1 #class 0 #blockCopy: 1 #value 0 #value: 1 #do: 1 #new 0 #new: 1 #x 0 #y 0 ).
"An array of the 255 Characters in ascii order."
+ newArray at: 25 put: ((0 to: 255) collect: [:ascii | Character value: ascii]).
- newArray
- at: 25
- put: ((0 to: 255)
- collect: [:ascii | Character value: ascii]).
newArray at: 26 put: #mustBeBoolean.
newArray at: 27 put: ByteArray.
newArray at: 28 put: Process.
+ "An array of up to 31 classes whose instances will have compact headers"
- "An array of up to 31 classes whose instances will have
- compact headers"
newArray at: 29 put: self compactClassesArray.
+ newArray at: 30 put: (self specialObjectsArray at: 30).
- newArray
- at: 30
- put: (self specialObjectsArray at: 30).
"(delay Semaphore)"
+ newArray at: 31 put: (self specialObjectsArray at: 31).
- newArray
- at: 31
- put: (self specialObjectsArray at: 31).
"(user interrupt Semaphore)"
"Prototype instances that can be copied for fast initialization"
+ newArray at: 32 put: (Float new: 2).
+ newArray at: 33 put: (LargePositiveInteger new: 4).
- newArray
- at: 32
- put: (Float new: 2).
- newArray
- at: 33
- put: (LargePositiveInteger new: 4).
newArray at: 34 put: Point new.
newArray at: 35 put: #cannotInterpret:.
+ "Note: This must be fixed once we start using context prototypes (yeah, right)"
- "Note: This must be fixed once we start using context
- prototypes"
- newArray
- at: 36
- put: (self specialObjectsArray at: 36).
"(MethodContext new: CompiledMethod fullFrameSize)."
+ newArray at: 36 put: (self specialObjectsArray at: 36). "Is the prototype MethodContext (unused by the VM)"
newArray at: 37 put: nil.
- newArray
- at: 38
- put: (self specialObjectsArray at: 38).
"(BlockContext new: CompiledMethod fullFrameSize)."
+ newArray at: 38 put: (self specialObjectsArray at: 38). "Is the prototype BlockContext (unused by the VM)"
+ newArray at: 39 put: (self specialObjectsArray at: 39). "preserve external semaphores"
- newArray at: 39 put: Array new.
"array of objects referred to by external code"
newArray at: 40 put: PseudoContext.
newArray at: 41 put: TranslatedMethod.
"finalization Semaphore"
+ newArray at: 42 put: ((self specialObjectsArray at: 42) ifNil: [Semaphore new]).
- newArray
- at: 42
- put: ((self specialObjectsArray at: 42)
- ifNil: [Semaphore new]).
newArray at: 43 put: LargeNegativeInteger.
"External objects for callout.
+ Note: Written so that one can actually completely remove the FFI."
+ newArray at: 44 put: (self at: #ExternalAddress ifAbsent: []).
+ newArray at: 45 put: (self at: #ExternalStructure ifAbsent: []).
+ newArray at: 46 put: (self at: #ExternalData ifAbsent: []).
+ newArray at: 47 put: (self at: #ExternalFunction ifAbsent: []).
+ newArray at: 48 put: (self at: #ExternalLibrary ifAbsent: []).
- Note: Written so that one can actually completely remove the
- FFI."
- newArray
- at: 44
- put: (self
- at: #ExternalAddress
- ifAbsent: []).
- newArray
- at: 45
- put: (self
- at: #ExternalStructure
- ifAbsent: []).
- newArray
- at: 46
- put: (self
- at: #ExternalData
- ifAbsent: []).
- newArray
- at: 47
- put: (self
- at: #ExternalFunction
- ifAbsent: []).
- newArray
- at: 48
- put: (self
- at: #ExternalLibrary
- ifAbsent: []).
newArray at: 49 put: #aboutToReturn:through:.
newArray at: 50 put: #run:with:in:.
+ "Now replace the interpreter's reference in one atomic operation"
- "Now replace the interpreter's reference in one atomic
- operation"
self specialObjectsArray become: newArray!
Item was changed:
----- Method: Project class>>interruptName: (in category 'utilities') -----
interruptName: labelString
"Create a Notifier on the active scheduling process with the given label."
- | preemptedProcess projectProcess suspendingList |
- Smalltalk isMorphic ifFalse:
- [^ ScheduledControllers interruptName: labelString].
- ActiveHand ifNotNil:[ActiveHand interrupted].
- ActiveWorld _ World. "reinstall active globals"
- ActiveHand _ World primaryHand.
- ActiveHand interrupted. "make sure this one's interrupted too"
- ActiveEvent _ nil.
+ ^ self interruptName: labelString preemptedProcess: nil
- projectProcess _ self uiProcess. "we still need the accessor for a while"
- preemptedProcess _ Processor preemptedProcess.
- "Only debug preempted process if its priority is >= projectProcess' priority"
- preemptedProcess priority < projectProcess priority ifTrue:[
- (suspendingList _ projectProcess suspendingList) == nil
- ifTrue: [projectProcess == Processor activeProcess
- ifTrue: [projectProcess suspend]]
- ifFalse: [suspendingList remove: projectProcess ifAbsent: [].
- projectProcess offList].
- preemptedProcess _ projectProcess.
- ] ifFalse:[
- preemptedProcess _ projectProcess suspend offList.
- ].
- Debugger openInterrupt: labelString onProcess: preemptedProcess
!
Item was changed:
----- Method: Preferences class>>preferencesControlPanel (in category 'preferences panel') -----
preferencesControlPanel
"Answer a Preferences control panel window"
"Preferences preferencesControlPanel openInHand"
| window playfield aPanel |
aPanel _ PreferencesPanel new.
+ playfield _ PasteUpMorph new width: 450.
- playfield _ PasteUpMorph new width: 325.
playfield dropEnabled: false.
window _ (SystemWindow labelled: 'Preferences' translated) model: aPanel.
self initializePreferencePanel: aPanel in: playfield.
window on: #keyStroke send: #keyStroke: to: aPanel.
window bounds: (100 @ 100 - (0 @ window labelHeight + window borderWidth) extent: playfield extent + (2 * window borderWidth)).
window addMorph: playfield frame: (0 @ 0 extent: 1 @ 1).
window updatePaneColors.
window setProperty: #minimumExtent toValue: playfield extent + (12 at 15).
^ window!
Item was changed:
----- Method: SystemDictionary>>lowSpaceWatcher (in category 'memory space') -----
lowSpaceWatcher
+ "Wait until the low space semaphore is signalled, then take appropriate actions."
+
+ | free preemptedProcess |
- "Wait until the low space semaphore is signalled, then take
- appropriate actions."
- | free |
self garbageCollectMost <= self lowSpaceThreshold
ifTrue: [self garbageCollect <= self lowSpaceThreshold
ifTrue: ["free space must be above threshold before
starting low space watcher"
^ Beeper beep]].
+
+ Smalltalk specialObjectsArray at: 23 put: nil. "process causing low space will be saved here"
LowSpaceSemaphore := Semaphore new.
self primLowSpaceSemaphore: LowSpaceSemaphore.
+ self primSignalAtBytesLeft: self lowSpaceThreshold. "enable low space interrupts"
+
+ LowSpaceSemaphore wait. "wait for a low space condition..."
+
+ self primSignalAtBytesLeft: 0. "disable low space interrupts"
- self primSignalAtBytesLeft: self lowSpaceThreshold.
- "enable low space interrupts"
- LowSpaceSemaphore wait.
- "wait for a low space condition..."
- self primSignalAtBytesLeft: 0.
- "disable low space interrupts"
self primLowSpaceSemaphore: nil.
LowSpaceProcess := nil.
+
+ "The process that was active at the time of the low space interrupt."
+ preemptedProcess := Smalltalk specialObjectsArray at: 23.
+ Smalltalk specialObjectsArray at: 23 put: nil.
+
+ "Note: user now unprotected until the low space watcher is re-installed"
+
- "Note: user now unprotected until the low space watcher is
- re-installed "
self memoryHogs isEmpty
ifFalse: [free := self bytesLeft.
self memoryHogs
+ do: [ :hog | hog freeSomeSpace ].
- do: [:hog | hog freeSomeSpace].
self bytesLeft > free
+ ifTrue: [ ^ self installLowSpaceWatcher ]].
- ifTrue: [^ self installLowSpaceWatcher]].
self isMorphic
+ ifTrue: [CurrentProjectRefactoring
+ currentInterruptName: 'Space is low'
+ preemptedProcess: preemptedProcess]
+ ifFalse: [ScheduledControllers
+ interruptName: 'Space is low'
+ preemptedProcess: preemptedProcess]
+ !
- ifTrue: [CurrentProjectRefactoring currentInterruptName: 'Space is low']
- ifFalse: [ScheduledControllers interruptName: 'Space is low']!
Item was added:
+ ----- Method: Utilities class>>defaultRepositoryChangeLogOn: (in category 'fetching updates') -----
+ defaultRepositoryChangeLogOn: aStream
+ "Transcript clear. Utilities defaultRepositoryChangeLogOn: Transcript"
+ | repo updates latest previous latestVersion previousVersion added removed latestPackages previousPackages prevDep prevInfo latestInfo |
+ repo := MCRepositoryGroup default repositories detect: [:r |
+ r description = MCMcmUpdater defaultUpdateURL].
+ updates := repo allFileNames select: [:each | 'update-*.mcm' match: each].
+ updates := updates asSortedCollection:
+ [:a :b | a splitInteger second > b splitInteger second].
+ latest := repo versionFromFileNamed: updates first.
+ previous := repo versionFromFileNamed: updates second.
+ latestVersion := self versionNumberAndDateFromConfig: latest.
+ previousVersion := self versionNumberAndDateFromConfig: previous.
+ aStream nextPutAll: 'Changes from v'; print: previousVersion first;
+ nextPutAll: ' of '; print: previousVersion second;
+ nextPutAll: ' to v'; print: latestVersion first;
+ nextPutAll: ' of '; print: latestVersion second;
+ nextPutAll: ':'; cr.
+ aStream flush.
+ latestPackages := latest dependencies collect: [:dep | dep package].
+ previousPackages := previous dependencies collect: [:dep | dep package].
+ added := latestPackages difference: previousPackages.
+ removed := previousPackages difference: latestPackages.
+ added ifNotEmpty: [
+ aStream nextPutAll: 'Added packages:'.
+ added do: [:each | aStream space; nextPutAll: each name].
+ aStream cr].
+ removed ifNotEmpty: [
+ aStream nextPutAll: 'Removed packages:'.
+ removed do: [:each | aStream space; nextPutAll: each name].
+ aStream cr].
+ latest dependencies do: [:latestDep |
+ prevDep := previous dependencies detect: [:p | latestDep package = p package] ifNone: [].
+ (prevDep notNil and: [prevDep versionInfo ~= latestDep versionInfo])
+ ifTrue: [
+ aStream nextPutAll: '--------------------'; cr.
+ prevInfo := prevDep package workingCopy ancestry findAncestor: prevDep versionInfo.
+ latestInfo := latestDep package workingCopy ancestry findAncestor: latestDep versionInfo.
+ (latestInfo allAncestorsOnPathTo: prevInfo) reverse, {latestInfo}
+ do: [:ver | aStream nextPutAll: ver name; cr; nextPutAll: ver message; cr]
+ separatedBy: [aStream cr]]].
+ aStream flush
+ !
Item was added:
+ ----- Method: Project class>>interruptName:preemptedProcess: (in category 'utilities') -----
+ interruptName: labelString preemptedProcess: theInterruptedProcess
+ "Create a Notifier on the active scheduling process with the given label."
+ | preemptedProcess projectProcess |
+ Smalltalk isMorphic ifFalse:
+ [^ ScheduledControllers interruptName: labelString].
+ ActiveHand ifNotNil:[ActiveHand interrupted].
+ ActiveWorld := World. "reinstall active globals"
+ ActiveHand := World primaryHand.
+ ActiveHand interrupted. "make sure this one's interrupted too"
+ ActiveEvent := nil.
+
+ projectProcess := self uiProcess. "we still need the accessor for a while"
+ preemptedProcess := theInterruptedProcess ifNil: [Processor preemptedProcess].
+ "Only debug preempted process if its priority is >= projectProcess' priority"
+ preemptedProcess priority < projectProcess priority
+ ifTrue:[preemptedProcess := projectProcess].
+ preemptedProcess suspend.
+ Debugger openInterrupt: labelString onProcess: preemptedProcess
+ !
Item was removed:
- ----- Method: Preferences class>>openFactoredPanelWithWidth: (in category 'preferences panel') -----
- openFactoredPanelWithWidth: aWidth
- "Open up a preferences panel of the given width"
-
- "Preferences openFactoredPanelWithWidth: 325"
- | window playfield aPanel |
-
- aPanel _ PreferencesPanel new.
- playfield _ PasteUpMorph new width: aWidth.
- playfield dropEnabled: false.
- self initializePreferencePanel: aPanel in: playfield.
- self couldOpenInMorphic
- ifTrue: [window _ (SystemWindow labelled: 'Preferences' translated)
- model: aPanel.
- window on: #keyStroke send: #keyStroke: to: aPanel.
- window
- bounds: (100 @ 100 - (0 @ window labelHeight + window borderWidth) extent: playfield extent + (2 * window borderWidth)).
- window
- addMorph: playfield
- frame: (0 @ 0 extent: 1 @ 1).
- window updatePaneColors.
- window setProperty: #minimumExtent toValue: playfield extent + (12 at 15).
- self currentWorld addMorphFront: window.
- window center: self currentWorld center.
- window activateAndForceLabelToShow]
- ifFalse:
- [(window _ MVCWiWPasteUpMorph newWorldForProject: nil) addMorph: playfield.
- MorphWorldView
- openOn: window
- label: 'Preferences' translated
- extent: playfield extent]!
More information about the etoys-dev
mailing list