[squeak-dev] The Trunk: Kernel-nice.346.mczcommits at source.squeak.org commits at source.squeak.orgSun Dec 27 04:11:16 UTC 2009
Nicolas Cellier uploaded a new version of Kernel to project The Trunk: http://source.squeak.org/trunk/Kernel-nice.346.mcz ==================== Summary ==================== Name: Kernel-nice.346 Author: nice Time: 27 December 2009, 5:10:43 am UUID: b6d92933-9056-4bb8-a54d-ffd1bbcc74b6 Ancestors: Kernel-nice.345 Cosmetic: move or remove a few temps inside closures =============== Diff against Kernel-nice.345 =============== Item was changed: ----- Method: CompiledMethod>>hasReportableSlip (in category 'testing') ----- hasReportableSlip "Answer whether the receiver contains anything that should be brought to the attention of the author when filing out. Customize the lists here to suit your preferences. If slips do not get reported in spite of your best efforts here, make certain that the Preference 'checkForSlips' is set to true." - | assoc | #(#doOnlyOnce: #halt #halt: #hottest #printDirectlyToDisplay #toRemove #personal #urgent #haltOnce #haltOnce: #haltIf: ) do: [:aLit | (self hasLiteral: aLit) ifTrue: [^ true]]. #(#Transcript #AA #BB #CC #DD #EE ) + do: [:aSymbol | + | assoc | + (assoc := Smalltalk - do: [:aSymbol | (assoc := Smalltalk associationAt: aSymbol ifAbsent: []) ifNotNil: [(self hasLiteral: assoc) ifTrue: [^ true]]]. ^ false! Item was changed: ----- Method: DateAndTime>>= (in category 'ansi protocol') ----- = comparand "comparand conforms to protocol DateAndTime, or can be converted into something that conforms." | comparandAsDateAndTime | self == comparand ifTrue: [^ true]. + comparandAsDateAndTime := [comparand asDateAndTime] - [comparandAsDateAndTime := comparand asDateAndTime] on: MessageNotUnderstood do: [^ false]. ^ self offset = comparandAsDateAndTime offset ifTrue: [self hasEqualTicks: comparandAsDateAndTime ] ifFalse: [self asUTC ticks = comparandAsDateAndTime asUTC ticks] ! Item was changed: ----- Method: Object>>closeTo: (in category 'comparing') ----- closeTo: anObject "Answer whether the receiver and the argument represent the same object. If = is redefined in any subclass, consider also redefining the message hash." + ^[self = anObject] ifError: [false]! - | ans | - [ans := self = anObject] ifError: [:aString :aReceiver | ^ false]. - ^ ans! Item was changed: ----- Method: Number>>closeTo: (in category 'comparing') ----- closeTo: num "are these two numbers close?" - | ans | num isFloat ifTrue: [^ num closeTo: self asFloat]. + ^[self = num] ifError: [false]! - [ans := self = num] ifError: [:aString :aReceiver | ^ false]. - ^ ans! Item was changed: ----- Method: Model>>veryDeepFixupWith: (in category 'copying') ----- veryDeepFixupWith: deepCopier "See if the dependents are being copied also. If so, point at the new copies. (The dependent has self as its model.) Dependents handled in class Object, when the model is not a Model, are fixed up in Object veryDeepCopy." + | originalDependents refs | - | originalDependents refs newDependent | super veryDeepFixupWith: deepCopier. originalDependents := dependents. originalDependents ifNil: [ ^self. ]. dependents := nil. refs := deepCopier references. originalDependents + do: [:originalDependent | | newDependent | - do: [:originalDependent | newDependent := refs at: originalDependent ifAbsent: []. newDependent ifNotNil: [self addDependent: newDependent]]! Item was changed: ----- 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 interfaces resultType itsSelector | 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 changed: ----- Method: ClassDescription>>chooseInstVarThenDo: (in category 'instance variables') ----- chooseInstVarThenDo: aBlock "Put up a menu of all the instance variables in the receiver, and when the user chooses one, evaluate aBlock with the chosen variable as its parameter. If the list is 6 or larger, then offer an alphabetical formulation as an alternative. triggered by a 'show alphabetically' item at the top of the list." + | lines labelStream allVars index count offerAlpha | - | lines labelStream vars allVars index count offerAlpha | (count := self allInstVarNames size) = 0 ifTrue: [^ self inform: 'There are no instance variables.']. allVars := OrderedCollection new. lines := OrderedCollection new. labelStream := WriteStream on: (String new: 200). (offerAlpha := count > 5) ifTrue: [lines add: 1. allVars add: 'show alphabetically'. labelStream nextPutAll: allVars first; cr]. self withAllSuperclasses reverseDo: + [:class | | vars | - [:class | vars := class instVarNames. vars do: [:var | labelStream nextPutAll: var; cr. allVars add: var]. vars isEmpty ifFalse: [lines add: allVars size]]. labelStream skip: -1 "cut last CR". (lines size > 0 and: [lines last = allVars size]) ifTrue: [lines removeLast]. "dispense with inelegant line beneath last item" index := (UIManager default chooseFrom: (labelStream contents subStrings: {Character cr}) lines: lines title: 'Instance variables in', self name). index = 0 ifTrue: [^ self]. (index = 1 and: [offerAlpha]) ifTrue: [^ self chooseInstVarAlphabeticallyThenDo: aBlock]. aBlock value: (allVars at: index)! Item was changed: ----- Method: ClassBuilder>>mutate:to: (in category 'class mutation') ----- mutate: oldClass to: newClass "Mutate the old class and subclasses into newClass and subclasses. Note: This method is slightly different from: #mutate:toSuper: since here we are at the root of reshaping and have two distinct roots." - | newSubclass | self showProgressFor: oldClass. "Convert the subclasses" oldClass subclasses do:[:oldSubclass| + | newSubclass | newSubclass := self reshapeClass: oldSubclass toSuper: newClass. self mutate: oldSubclass to: newSubclass. ]. "And any obsolete ones" oldClass obsoleteSubclasses do:[:oldSubclass| oldSubclass ifNotNil:[ + | newSubclass | newSubclass := self reshapeClass: oldSubclass toSuper: newClass. self mutate: oldSubclass to: newSubclass. ]. ]. self update: oldClass to: newClass. ^newClass! Item was changed: ----- Method: Categorizer>>changeFromCategorySpecs: (in category 'accessing') ----- changeFromCategorySpecs: categorySpecs "Tokens is an array of categorySpecs as scanned from a browser 'reorganize' pane, or built up by some other process, such as a scan of an environment." + | newCategories newStops temp cc currentStop oldElements newElements | - | oldElements newElements newCategories newStops currentStop temp ii cc catSpec | oldElements := elementArray asSet. newCategories := Array new: categorySpecs size. newStops := Array new: categorySpecs size. currentStop := 0. newElements := WriteStream on: (Array new: 16). 1 to: categorySpecs size do: + [:i | | catSpec selectors | - [:i | | selectors | catSpec := categorySpecs at: i. newCategories at: i put: catSpec first asSymbol. selectors := catSpec allButFirst collect: [:each | each isSymbol ifTrue: [each] ifFalse: [each printString asSymbol]]. selectors asSortedCollection do: [:elem | (oldElements remove: elem ifAbsent: [nil]) notNil ifTrue: [newElements nextPut: elem. currentStop := currentStop+1]]. newStops at: i put: currentStop]. "Ignore extra elements but don't lose any existing elements!!" oldElements := oldElements collect: [:elem | Array with: (self categoryOfElement: elem) with: elem]. newElements := newElements contents. categoryArray := newCategories. (cc := categoryArray asSet) size = categoryArray size ifFalse: ["has duplicate element" temp := categoryArray asOrderedCollection. temp removeAll: categoryArray asSet asOrderedCollection. + temp do: [:dup | | ii | - temp do: [:dup | ii := categoryArray indexOf: dup. [dup := (dup,' #2') asSymbol. cc includes: dup] whileTrue. cc add: dup. categoryArray at: ii put: dup]]. categoryStops := newStops. elementArray := newElements. oldElements do: [:pair | self classify: pair last under: pair first].! Item was changed: ----- Method: Object>>universalTilesForInterface: (in category 'scripts-kernel') ----- universalTilesForInterface: aMethodInterface "Return universal tiles for the given method interface. Record who self is." + | ms itsSelector argList | - | ms argTile itsSelector aType 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 changed: ----- Method: ClassBuilder>>name:inEnvironment:subclassOf:type:instanceVariableNames:classVariableNames:poolDictionaries:category:unsafe: (in category 'class definition') ----- name: className inEnvironment: env subclassOf: newSuper type: type instanceVariableNames: instVarString classVariableNames: classVarString poolDictionaries: poolString category: category unsafe: unsafe "Define a new class in the given environment. If unsafe is true do not run any validation checks. This facility is provided to implement important system changes." + | oldClass instVars classVars copyOfOldClass newClass | - | oldClass newClass organization instVars classVars force needNew oldCategory copyOfOldClass newCategory | environ := env. instVars := Scanner new scanFieldNames: instVarString. classVars := (Scanner new scanFieldNames: classVarString) collect: [:x | x asSymbol]. "Validate the proposed name" unsafe ifFalse:[(self validateClassName: className) ifFalse:[^nil]]. oldClass := env at: className ifAbsent:[nil]. oldClass isBehavior ifFalse: [oldClass := nil] "Already checked in #validateClassName:" ifTrue: [ copyOfOldClass := oldClass copy. copyOfOldClass superclass addSubclass: copyOfOldClass]. + [ | newCategory needNew force organization oldCategory | + unsafe ifFalse:[ - [unsafe ifFalse:[ "Run validation checks so we know that we have a good chance for recompilation" (self validateSuperclass: newSuper forSubclass: oldClass) ifFalse:[^nil]. (self validateInstvars: instVars from: oldClass forSuper: newSuper) ifFalse:[^nil]. (self validateClassvars: classVars from: oldClass forSuper: newSuper) ifFalse:[^nil]. (self validateSubclassFormat: type from: oldClass forSuper: newSuper extra: instVars size) ifFalse:[^nil]]. "See if we need a new subclass" needNew := self needsSubclassOf: newSuper type: type instanceVariables: instVars from: oldClass. needNew == nil ifTrue:[^nil]. "some error" (needNew and:[unsafe not]) ifTrue:[ "Make sure we don't redefine any dangerous classes" (self tooDangerousClasses includes: oldClass name) ifTrue:[ self error: oldClass name, ' cannot be changed'. ]. "Check if the receiver should not be redefined" (oldClass ~~ nil and:[oldClass shouldNotBeRedefined]) ifTrue:[ self notify: oldClass name asText allBold, ' should not be redefined. \Proceed to store over it.' withCRs]]. needNew ifTrue:[ "Create the new class" newClass := self newSubclassOf: newSuper type: type instanceVariables: instVars from: oldClass. newClass == nil ifTrue:[^nil]. "Some error" newClass setName: className. ] ifFalse:[ "Reuse the old class" newClass := oldClass. ]. "Install the class variables and pool dictionaries... " force := (newClass declare: classVarString) | (newClass sharing: poolString). "... classify ..." newCategory := category asSymbol. organization := environ ifNotNil:[environ organization]. oldClass isNil ifFalse: [oldCategory := (organization categoryOfElement: oldClass name) asSymbol]. organization classify: newClass name under: newCategory. newClass environment: environ. "... recompile ..." newClass := self recompile: force from: oldClass to: newClass mutate: false. "... export if not yet done ..." (environ at: newClass name ifAbsent:[nil]) == newClass ifFalse:[ [environ at: newClass name put: newClass] on: AttemptToWriteReadOnlyGlobal do:[:ex| ex resume: true]. Smalltalk flushClassNameCache. ]. newClass doneCompiling. "... notify interested clients ..." oldClass isNil ifTrue: [ SystemChangeNotifier uniqueInstance classAdded: newClass inCategory: newCategory. ^ newClass]. newCategory ~= oldCategory ifTrue: [SystemChangeNotifier uniqueInstance class: newClass recategorizedFrom: oldCategory to: category] ifFalse: [SystemChangeNotifier uniqueInstance classDefinitionChangedFrom: copyOfOldClass to: newClass.]. ] ensure: [copyOfOldClass ifNotNil: [copyOfOldClass superclass removeSubclass: copyOfOldClass]. Behavior flushObsoleteSubclasses. ]. ^newClass! Item was changed: ----- Method: Float>>significandAsInteger (in category 'truncation and round off') ----- significandAsInteger | exp sig | + exp := self exponent. + sig := (((self at: 1) bitAnd: 16r000FFFFF) bitShift: 32) bitOr: (self at: 2). - exp _ self exponent. - sig _ (((self at: 1) bitAnd: 16r000FFFFF) bitShift: 32) bitOr: (self at: 2). (exp > -1023 and: [self ~= 0.0]) + ifTrue: [sig := sig bitOr: (1 bitShift: 52)]. - ifTrue: [sig _ sig bitOr: (1 bitShift: 52)]. ^ sig.! Item was changed: ----- Method: ClassDescription>>printMethodChunkHistorically:on:moveSource:toFile: (in category 'fileIn/Out') ----- printMethodChunkHistorically: selector on: outStream moveSource: moveSource toFile: fileIndex "Copy all source codes historically for the method associated with selector onto the fileStream. If moveSource true, then also set the source code pointer of the method." + | preamble method sourceFile endPos category changeList newPos | - | preamble method newPos sourceFile endPos category changeList prior | category := self organization categoryOfElement: selector. preamble := self name , ' methodsFor: ', category asString printString. method := self methodDict at: selector. ((method fileIndex = 0 or: [(SourceFiles at: method fileIndex) == nil]) or: [method filePosition = 0]) ifTrue: [ outStream cr; nextPut: $!!; nextChunkPut: preamble; cr. outStream nextChunkPut: method decompileString. outStream nextChunkPut: ' '; cr] ifFalse: [ changeList := ChangeSet scanVersionsOf: method class: self meta: self isMeta category: category selector: selector. newPos := nil. sourceFile := SourceFiles at: method fileIndex. + changeList reverseDo: [ :chgRec | | prior | - changeList reverseDo: [ :chgRec | chgRec fileIndex = fileIndex ifTrue: [ outStream copyPreamble: preamble from: sourceFile at: chgRec position. (prior := chgRec prior) ifNotNil: [ outStream position: outStream position - 2. outStream nextPutAll: ' prior: ', ( prior first = method fileIndex ifFalse: [prior third] ifTrue: [ SourceFiles sourcePointerFromFileIndex: method fileIndex andPosition: newPos]) printString. outStream nextPut: $!!; cr]. "Copy the method chunk" newPos := outStream position. outStream copyMethodChunkFrom: sourceFile at: chgRec position. sourceFile skipSeparators. "The following chunk may have ]style[" sourceFile peek == $] ifTrue: [ outStream cr; copyMethodChunkFrom: sourceFile]. outStream nextChunkPut: ' '; cr]]. moveSource ifTrue: [ endPos := outStream position. method checkOKToAdd: endPos - newPos at: newPos. method setSourcePosition: newPos inFile: fileIndex]]. ^ outStream! Item was changed: ----- Method: Behavior>>unreferencedInstanceVariables (in category 'user interface') ----- unreferencedInstanceVariables + "Return a list of the instance variables defined in the receiver which are not referenced in the receiver or any of its subclasses." - "Return a list of the instance variables defined in the receiver which are not referenced in the receiver or any of its subclasses. 2/26/96 sw" - - | any | + ^ self instVarNames reject: + [:ivn | + self withAllSubclasses anySatisfy: + [:class | (class whichSelectorsAccess: ivn) anySatisfy: + [:sel | sel isDoIt not]]]! - ^ self instVarNames copy reject: - [:ivn | any := false. - self withAllSubclasses do: - [:class | (class whichSelectorsAccess: ivn) do: - [:sel | sel isDoIt ifFalse: [any := true]]]. - any] - - "Ob unreferencedInstanceVariables"! Item was changed: ----- Method: Class>>sharing: (in category 'initialize-release') ----- sharing: poolString "Set up sharedPools. Answer whether recompilation is advisable." + | oldPools | - | oldPools found | oldPools := self sharedPools. sharedPools := OrderedCollection new. (Scanner new scanFieldNames: poolString) do: [:poolName | sharedPools add: (self environment at: poolName asSymbol ifAbsent:[ (self confirm: 'The pool dictionary ', poolName,' does not exist.', '\Do you want it automatically created?' withCRs) ifTrue:[self environment at: poolName asSymbol put: Dictionary new] ifFalse:[^self error: poolName,' does not exist']])]. sharedPools isEmpty ifTrue: [sharedPools := nil]. + oldPools do: [:pool | + | found | + found := self sharedPools anySatisfy: [:p | p == pool]. - oldPools do: [:pool | found := false. - self sharedPools do: [:p | p == pool ifTrue: [found := true]]. found ifFalse: [^ true "A pool got deleted"]]. ^ false! Item was changed: ----- Method: Metaclass>>addInstVarName: (in category 'instance variables') ----- addInstVarName: aString "Add the argument, aString, as one of the receiver's instance variables." | fullString | + fullString := String streamContents: [:strm | + self instVarNames do: [:aString2 | strm nextPutAll: aString2; space]. + strm nextPutAll: aString]. - fullString := aString. - self instVarNames do: [:aString2 | fullString := aString2 , ' ' , fullString]. self instanceVariableNames: fullString! Item was changed: ----- Method: Float>>hex (in category 'printing') ----- hex "If ya really want to know..." - | word nibble | ^ String streamContents: [:strm | + | word nibble | 1 to: 2 do: [:i | word := self at: i. 1 to: 8 do: [:s | nibble := (word bitShift: -8+s*4) bitAnd: 16rF. strm nextPut: ('0123456789ABCDEF' at: nibble+1)]]] " (-2.0 to: 2.0) collect: [:f | f hex] "! Item was changed: ----- Method: Object>>inheritsFromAnyIn: (in category 'class membership') ----- inheritsFromAnyIn: aList "Answer whether the receiver inherits from any class represented by any element in the list. The elements of the list can be classes, class name symbols, or strings representing possible class names. This allows speculative membership tests to be made even when some of the classes may not be known to the current image, and even when their names are not interned symbols." - | aClass | aList do: [:elem | Symbol hasInterned: elem asString ifTrue: + [:elemSymbol | + | aClass | + (((aClass := Smalltalk at: elemSymbol ifAbsent: [nil]) isKindOf: Class) - [:elemSymbol | (((aClass := Smalltalk at: elemSymbol ifAbsent: [nil]) isKindOf: Class) and: [self isKindOf: aClass]) ifTrue: [^ true]]]. ^ false " {3. true. 'olive'} do: [:token | {{#Number. #Boolean}. {Number. Boolean }. {'Number'. 'Boolean'}} do: [:list | Transcript cr; show: token asString, ' list element provided as a ', list first class name, ' - ', (token inheritsFromAnyIn: list) asString]] "! Item was changed: ----- Method: ClassDescription>>replaceSilently:to: (in category 'instance variables') ----- replaceSilently: old to: new "text-replace any part of a method. Used for class and pool variables. Don't touch the header. Not guaranteed to work if name appears in odd circumstances" + | oldName newName | - | oldCode newCode parser header body sels oldName newName | - oldName := old asString. newName := new asString. self withAllSubclasses do: + [:cls | + | sels | + sels := cls selectors copyWithoutAll: #(DoIt DoItIn:). - [:cls | sels := cls selectors asSet. - sels removeAllFoundIn: #(DoIt DoItIn:). sels do: [:sel | + | oldCode newCode parser header body | oldCode := cls sourceCodeAt: sel. "Don't make changes in the method header" (parser := cls parserClass new) parseSelector: oldCode. header := oldCode copyFrom: 1 to: (parser endOfLastToken min: oldCode size). body := header size > oldCode size ifTrue: [''] ifFalse: [oldCode copyFrom: header size+1 to: oldCode size]. newCode := header , (body copyReplaceTokens: oldName with: newName). newCode ~= oldCode ifTrue: [cls compile: newCode classified: (cls organization categoryOfElement: sel) notifying: nil]]. + cls isMeta ifFalse: + [| oldCode newCode | + oldCode := cls comment. + newCode := oldCode copyReplaceTokens: oldName with: newName. + newCode ~= oldCode ifTrue: + [cls comment: newCode]]]! - cls isMeta ifFalse: - [oldCode := cls comment. - newCode := oldCode copyReplaceTokens: oldName with: newName. - newCode ~= oldCode ifTrue: - [cls comment: newCode]]]! Item was changed: ----- Method: MethodFinder>>constUsingData1Value (in category 'find a constant') ----- constUsingData1Value + | subTest | - | const subTest got | "See if (data1 <= C) or (data1 >= C) is the answer" "quick test" ((answers at: 1) class superclass == Boolean) ifFalse: [^ false]. 2 to: answers size do: [:ii | ((answers at: ii) class superclass == Boolean) ifFalse: [^ false]]. + thisData do: [:datums | | got const | - thisData do: [:datums | const := datums first. "use data as a constant!!" got := (subTest := MethodFinder new copy: self addArg: const) searchForOne isEmpty not. got ifTrue: [ "replace data2 with const in expressions" subTest expressions do: [:exp | expressions add: (exp copyReplaceAll: 'data2' with: const printString)]. selector addAll: subTest selectors. ^ true]]. ^ false! Item was changed: ----- Method: StringHolder>>buildOptionalButtonsWith: (in category 'toolbuilder') ----- buildOptionalButtonsWith: builder + | panelSpec | - | panelSpec buttonSpec | panelSpec := builder pluggablePanelSpec new. panelSpec children: OrderedCollection new. self optionalButtonPairs do:[:spec| + | buttonSpec | buttonSpec := builder pluggableActionButtonSpec new. buttonSpec model: self. buttonSpec label: spec first. buttonSpec action: spec second. spec size > 2 ifTrue:[buttonSpec help: spec third]. panelSpec children add: buttonSpec. ]. panelSpec layout: #horizontal. "buttons" ^panelSpec! Item was changed: ----- Method: Random>>roll: (in category 'die rolling') ----- roll: diceString "Roll some dice, DnD-style, according to this mini-grammar: dice := epxr {pm expr} pm := '+' | '-' expr := num | num dD | dD numP | num dD numP dD := 'd' | 'D' num := digit+ numP := num | '%'" + | stream op result | - | stream op result dice range res token | stream := diceString readStream. result := 0. op := #+. + [ | res range dice token | + token := self diceToken: stream. - [token := self diceToken: stream. token isNumber ifTrue: [dice := token. token := self diceToken: stream] ifFalse: [token == $d ifTrue: [dice := 1] ifFalse: [res := 0]]. token == $d ifTrue: [token := self diceToken: stream. token isNumber ifTrue: [range := token. token := self diceToken: stream] ifFalse: [token == $% ifTrue: [range := 100. token := self diceToken: stream] ifFalse: [range := 6]]. res := 0. dice timesRepeat: [res := res + (self nextInt: range)]]. result := result perform: op with: res. token ifNil: [^ result]. (token == $+ or: [token == $-]) ifFalse: [self error: 'unknown token ' , token]. op := token asSymbol] repeat! Item was changed: ----- Method: Monitor>>critical: (in category 'synchronization') ----- critical: aBlock "Critical section. Executes aBlock as a critical section. At any time, only one process can be executing code in a critical section. NOTE: All the following synchronization operations are only valid inside the critical section of the monitor!!" + ^[ + self enter. + aBlock value] + ensure: [self exit].! - | result | - [self enter. - result := aBlock value] ensure: [self exit]. - ^ result.! Item was changed: ----- 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 ordered unordered index | 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 changed: ----- Method: Random class>>bucketTest: (in category 'testing') ----- bucketTest: randy "Execute this: Random bucketTest: Random new" " A quick-and-dirty bucket test. Prints nbuckets values on the Transcript. Each should be 'near' the value of ntries. Any run with any value 'far' from ntries indicates something is very wrong. Each run generates different values. For a slightly better test, try values of nbuckets of 200-1000 or more; go get coffee. This is a poor test; see Knuth. Some 'OK' runs: 1000 1023 998 969 997 1018 1030 1019 1054 985 1003 1011 987 982 980 982 974 968 1044 976 1029 1011 1025 1016 997 1019 991 954 968 999 991 978 1035 995 988 1038 1009 988 993 976 " + | nbuckets buckets ntrys | - | nbuckets buckets ntrys slot | nbuckets := 20. buckets := Array new: nbuckets. buckets atAllPut: 0. ntrys := 100. + ntrys*nbuckets timesRepeat: [ | slot | - ntrys*nbuckets timesRepeat: [ slot := (randy next * nbuckets) floor + 1. buckets at: slot put: (buckets at: slot) + 1 ]. Transcript cr. 1 to: nbuckets do: [ :nb | Transcript show: (buckets at: nb) printString, ' ' ]! Item was changed: ----- Method: CompiledMethodTrailer>>encodeSourceByStringIdentifier (in category 'encoding') ----- encodeSourceByStringIdentifier "A method source is determined by a class + string identifier" - | utf8str len | self assert: (data isString). encodedData := ByteArray streamContents: [:str | + | utf8str len | utf8str := (data convertToEncoding: 'utf8') asByteArray. str nextPutAll: utf8str. len := self encodeLengthField: utf8str size. str nextPutAll: len. str nextPut: self kindAsByte + (len size -1) ]! Item was changed: ----- Method: StringHolder>>buildWindowWith:specs: (in category 'toolbuilder') ----- buildWindowWith: builder specs: specs + | windowSpec | - | windowSpec rect action widgetSpec | windowSpec := self buildWindowWith: builder. specs do:[:assoc| + | rect action widgetSpec | rect := assoc key. action := assoc value. widgetSpec := action value. widgetSpec ifNotNil:[ widgetSpec frame: rect. windowSpec children add: widgetSpec]]. ^windowSpec! Item was changed: ----- Method: Message>>createStubMethod (in category 'stub creation') ----- createStubMethod + | argNames | - | argNames aOrAn argName arg argClassName | argNames := Set new. ^ String streamContents: [ :s | self selector keywords doWithIndex: [ :key :i | + | aOrAn argName arg argClassName | s nextPutAll: key. ((key last = $:) or: [self selector isInfix]) ifTrue: [ arg := self arguments at: i. argClassName := (arg isKindOf: Class) ifTrue: ['Class'] ifFalse: [arg class name]. aOrAn := argClassName first isVowel ifTrue: ['an'] ifFalse: ['a']. argName := aOrAn, argClassName. [argNames includes: argName] whileTrue: [argName := argName, i asString]. argNames add: argName. s nextPutAll: ' '; nextPutAll: argName; space ]. ]. s cr; tab. s nextPutAll: 'self shouldBeImplemented' ]! Item was changed: ----- Method: Random>>check:difficulty: (in category 'die rolling') ----- check: nDice difficulty: diff "Roll some dice, WoD-style." + | result | - | result die | result := 0. nDice timesRepeat: + [ | die | + (die := self nextInt: 10) = 1 - [(die := self nextInt: 10) = 1 ifTrue: [result := result - 1] ifFalse: [die >= diff ifTrue: [result := result + 1]]]. ^ result! Item was changed: ----- 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 | - | aName nameSym stem okay | 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 changed: ----- Method: ContextPart>>quickSend:to:with:super: (in category 'controlling') ----- quickSend: selector to: receiver with: arguments super: superFlag "Send the given selector with arguments in an environment which closely resembles the non-simulating environment, with an interjected unwind-protected block to catch nonlocal returns. Attention: don't get lost!!" + | lookupClass contextToReturnTo result | - | oldSender contextToReturnTo result lookupClass | contextToReturnTo := self. lookupClass := superFlag ifTrue: [(self method literalAt: self method numLiterals) value superclass] ifFalse: [receiver class]. + [ | oldSender | + oldSender := thisContext sender swapSender: self. - [oldSender := thisContext sender swapSender: self. result := receiver perform: selector withArguments: arguments inSuperclass: lookupClass. thisContext sender swapSender: oldSender] ifCurtailed: [ contextToReturnTo := thisContext sender receiver. "The block context returning nonlocally" contextToReturnTo jump: -1. "skip to front of return bytecode causing this unwind" contextToReturnTo nextByte = 16r7C ifTrue: [ "If it was a returnTop, push the value to be returned. Otherwise the value is implicit in the bytecode" contextToReturnTo push: (thisContext sender tempAt: 1)]. thisContext swapSender: thisContext home sender. "Make this block return to the method's sender" contextToReturnTo]. contextToReturnTo push: result. ^contextToReturnTo! Item was changed: ----- Method: Object>>veryDeepCopyUsing: (in category 'copying') ----- veryDeepCopyUsing: copier "Do a complete tree copy using a dictionary. An object in the tree twice is only copied once. All references to the object in the copy of the tree will point to the new copy. Same as veryDeepCopy except copier (with dictionary) is supplied. ** do not delete this method, even if it has no callers **" + | new refs | - | new refs newDep newModel | new := self veryDeepCopyWith: copier. copier mapUniClasses. copier references associationsDo: [:assoc | assoc value veryDeepFixupWith: copier]. "Fix dependents" refs := copier references. DependentsFields associationsDo: [:pair | pair value do: [:dep | + | newDep newModel | (newDep := refs at: dep ifAbsent: [nil]) ifNotNil: [ newModel := refs at: pair key ifAbsent: [pair key]. newModel addDependent: newDep]]]. ^ new! Item was changed: ----- Method: ClassOrganizer>>notifyOfChangedSelectorsOldDict:newDict: (in category 'private') ----- notifyOfChangedSelectorsOldDict: oldDictionaryOrNil newDict: newDictionaryOrNil - | newCat | (oldDictionaryOrNil isNil and: [newDictionaryOrNil isNil]) ifTrue: [^ self]. oldDictionaryOrNil isNil ifTrue: [ newDictionaryOrNil keysAndValuesDo: [:el :cat | self notifyOfChangedSelector: el from: nil to: cat]. ^ self. ]. newDictionaryOrNil isNil ifTrue: [ oldDictionaryOrNil keysAndValuesDo: [:el :cat | self notifyOfChangedSelector: el from: cat to: nil]. ^ self. ]. oldDictionaryOrNil keysAndValuesDo: [:el :cat | + | newCat | newCat := newDictionaryOrNil at: el. self notifyOfChangedSelector: el from: cat to: newCat. ].! Item was changed: ----- 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 nameSym 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 changed: ----- Method: Class>>fileOutPool:onFileStream: (in category 'fileIn/Out') ----- fileOutPool: aPool onFileStream: aFileStream + | aPoolName | - | aPoolName aValue | (aPool isKindOf: SharedPool class) ifTrue:[^self notify: 'we do not fileout SharedPool type shared pools for now']. aPoolName := self environment keyAtIdentityValue: aPool. Transcript cr; show: aPoolName. aFileStream nextPutAll: 'Transcript show: ''' , aPoolName , '''; cr!!'; cr. aFileStream nextPutAll: 'Smalltalk at: #' , aPoolName , ' put: Dictionary new!!'; cr. aPool keys asArray sort do: [ :aKey | + | aValue | aValue := aPool at: aKey. aFileStream nextPutAll: aPoolName , ' at: #''' , aKey asString , '''', ' put: '. (aValue isKindOf: Number) ifTrue: [aValue printOn: aFileStream] ifFalse: [aFileStream nextPutAll: '('. aValue printOn: aFileStream. aFileStream nextPutAll: ')']. aFileStream nextPutAll: '!!'; cr]. aFileStream cr! Item was changed: ----- Method: Semaphore>>critical: (in category 'mutual exclusion') ----- critical: mutuallyExcludedBlock "Evaluate mutuallyExcludedBlock only if the receiver is not currently in the process of running the critical: message. If the receiver is, evaluate mutuallyExcludedBlock after the other critical: message is finished." + | caught | - | blockValue caught | caught := false. + ^[ - [ caught := true. self wait. + mutuallyExcludedBlock value + ] ensure: [caught ifTrue: [self signal]] - blockValue := mutuallyExcludedBlock value - ] ensure: [caught ifTrue: [self signal]]. - ^blockValue ! Item was changed: ----- Method: Object>>copySameFrom: (in category 'copying') ----- copySameFrom: otherObject "Copy to myself all instance variables named the same in otherObject. This ignores otherObject's control over its own inst vars." + | myInstVars otherInstVars | - | myInstVars otherInstVars match | myInstVars := self class allInstVarNames. otherInstVars := otherObject class allInstVarNames. myInstVars doWithIndex: [:each :index | + | match | (match := otherInstVars indexOf: each) > 0 ifTrue: [self instVarAt: index put: (otherObject instVarAt: match)]]. 1 to: (self basicSize min: otherObject basicSize) do: [:i | self basicAt: i put: (otherObject basicAt: i)]. ! Item was changed: ----- Method: Integer class>>verbosePrimesUpTo:do: (in category 'prime numbers') ----- verbosePrimesUpTo: max do: aBlock "Integer verbosePrimesUpTo: SmallInteger maxVal" "<- heh, heh" "Compute primes up to max, but be verbose about it" + | lastTime | - | lastTime nowTime | lastTime := Time millisecondClockValue. Utilities informUserDuring:[:bar| bar value:'Computing primes...'. + self primesUpTo: max do:[:prime| | nowTime | - self primesUpTo: max do:[:prime| aBlock value: prime. nowTime := Time millisecondClockValue. (nowTime - lastTime > 1000) ifTrue:[ lastTime := nowTime. bar value:'Last prime found: ', prime printString]]].! Item was changed: ----- Method: CompiledMethodTrailer>>qCompress: (in category 'private') ----- qCompress: string "A very simple text compression routine designed for method temp names. Most common 11 chars get values 1-11 packed in one 4-bit nibble; the next most common get values 12-15 (2 bits) * 16 plus next nibble; unusual ones get three nibbles, the first being the escape nibble 0. Answer the write stream with compressed data inside" + | utf8str stream oddNibble | - | utf8str stream ix oddNibble | string isEmpty ifTrue: [^self qCompress: ' ']. utf8str := string convertToEncoding: 'utf8'. stream := WriteStream on: (ByteArray new: utf8str size). oddNibble := nil. + utf8str do: [:char | | ix | - utf8str do: [:char | ix := 'ear tonsilcmbdfghjkpquvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ012345[]()' indexOf: char ifAbsent: 0. (ix = 0 ifTrue: [{ 0. char asInteger // 16. char asInteger \\ 16 }] ifFalse: [ix <= 11 ifTrue: [{ ix }] ifFalse: [{ ix//16+12. ix\\16 }]]) do: [:nibble | oddNibble ifNotNil: [stream nextPut: oddNibble*16 + nibble. oddNibble := nil] ifNil: [oddNibble := nibble]]]. oddNibble ifNotNil: "4 = 'ear tonsil' indexOf: Character space" [stream nextPut: oddNibble * 16 + 4]. ^ stream ! Item was changed: ----- Method: CompiledMethodTrailer>>encodeVarLengthSourcePointer (in category 'encoding') ----- encodeVarLengthSourcePointer - | value | "source pointer must be >=0" (self assert: data >= 0). - value := data. encodedData := ByteArray streamContents: [:str | + | value | + value := data. [value > 0] whileTrue: [ value > 127 ifTrue: [ str nextPut: 128 + (value bitAnd: 16r7F) ] ifFalse: [ str nextPut: value. ]. value := value >> 7. ]. ]. encodedData := encodedData reversed copyWith: (self kindAsByte)! Item was changed: ----- Method: Time class>>condenseBunches: (in category 'general inquiries') ----- condenseBunches: aCollectionOfSeconds + | secArray now out pause prev bunchEnd | - | secArray pause now out prev bunchEnd ago | "Identify the major intervals in a bunch of numbers. Each number is a seconds since 1901 that represents a date and time. We want the last event in a bunch. Return array of seconds for: Every event in the last half hour. Every bunch separated by 30 min in the last 24 hours. Every bunch separated by two hours before that." "Time condenseBunches: (#(20 400 401 20000 20200 20300 40000 45000 200000 201000 202000) collect: [ :tt | self totalSeconds - tt]) " secArray := aCollectionOfSeconds asSortedCollection. pause := 1. now := self totalSeconds. out := OrderedCollection new. prev := 0. bunchEnd := nil. + secArray reverseDo: [:secs | | ago | "descending" - secArray reverseDo: [:secs | "descending" ago := now - secs. ago > (60*30) ifTrue: [pause := "60*30" 1800]. ago > (60*60*24) ifTrue: [pause := "60*120" 7200]. ago - prev >= pause ifTrue: [out add: bunchEnd. bunchEnd := secs]. prev := ago]. out add: bunchEnd. out removeFirst. ^ out ! Item was changed: ----- Method: ClassDescription>>fileOutChangedMessagesHistorically:on:moveSource:toFile: (in category 'fileIn/Out') ----- fileOutChangedMessagesHistorically: aSet on: aFileStream moveSource: moveSource toFile: fileIndex "File all historical description of the messages of this class that have been changed (i.e., are entered into the argument, aSet) onto aFileStream. If moveSource, is true, then set the method source pointer to the new file position. Note when this method is called with moveSource=true, it is condensing the .changes file, and should only write a preamble for every method." + | org | - | org sels | (org := self organization) categories do: [:cat | + | sels | sels := (org listAtCategoryNamed: cat) select: [:sel | aSet includes: sel]. sels do: [:sel | self printMethodChunkHistorically: sel on: aFileStream moveSource: moveSource toFile: fileIndex]]! Item was changed: ----- Method: DateAndTime>>dayOfYear (in category 'ansi protocol') ----- dayOfYear "This code was contributed by Dan Ingalls. It is equivalent to the terser ^ jdn - (Year year: self year) start julianDayNumber + 1 but much quicker." - | monthStart | ^ self dayMonthYearDo: [ :d :m :y | + | monthStart | monthStart := #(1 32 60 91 121 152 182 213 244 274 305 335) at: m. (m > 2 and: [ Year isLeapYear: y ]) ifTrue: [ monthStart + d ] ifFalse: [ monthStart + d - 1 ]]! Item was changed: ----- Method: Integer>>printStringRoman (in category 'printing-numerative') ----- printStringRoman + ^String streamContents: [:stream | | integer | + integer := self negative ifTrue: [stream nextPut: $-. self negated] ifFalse: [self]. + integer // 1000 timesRepeat: [stream nextPut: $M]. + integer + romanDigits: 'MDC' for: 100 on: stream; + romanDigits: 'CLX' for: 10 on: stream; + romanDigits: 'XVI' for: 1 on: stream]! - | stream integer | - stream := WriteStream on: String new. - integer := self negative ifTrue: [stream nextPut: $-. self negated] ifFalse: [self]. - integer // 1000 timesRepeat: [stream nextPut: $M]. - integer - romanDigits: 'MDC' for: 100 on: stream; - romanDigits: 'CLX' for: 10 on: stream; - romanDigits: 'XVI' for: 1 on: stream. - ^stream contents! Item was changed: ----- Method: Time class>>namesForTimes: (in category 'general inquiries') ----- namesForTimes: arrayOfSeconds + | simpleEnglish final prev | - | simpleEnglish prev final prevPair myPair | "Return English descriptions of the times in the array. They are each seconds since 1901. If two names are the same, append the date and time to distinguish them." simpleEnglish := arrayOfSeconds collect: [:secsAgo | self humanWordsForSecondsAgo: self totalSeconds - secsAgo]. prev := ''. final := simpleEnglish copy. + simpleEnglish withIndexDo: [:eng :ind | | prevPair myPair | - simpleEnglish withIndexDo: [:eng :ind | eng = prev ifFalse: [eng] ifTrue: ["both say 'a month ago'" prevPair := self dateAndTimeFromSeconds: (arrayOfSeconds at: ind-1). myPair := self dateAndTimeFromSeconds: (arrayOfSeconds at: ind). (final at: ind-1) = prev ifTrue: ["only has 'a month ago'" final at: ind-1 put: (final at: ind-1), ', ', prevPair first mmddyyyy]. final at: ind put: (final at: ind), ', ', myPair first mmddyyyy. prevPair first = myPair first ifTrue: [ (final at: ind-1) last == $m ifFalse: ["date but no time" final at: ind-1 put: (final at: ind-1), ', ', prevPair second printMinutes]. final at: ind put: (final at: ind), ', ', myPair second printMinutes]]. prev := eng]. ^ final ! Item was changed: ----- Method: ClassDescription>>fileOutChangedMessages:on:moveSource:toFile: (in category 'fileIn/Out') ----- fileOutChangedMessages: aSet on: aFileStream moveSource: moveSource toFile: fileIndex "File a description of the messages of this class that have been changed (i.e., are entered into the argument, aSet) onto aFileStream. If moveSource, is true, then set the method source pointer to the new file position. Note when this method is called with moveSource=true, it is condensing the .changes file, and should only write a preamble for every method." + | org | - | org sels | (org := self organization) categories do: [:cat | + | sels | sels := (org listAtCategoryNamed: cat) select: [:sel | aSet includes: sel]. ((cat beginsWith: '*') and: [cat endsWith: '-override']) ifTrue: [ sels do: [:sel | self printMethodChunkHistorically: sel on: aFileStream moveSource: moveSource toFile: fileIndex]] ifFalse: [ sels do: [:sel | self printMethodChunk: sel withPreamble: true on: aFileStream moveSource: moveSource toFile: fileIndex]]]! Item was changed: ----- Method: CompiledMethod>>searchForSelector (in category 'accessing') ----- searchForSelector "search me in all classes, if found, return my selector. Slow!!" - | selector | self systemNavigation allBehaviorsDo: [:class | + | selector | (selector := class methodDict keyAtIdentityValue: self ifAbsent: [nil]) ifNotNil: [^selector]]. ^nil.! Item was changed: ----- Method: Object>>primitiveError: (in category 'private') ----- primitiveError: aString "This method is called when the error handling results in a recursion in calling on error: or halt or halt:." - | context | (String streamContents: [:s | + | context | s nextPutAll: '***System error handling failed***'. s cr; nextPutAll: aString. context := thisContext sender sender. 20 timesRepeat: [context == nil ifFalse: [s cr; print: (context := context sender)]]. s cr; nextPutAll: '-------------------------------'. s cr; nextPutAll: 'Type CR to enter an emergency evaluator.'. s cr; nextPutAll: 'Type any other character to restart.']) displayAt: 0 @ 0. [Sensor keyboardPressed] whileFalse. Sensor keyboard = Character cr ifTrue: [Transcripter emergencyEvaluator]. Smalltalk isMorphic ifTrue: [World install "init hands and redisplay"] ifFalse: [ScheduledControllers searchForActiveController]!
More information about the Squeak-dev mailing list |