The Trunk: Kernel-ar.368.mcz

Andreas Raab uploaded a new version of Kernel to project The Trunk:
http://source.squeak.org/trunk/Kernel-ar.368.mcz

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

Name: Kernel-ar.368
Author: ar
Time: 4 January 2010, 12:39:10 pm
UUID: ecc189b7-7be8-e343-ba67-3eb7c3278c95
Ancestors: Kernel-nice.365

Make Etoys unloadable: Move lots of methods to Etoys package. Remove installTilesAsSelection support.

=============== Diff against Kernel-nice.365 ===============

Item was added:
+ ----- Method: Object>>isPlayer (in category 'testing') -----
+ isPlayer
+ ^false!

Item was changed:
  SystemOrganization addCategory: #'Kernel-Chronology'!
  SystemOrganization addCategory: #'Kernel-Classes'!
  SystemOrganization addCategory: #'Kernel-Methods'!
  SystemOrganization addCategory: #'Kernel-Numbers'!
  SystemOrganization addCategory: #'Kernel-Objects'!
  SystemOrganization addCategory: #'Kernel-Processes'!
  SystemOrganization addCategory: #'Kernel-Models'!
- SystemOrganization addCategory: #'Kernel-Tests-ClassBuilder'!

Item was changed:
  ----- Method: StringHolder class>>shiftedYellowButtonMenuItems (in category 'yellow button menu') -----
  shiftedYellowButtonMenuItems
  "Returns the standard yellow button menu items"
  ^{
  {'explain' translated. #explain}.
  {'pretty print' translated. #prettyPrint}.
  {'pretty print with color' translated. #prettyPrintWithColor}.
  {'file it in (G)' translated. #fileItIn}.
- {'tiles from it' translated. #selectionAsTiles}.
  {'spawn (o)' translated. #spawn}.
  #-.
  {'browse it (b)' translated. #browseIt}.
  {'senders of it (n)' translated. #sendersOfIt}.
  {'implementors of it (m)' translated. #implementorsOfIt}.
  {'references to it (N)' translated. #referencesToIt}.
  #-.
  {'selectors containing it (W)' translated. #methodNamesContainingIt}.
  {'method strings with it (E)' translated. #methodStringsContainingit}.
  {'method source with it' translated. #methodSourceContainingIt}.
  {'class names containing it' translated. #classNamesContainingIt}.
  {'class comments with it' translated. #classCommentsContainingIt}.
  {'change sets with it' translated. #browseChangeSetsWithSelector}.
  #-.
  {'save contents to file...' translated. #saveContentsInFile}.
  {'send contents to printer' translated. #sendContentsToPrinter}.
  {'printer setup' translated. #printerSetup}.
  #-.
  {'special menu...' translated. #presentSpecialMenu}.
  {'more...' translated. #yellowButtonActivity}.
  }!

Item was removed:
- ----- Method: Object>>updateThresholdForGraphicInViewerTab (in category 'viewer') -----
- updateThresholdForGraphicInViewerTab
- "When a Viewer is open on the receiver, its tab needs some graphic to show to the user. Computing this graphic can take quite some time so we want to make the update frequency depending on how long it takes to compute the thumbnail. The threshold returned by this method defines that the viewer will update at most every 'threshold * timeItTakesToDraw' milliseconds. Thus, if the time for computing the receiver's thumbnail is 200 msecs and the the threshold is 10, the viewer will update at most every two seconds."
- ^20 "seems to be a pretty good general choice"!

Item was removed:
- ----- Method: Object>>assureUniClass (in category 'viewer') -----
- assureUniClass
- "If the receiver is not yet an instance of a uniclass, create a uniclass for it and make the receiver become an instance of that class."
-
- | anInstance |
- self belongsToUniClass ifTrue: [^ self].
- anInstance := self class instanceOfUniqueClass.
- self become: (self as: anInstance class).
- ^ anInstance!

Item was removed:
- ----- Method: Object>>tilePhrasesForMethodInterfaces:inViewer: (in category 'viewer') -----
- tilePhrasesForMethodInterfaces: methodInterfaceList inViewer: aViewer
- "Return a collection of ViewerLine objects corresponding to the method-interface list provided.   The resulting list will be in the same order as the incoming list, but may be smaller if the viewer's vocbulary suppresses some of the methods, or if, in classic tiles mode, the selector requires more arguments than can be handled."
-
- | toSuppress interfaces |
- toSuppress := aViewer currentVocabulary phraseSymbolsToSuppress.
- interfaces := methodInterfaceList reject: [:int | toSuppress includes: int selector].
- Preferences universalTiles ifFalse:  "Classic tiles have their limitations..."
- [interfaces := interfaces select:
- [:int |
- | itsSelector |
- itsSelector := int selector.
- itsSelector numArgs < 2 or:
- "The lone two-arg loophole in classic tiles"
- [#(color:sees:) includes: itsSelector]]].
-
- ^ interfaces collect:
- [:aMethodInterface |
- | resultType |
- ((resultType := aMethodInterface resultType) notNil and: [resultType ~~ #unknown])
- ifTrue:
- [aViewer phraseForVariableFrom: aMethodInterface]
- ifFalse:
- [aViewer phraseForCommandFrom: aMethodInterface]]!

Item was removed:
- ----- Method: Object>>universalTilesForGetterOf: (in category 'scripts-kernel') -----
- universalTilesForGetterOf: aMethodInterface
- "Return universal tiles for a getter on the given method interface."
-
- | ms argTile argArray itsSelector |
- itsSelector := aMethodInterface selector.
- argArray := #().
-
- "Four gratuituous special cases..."
-
- (itsSelector == #color:sees:) ifTrue:
- [argTile := ScriptingSystem tileForArgType: #Color.
- argArray := Array with: argTile colorSwatch color with: argTile colorSwatch color copy].
-
- itsSelector == #seesColor: ifTrue:
- [argTile := ScriptingSystem tileForArgType: #Color.
- argArray :=  Array with: argTile colorSwatch color].
-
- (#(touchesA: overlaps: overlapsAny:) includes: itsSelector) ifTrue:
- [argTile := ScriptingSystem tileForArgType: #Player.
- argArray := Array with: argTile actualObject].
-
- ms := MessageSend receiver: self selector: itsSelector arguments: argArray.
- ^ ms asTilesIn: self class globalNames: (self class officialClass ~~ CardPlayer)
- "For CardPlayers, use 'self'.  For others, name it, and use its name."!

Item was removed:
- ----- Method: Object>>offerViewerMenuFor:event: (in category 'viewer') -----
- offerViewerMenuFor: aViewer event: evt
- "Offer the primary Viewer menu to the user.  Copied up from Player code, but most of the functions suggested here don't work for non-Player objects, many aren't even defined, some relate to exploratory sw work not yet reflected in the current corpus.  We are early in the life cycle of this method..."
-
- | aMenu |
- aMenu := MenuMorph new defaultTarget: self.
- aMenu addStayUpItem.
- aMenu title: '**CAUTION -- UNDER CONSTRUCTION!!**
- Many things may not work!!
- ', self nameForViewer.
- (aViewer affordsUniclass and: [self belongsToUniClass not]) ifTrue:
- [aMenu add: 'give me a Uniclass' action: #assureUniClass.
- aMenu addLine].
- aMenu add: 'choose vocabulary...' target: aViewer action: #chooseVocabulary.
- aMenu add: 'choose limit class...' target: aViewer action: #chooseLimitClass.
- aMenu add: 'add search pane' target: aViewer action: #addSearchPane.
- aMenu balloonTextForLastItem: 'Specify which class should be the most generic one to have its methods shown in this Viewer'.
- aMenu addLine.
-
- self belongsToUniClass ifTrue:
- [aMenu add: 'add a new instance variable' target: self selector: #addInstanceVariableIn: argument: aViewer.
- aMenu add: 'add a new script' target: aViewer selector: #newPermanentScriptIn: argument: aViewer.
- aMenu addLine.
- aMenu add: 'make my class be first-class' target: self selector: #makeFirstClassClassIn: argument: aViewer.
- aMenu add: 'move my changes up to my superclass' target: self action: #promoteChangesToSuperclass.
- aMenu addLine].
-
- aMenu add: 'tear off a tile' target: self selector: #launchTileToRefer.
- aMenu addLine.
-
- aMenu add: 'inspect me' target: self selector: #inspect.
- aMenu add: 'inspect my class' target: self class action: #inspect.
- aMenu addLine.
-
- aMenu add: 'browse vocabulary' action: #haveFullProtocolBrowsed.
- aMenu add: 'inspect this Viewer' target: aViewer action: #inspect.
-
- aMenu popUpEvent: evt in: aViewer currentWorld
-
- "
- aMenu add: 'references to me' target: aViewer action: #browseReferencesToObject.
- aMenu add: 'toggle scratch pane' target: aViewer selector: #toggleScratchPane.
- aMenu add: 'make a nascent script for me' target: aViewer selector: #makeNascentScript.
- aMenu add: 'rename me' target: aViewer selector: #chooseNewNameForReference.
- aMenu add: 'browse full' action: #browseOwnClassFull.
- aMenu add: 'browse hierarchy' action: #browseOwnClassHierarchy.
- aMenu add: 'set user level...' target: aViewer action: #setUserLevel.
- aMenu add: 'browse sub-protocol' action: #browseOwnClassSubProtocol.
- aMenu addLine.
-
- "!

Item was removed:
- ----- Method: Object>>tileToRefer (in category 'viewer') -----
- tileToRefer
- "Answer a reference tile that comprises an alias to me"
-
- ^ TileMorph new setToReferTo: self!

Item was removed:
- ----- Method: Object>>universalTilesForInterface: (in category 'scripts-kernel') -----
- universalTilesForInterface: aMethodInterface
- "Return universal tiles for the given method interface.  Record who self is."
-
- | ms itsSelector argList |
- itsSelector := aMethodInterface selector.
- argList := OrderedCollection new.
- aMethodInterface argumentVariables doWithIndex:
- [:anArgumentVariable :anIndex |
- | argTile aType |
- argTile := ScriptingSystem tileForArgType: (aType := aMethodInterface typeForArgumentNumber: anIndex).
- argList add: (aType == #Player
- ifTrue: [argTile actualObject]
- ifFalse: [argTile literal]). "default value for each type"].
-
- ms := MessageSend receiver: self selector: itsSelector arguments: argList asArray.
- ^ ms asTilesIn: self class globalNames: (self class officialClass ~~ CardPlayer)
- "For CardPlayers, use 'self'.  For others, name it, and use its name."!

Item was removed:
- ----- Method: Object>>defaultLimitClassForVocabulary: (in category 'viewer') -----
- defaultLimitClassForVocabulary: aVocabulary
- "Answer the class to use, by default, as the limit class on a protocol browser or viewer opened up on the receiver, within the purview of the Vocabulary provided"
-
- ^ (aVocabulary isKindOf: FullVocabulary)
- ifTrue:
- [self class superclass == Object
- ifTrue:
- [self class]
- ifFalse:
- [self class superclass]]
- ifFalse:
- [ProtoObject]!

Item was removed:
- ----- Method: Object>>elementTypeFor:vocabulary: (in category 'viewer') -----
- elementTypeFor: aStringOrSymbol vocabulary: aVocabulary
- "Answer a symbol characterizing what kind of element aStringOrSymbol represents.  Realistically, at present, this always just returns #systemScript; a prototyped but not-incorporated architecture supported use of a leading colon to characterize an inst var of a system class, and for the moment we still see its remnant here."
-
- self flag: #deferred.  "a loose end in the non-player case"
- ^ #systemScript!

Item was removed:
- ----- Method: Object>>tilePhrasesForCategory:inViewer: (in category 'viewer') -----
- tilePhrasesForCategory: aCategorySymbol inViewer: aViewer
- "Return a collection of phrases for the category."
-
- | interfaces |
- interfaces := self methodInterfacesForCategory: aCategorySymbol inVocabulary: aViewer currentVocabulary limitClass: aViewer limitClass.
- interfaces := self methodInterfacesInPresentationOrderFrom: interfaces forCategory: aCategorySymbol.
- ^ self tilePhrasesForMethodInterfaces: interfaces inViewer: aViewer!

Item was removed:
- ----- Method: Object>>hasUserDefinedSlots (in category 'viewer') -----
- hasUserDefinedSlots
- "Answer whether the receiver has any user-defined slots, in the omniuser sense of the term.  This is needed to allow Viewers to look at any object, not just at Players."
-
- ^ false!

Item was removed:
- ----- Method: Object>>offerViewerMenuForEvt:morph: (in category 'viewer') -----
- offerViewerMenuForEvt: anEvent morph: aMorph
- "Offer the viewer's primary menu to the user.  aMorph is some morph within the viewer itself, the one within which a mousedown triggered the need for this menu, and it is used only to retrieve the Viewer itself"
-
- self offerViewerMenuFor: (aMorph ownerThatIsA: StandardViewer) event: anEvent!

Item was removed:
- ----- Method: Object>>uniqueNameForReferenceOrNil (in category 'viewer') -----
- uniqueNameForReferenceOrNil
- "If the receiver has a unique name for reference, return it here, else return nil"
-
- ^ References keyAtValue: self ifAbsent: [nil]!

Item was removed:
- ----- Method: Object>>newScriptorAround: (in category 'viewer') -----
- newScriptorAround: aPhraseTileMorph
- "Sprout a scriptor around aPhraseTileMorph, thus making a new script.  This is where generalized scriptors will be threaded in"
-
- ^ nil!

Item was removed:
- ----- Method: Object>>graphicForViewerTab (in category 'viewer') -----
- graphicForViewerTab
- "When a Viewer is open on the receiver, its tab needs some graphic to show to the user.  Answer a form or a morph to serve that purpose.  A generic image is used for arbitrary objects, but note my reimplementors"
-
- ^ ScriptingSystem formAtKey: 'Image'!

Item was removed:
- ----- Method: Object>>browseOwnClassSubProtocol (in category 'viewer') -----
- browseOwnClassSubProtocol
- "Open up a ProtocolBrowser on the subprotocol of the receiver"
-
- ProtocolBrowser openSubProtocolForClass: self class
- !

Item was removed:
- ----- Method: Object>>externalName (in category 'viewer') -----
- externalName
- "Answer an external name by which the receiver is known.  Generic implementation here is a transitional backstop. probably"
-
- ^ self nameForViewer!

Item was removed:
- ----- Method: Object>>initialTypeForSlotNamed: (in category 'viewer') -----
- initialTypeForSlotNamed: aName
- "Answer the initial type to be ascribed to the given instance variable"
-
- ^ #Object!

Item was removed:
- ----- Method: Object>>renameScript: (in category 'viewer') -----
- renameScript: oldSelector
- "prompt the user for a new selector and apply it.  Presently only works for players"
-
- self notYetImplemented!

Item was removed:
- ----- Method: Object>>categoriesForVocabulary:limitClass: (in category 'viewer') -----
- categoriesForVocabulary: aVocabulary limitClass: aLimitClass
- "Answer a list of categories of methods for the receiver when using the given vocabulary, given that one considers only methods that are implemented not further away than aLimitClass"
-
- ^ aVocabulary categoryListForInstance: self ofClass: self class limitClass: aLimitClass!

Item was removed:
- ----- Method: Object>>methodInterfacesInPresentationOrderFrom:forCategory: (in category 'viewer') -----
- methodInterfacesInPresentationOrderFrom: interfaceList forCategory: aCategory
- "Answer the interface list sorted in desired presentation order, using a
- static master-ordering list, q.v. The category parameter allows an
- escape in case one wants to apply different order strategies in different
- categories, but for now a single master-priority-ordering is used -- see
- the comment in method EToyVocabulary.masterOrderingOfPhraseSymbols"
-
- | masterOrder ordered unordered |
- masterOrder := Vocabulary eToyVocabulary masterOrderingOfPhraseSymbols.
- ordered := SortedCollection sortBlock: [:a :b | a key < b key].
- unordered := SortedCollection sortBlock: [:a :b | a wording < b wording].
-
- interfaceList do: [:interface |
- | index |
- index := masterOrder indexOf: interface elementSymbol.
- index isZero
- ifTrue: [unordered add: interface]
- ifFalse: [ordered add: index -> interface]].
-
- ^ Array
- streamContents: [:stream |
- ordered do: [:assoc | stream nextPut: assoc value].
- stream nextPutAll: unordered]!

Item was removed:
- ----- Method: Object>>uniqueNameForReferenceFrom: (in category 'viewer') -----
- uniqueNameForReferenceFrom: proposedName
- "Answer a satisfactory symbol, similar to the proposedName but obeying the rules, to represent the receiver"
-
- | aName stem |
- proposedName = self uniqueNameForReferenceOrNil
- ifTrue: [^ proposedName].  "No change"
-
- stem := proposedName select: [:ch | ch isLetter or: [ch isDigit]].
- stem size == 0 ifTrue: [stem := 'A'].
- stem first isLetter ifFalse:
- [stem := 'A', stem].
- stem := stem capitalized.
- aName := Utilities keyLike: stem satisfying:
- [:jinaLake |
- | nameSym okay |
- nameSym := jinaLake asSymbol.
- okay := true.
- (self class bindingOf: nameSym) ifNotNil: [okay := false "don't use it"].
- okay].
- ^ aName asSymbol!

Item was removed:
- ----- Method: Object>>uniqueInstanceVariableNameLike:excluding: (in category 'viewer') -----
- uniqueInstanceVariableNameLike: aString excluding: takenNames
- "Answer a nice instance-variable name to be added to the receiver which resembles aString, making sure it does not coincide with any element in takenNames"
-
- | okBase uniqueName usedNames |
- usedNames := self class allInstVarNamesEverywhere.
- usedNames removeAllFoundIn: self class instVarNames.
- usedNames addAll: takenNames.
- okBase := Scanner wellFormedInstanceVariableNameFrom: aString.
-
- uniqueName := Utilities keyLike: okBase satisfying:
- [:aKey | (usedNames includes: aKey) not].
-
- ^ uniqueName!

Item was removed:
- ----- Method: Object>>usableMethodInterfacesIn: (in category 'viewer') -----
- usableMethodInterfacesIn: aListOfMethodInterfaces
- "Filter aList, returning a subset list of apt phrases"
-
- ^ aListOfMethodInterfaces
- !

Item was removed:
- ----- Method: Object>>uniqueNameForReference (in category 'viewer') -----
- uniqueNameForReference
- "Answer a nice name by which the receiver can be referred to by other objects.  At present this uses a global References dictionary to hold the database of references, but in due course this will need to acquire some locality"
-
- | aName stem knownClassVars |
- (aName := self uniqueNameForReferenceOrNil) ifNotNil: [^ aName].
- (stem := self knownName) ifNil:
- [stem := self defaultNameStemForInstances asString].
- stem := stem select: [:ch | ch isLetter or: [ch isDigit]].
- stem size == 0 ifTrue: [stem := 'A'].
- stem first isLetter ifFalse:
- [stem := 'A', stem].
- stem := stem capitalized.
- knownClassVars := ScriptingSystem allKnownClassVariableNames.
- aName := Utilities keyLike:  stem satisfying:
- [:jinaLake |
- | nameSym |
- nameSym := jinaLake asSymbol.
- ((References includesKey:  nameSym) not and:
- [(Smalltalk includesKey: nameSym) not]) and:
- [(knownClassVars includes: nameSym) not]].
-
- References at: (aName := aName asSymbol) put: self.
- ^ aName!

Item was removed:
- ----- Method: Object>>defaultNameStemForInstances (in category 'viewer') -----
- defaultNameStemForInstances
- "Answer a basis for names of default instances of the receiver.  The default is to let the class specify, but certain instances will want to override.  (PasteUpMorphs serving as Worlds come to mind"
-
- ^ self class defaultNameStemForInstances!

Item was removed:
- ----- Method: Object>>infoFor:inViewer: (in category 'viewer') -----
- infoFor: anElement inViewer: aViewer
- "The user made a gesture asking for info/menu relating to me.  Some of the messages dispatched here are not yet available in this image"
-
- | aMenu elementType |
- elementType := self elementTypeFor: anElement vocabulary: aViewer currentVocabulary.
- ((elementType = #systemSlot) | (elementType == #userSlot))
- ifTrue: [^ self slotInfoButtonHitFor: anElement inViewer: aViewer].
- self flag: #deferred.  "Use a traditional MenuMorph, and reinstate the pacify thing"
- aMenu := MenuMorph new defaultTarget: aViewer.
- #( ('implementors' browseImplementorsOf:)
- ('senders' browseSendersOf:)
- ('versions' browseVersionsOf:)
- -
- ('browse full' browseMethodFull:)
- ('inheritance' browseMethodInheritance:)
- -
- ('about this method' aboutMethod:)) do:
-
- [:pair |
- pair = '-'
- ifTrue:
- [aMenu addLine]
- ifFalse:
- [aMenu add: pair first target: aViewer selector: pair second argument: anElement]].
- aMenu addLine.
- aMenu defaultTarget: self.
- #( ('destroy script' removeScript:)
- ('rename script' renameScript:)
- ('pacify script' pacifyScript:)) do:
- [:pair |
- aMenu add: pair first target: self selector: pair second argument: anElement].
-
- aMenu addLine.
- aMenu  add: 'show categories....' target: aViewer selector: #showCategoriesFor: argument: anElement.
- aMenu items size == 0 ifTrue:  "won't happen at the moment a/c the above"
- [aMenu add: 'ok' action: nil].  "in case it was a slot -- weird, transitional"
-
- aMenu addTitle: anElement asString, ' (', elementType, ')'.
-
- aMenu popUpInWorld: self currentWorld.
-  !

Item was removed:
- ----- Method: Object>>isPlayerLike (in category 'viewer') -----
- isPlayerLike
- "Return true if the receiver is a player-like object"
- ^false!

Item was removed:
- ----- Method: Object>>categoriesForViewer: (in category 'viewer') -----
- categoriesForViewer: aViewer
- "Answer a list of categories to offer in the given viewer"
-
- ^ aViewer currentVocabulary categoryListForInstance: self ofClass: self class limitClass: aViewer limitClass!

Item was removed:
- ----- Method: Object>>belongsToUniClass (in category 'viewer') -----
- belongsToUniClass
- "Answer whether the receiver belongs to a uniclass.  For the moment (this is not entirely satisfactory) this is precisely equated with the classname ending in a digit"
-
- ^ self class name endsWithDigit!

Item was removed:
- ----- Method: Object>>openInstanceBrowserWithTiles (in category 'testing') -----
- openInstanceBrowserWithTiles
- "Open up an instance browser on me with tiles as the code type, and with the search level as desired."
-
- | aBrowser |
- aBrowser := InstanceBrowser new.
- aBrowser useVocabulary: Vocabulary fullVocabulary.
- aBrowser limitClass: self class.
- aBrowser contentsSymbol: #tiles. "preset it to make extra buttons (tile menus)"
- aBrowser openOnObject: self inWorld: ActiveWorld showingSelector: nil.
- aBrowser contentsSymbol: #source.
- aBrowser toggleShowingTiles.
-
- "
- (2@3) openInstanceBrowserWithTiles.
- WatchMorph new openInstanceBrowserWithTiles
- "!

Item was removed:
- ----- Method: Object>>tilePhrasesForSelectorList:inViewer: (in category 'viewer') -----
- tilePhrasesForSelectorList: aList inViewer: aViewer
- "Particular to the search facility in viewers.  Answer a list, in appropriate order, of ViewerLine objects to put into the viewer."
-
- | interfaces aVocab |
- aVocab := aViewer currentVocabulary.
- interfaces := self
- methodInterfacesInPresentationOrderFrom:
- (aList collect: [:aSel | aVocab methodInterfaceForSelector: aSel class: self class])
- forCategory: #search.
- ^ self tilePhrasesForMethodInterfaces: interfaces inViewer: aViewer!

Item was removed:
- ----- Method: Object>>chooseNewNameForReference (in category 'viewer') -----
- chooseNewNameForReference
- "Offer an opportunity for the receiver, presumed already to be known in the References registry, to be renamed"
-
- |  nameSym current newName |
- current := References keyAtValue: self ifAbsent: [^ self error: 'not found in References'].
-
- newName := UIManager default request: 'Please enter new name' initialAnswer: current.
- "Want to user some better way of determining the validity of the chosen identifier, and also want to give more precise diagnostic if the string the user types in is not acceptable.  Work to be done here."
-
- newName isEmpty ifTrue: [^ nil].
- ((Scanner isLiteralSymbol: newName) and: [(newName includes: $:) not])
- ifTrue:
- [nameSym := newName capitalized asSymbol.
- (((References includesKey:  nameSym) not and:
- [(Smalltalk includesKey: nameSym) not]) and:
- [(ScriptingSystem allKnownClassVariableNames includes: nameSym) not])
- ifTrue:
- [(References associationAt: current) key: nameSym.
- References rehash.
- ^ nameSym]].
- self inform: 'Sorry, that name is not available.'.
- ^ nil!