'From Pharo1.0beta of 16 May 2008 [Latest update: #10487] on 19 October 2009 at 4:57:33 pm'! BracketSliderMorph subclass: #AColorSelectorMorph instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Widgets'! !AColorSelectorMorph commentStamp: 'gvc 5/18/2007 13:52' prior: 0! ColorComponentSelector showing an alpha gradient over a hatched background.! !AColorSelectorMorph methodsFor: 'accessing' stamp: 'gvc 9/3/2009 13:43'! color: aColor "Set the gradient colors." super color: aColor asNontranslucentColor. self fillStyle: self defaultFillStyle! ! !AColorSelectorMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/3/2009 13:43'! defaultFillStyle "Answer the hue gradient." ^(GradientFillStyle colors: {self color alpha: 0. self color}) origin: self topLeft; direction: (self bounds isWide ifTrue: [self width@0] ifFalse: [0@self height])! ! !AColorSelectorMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/22/2006 09:17'! hatchForm "Answer a form showing a grid hatch pattern." ^ColorPresenterMorph hatchForm! ! !AColorSelectorMorph methodsFor: 'drawing' stamp: 'gvc 9/19/2006 14:28'! drawOn: aCanvas "Draw a hatch pattern first." aCanvas fillRectangle: self innerBounds fillStyle: (InfiniteForm with: self hatchForm). super drawOn: aCanvas ! ! !AColorSelectorMorph methodsFor: 'initialization' stamp: 'gvc 9/26/2006 11:54'! initialize "Initialize the receiver." super initialize. self value: 1.0; color: Color black! ! !AColorSelectorMorph methodsFor: 'visual properties' stamp: 'gvc 9/19/2006 15:46'! fillStyle: fillStyle "If it is a color then override with gradient." fillStyle isColor ifTrue: [self color: fillStyle] ifFalse: [super fillStyle: fillStyle]! ! TestCase subclass: #ATestCase instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Tests-Traits'! !ATestCase methodsFor: 'as yet unclassified' stamp: 'oscar.nierstrasz 10/18/2009 14:59'! testRequirement " self debug: #testRequirement " | class | class := Object subclass: #AClassForTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: self class category. [ class compile: 'call ^ self isCalled'. self assert: (class requiredSelectors includes: #isCalled). class compile: 'isCalled ^ 1'. "Fail here:" self deny: (class requiredSelectors includes: #isCalled)] ensure: [class removeFromSystem. RequiredSelectors current clearOut: class ] ! ! Exception subclass: #Abort instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Exceptions-Kernel'! !Abort methodsFor: 'as yet unclassified' stamp: 'ajh 3/24/2003 00:55'! defaultAction "No one has handled this error, but now give them a chance to decide how to debug it. If none handle this either then open debugger (see UnhandedError-defaultAction)" UnhandledError signalForException: self! ! DialogWindow subclass: #AboutDialogWindow instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Widgets-Windows'! !AboutDialogWindow commentStamp: 'gvc 5/18/2007 13:53' prior: 0! Default superclass for application about dialogs.! !AboutDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 1/12/2007 16:32'! newButtons "Answer new buttons as appropriate." ^{self newCloseButton isDefault: true}! ! Object subclass: #AbstractEvent instanceVariableNames: 'item itemKind environment' classVariableNames: '' poolDictionaries: '' category: 'System-Change Notification'! !AbstractEvent methodsFor: 'accessing' stamp: 'rw 6/30/2003 08:22'! item "Return the item that triggered the event (typically the name of a class, a category, a protocol, a method)." ^item! ! !AbstractEvent methodsFor: 'accessing' stamp: 'rw 7/10/2003 12:43'! itemCategory ^self environmentAt: self class categoryKind! ! !AbstractEvent methodsFor: 'accessing' stamp: 'rw 7/10/2003 12:43'! itemClass ^self environmentAt: self class classKind! ! !AbstractEvent methodsFor: 'accessing' stamp: 'rw 7/14/2003 12:10'! itemExpression ^self environmentAt: self class expressionKind! ! !AbstractEvent methodsFor: 'accessing' stamp: 'rw 6/30/2003 08:22'! itemKind "Return the kind of the item of the event (#category, #class, #protocol, #method, ...)" ^itemKind! ! !AbstractEvent methodsFor: 'accessing' stamp: 'rw 7/10/2003 12:44'! itemMethod ^self environmentAt: self class methodKind! ! !AbstractEvent methodsFor: 'accessing' stamp: 'rw 7/10/2003 12:44'! itemProtocol ^self environmentAt: self class protocolKind! ! !AbstractEvent methodsFor: 'accessing' stamp: 'NS 1/27/2004 10:38'! itemRequestor ^self environmentAt: #requestor! ! !AbstractEvent methodsFor: 'accessing' stamp: 'NS 1/27/2004 10:38'! itemSelector ^self environmentAt: #selector! ! !AbstractEvent methodsFor: 'printing' stamp: 'NS 1/19/2004 17:52'! printOn: aStream self printEventKindOn: aStream. aStream nextPutAll: ' Event for item: '; print: self item; nextPutAll: ' of kind: '; print: self itemKind! ! !AbstractEvent methodsFor: 'testing' stamp: 'rw 6/30/2003 08:34'! isAdded ^false! ! !AbstractEvent methodsFor: 'testing' stamp: 'NS 1/19/2004 18:41'! isCategoryKnown ^self itemCategory notNil! ! !AbstractEvent methodsFor: 'testing' stamp: 'rw 7/10/2003 15:01'! isCommented ^false! ! !AbstractEvent methodsFor: 'testing' stamp: 'rw 7/14/2003 10:15'! isDoIt ^false! ! !AbstractEvent methodsFor: 'testing' stamp: 'NS 1/19/2004 15:09'! isModified ^false! ! !AbstractEvent methodsFor: 'testing' stamp: 'NS 1/21/2004 09:40'! isProtocolKnown ^self itemCategory notNil! ! !AbstractEvent methodsFor: 'testing' stamp: 'rw 7/1/2003 19:53'! isRecategorized ^false! ! !AbstractEvent methodsFor: 'testing' stamp: 'rw 6/30/2003 08:34'! isRemoved ^false! ! !AbstractEvent methodsFor: 'testing' stamp: 'rw 7/1/2003 11:35'! isRenamed ^false! ! !AbstractEvent methodsFor: 'testing' stamp: 'NS 1/27/2004 12:44'! isReorganized ^ false! ! !AbstractEvent methodsFor: 'triggering' stamp: 'rw 7/14/2003 17:06'! trigger: anEventManager "Trigger the event manager." anEventManager triggerEvent: self eventSelector with: self.! ! !AbstractEvent methodsFor: 'private-accessing' stamp: 'rw 7/10/2003 12:10'! changeKind ^self class changeKind! ! !AbstractEvent methodsFor: 'private-accessing' stamp: 'rw 7/10/2003 12:43'! environmentAt: anItemKind (self itemKind = anItemKind) ifTrue: [^self item]. ^environment at: anItemKind ifAbsent: [nil]! ! !AbstractEvent methodsFor: 'private-accessing' stamp: 'rw 7/10/2003 12:20'! eventSelector ^self class eventSelectorBlock value: itemKind value: self changeKind! ! !AbstractEvent methodsFor: 'private-accessing' stamp: 'rw 7/10/2003 12:36'! item: anItem kind: anItemKind item := anItem. itemKind := anItemKind. environment := Dictionary new! ! !AbstractEvent methodsFor: 'private-accessing' stamp: 'rw 7/10/2003 12:37'! itemCategory: aCategory environment at: self class categoryKind put: aCategory! ! !AbstractEvent methodsFor: 'private-accessing' stamp: 'rw 7/10/2003 12:36'! itemClass: aClass environment at: self class classKind put: aClass! ! !AbstractEvent methodsFor: 'private-accessing' stamp: 'rw 7/14/2003 12:11'! itemExpression: anExpression environment at: self class expressionKind put: anExpression! ! !AbstractEvent methodsFor: 'private-accessing' stamp: 'rw 7/10/2003 12:38'! itemMethod: aMethod environment at: self class methodKind put: aMethod! ! !AbstractEvent methodsFor: 'private-accessing' stamp: 'rw 7/10/2003 12:38'! itemProtocol: aProtocol environment at: self class protocolKind put: aProtocol! ! !AbstractEvent methodsFor: 'private-accessing' stamp: 'NS 1/27/2004 10:38'! itemRequestor: requestor environment at: #requestor put: requestor! ! !AbstractEvent methodsFor: 'private-accessing' stamp: 'NS 1/27/2004 10:39'! itemSelector: aSymbol environment at: #selector put: aSymbol! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AbstractEvent class instanceVariableNames: ''! !AbstractEvent class methodsFor: 'accessing' stamp: 'NS 1/16/2004 14:08'! allChangeKinds "AbstractEvent allChangeKinds" ^AbstractEvent allSubclasses collect: [:cl | cl changeKind]! ! !AbstractEvent class methodsFor: 'accessing' stamp: 'bvs 7/20/2004 12:12'! allItemKinds "self allItemKinds" ^(AbstractEvent class organization listAtCategoryNamed: #'item kinds') collect: [:sel | self perform: sel]! ! !AbstractEvent class methodsFor: 'accessing' stamp: 'rw 7/10/2003 12:08'! changeKind "Return a symbol, with a : as last character, identifying the change kind." self subclassResponsibility! ! !AbstractEvent class methodsFor: 'accessing' stamp: 'rw 7/10/2003 12:18'! eventSelectorBlock ^[:itemKind :changeKind | itemKind, changeKind, 'Event:']! ! !AbstractEvent class methodsFor: 'accessing' stamp: 'rw 7/10/2003 12:19'! itemChangeCombinations ^self supportedKinds collect: [:itemKind | self eventSelectorBlock value: itemKind value: self changeKind]! ! !AbstractEvent class methodsFor: 'accessing' stamp: 'rw 7/10/2003 12:04'! supportedKinds "All the kinds of items that this event can take. By default this is all the kinds in the system. But subclasses can override this to limit the choices. For example, the SuperChangedEvent only works with classes, and not with methods, instance variables, ..." ^self allItemKinds! ! !AbstractEvent class methodsFor: 'accessing' stamp: 'rw 7/10/2003 11:39'! systemEvents "Return all the possible events in the system. Make a cross product of the items and the change types." "self systemEvents" ^self allSubclasses inject: OrderedCollection new into: [:allEvents :eventClass | allEvents addAll: eventClass itemChangeCombinations; yourself]! ! !AbstractEvent class methodsFor: 'instance creation' stamp: 'ab 2/10/2005 16:32'! classCategory: aName ^ self item: aName kind: AbstractEvent categoryKind.! ! !AbstractEvent class methodsFor: 'instance creation' stamp: 'NS 1/19/2004 18:42'! class: aClass ^ self item: aClass kind: AbstractEvent classKind.! ! !AbstractEvent class methodsFor: 'instance creation' stamp: 'NS 1/19/2004 18:42'! class: aClass category: cat | instance | instance := self class: aClass. instance itemCategory: cat. ^instance! ! !AbstractEvent class methodsFor: 'instance creation' stamp: 'rw 7/9/2003 11:19'! item: anItem kind: anItemKind ^self basicNew item: anItem kind: anItemKind! ! !AbstractEvent class methodsFor: 'instance creation' stamp: 'NS 1/16/2004 14:19'! method: aMethod class: aClass | instance | instance := self item: aMethod kind: self methodKind. instance itemClass: aClass. ^instance! ! !AbstractEvent class methodsFor: 'instance creation' stamp: 'NS 1/16/2004 14:20'! method: aMethod protocol: prot class: aClass | instance | instance := self method: aMethod class: aClass. instance itemProtocol: prot. ^instance! ! !AbstractEvent class methodsFor: 'instance creation' stamp: 'NS 1/27/2004 10:48'! method: aMethod selector: aSymbol class: aClass | instance | instance := self item: aMethod kind: self methodKind. instance itemSelector: aSymbol. instance itemClass: aClass. ^instance! ! !AbstractEvent class methodsFor: 'instance creation' stamp: 'NS 1/27/2004 10:49'! method: aMethod selector: aSymbol class: aClass requestor: requestor | instance | instance := self method: aMethod selector: aSymbol class: aClass. instance itemRequestor: requestor. ^instance! ! !AbstractEvent class methodsFor: 'instance creation' stamp: 'NS 1/27/2004 10:49'! method: aMethod selector: aSymbol protocol: prot class: aClass | instance | instance := self method: aMethod selector: aSymbol class: aClass. instance itemProtocol: prot. ^instance! ! !AbstractEvent class methodsFor: 'instance creation' stamp: 'NS 1/27/2004 10:50'! method: aMethod selector: aSymbol protocol: prot class: aClass requestor: requestor | instance | instance := self method: aMethod selector: aSymbol protocol: prot class: aClass. instance itemRequestor: requestor. ^instance! ! !AbstractEvent class methodsFor: 'instance creation' stamp: 'rw 6/30/2003 09:20'! new "Override new to trigger an error, since we want to use specialized methods to create basic and higher-level events." ^self error: 'Instances can only be created using specialized instance creation methods.'! ! !AbstractEvent class methodsFor: 'item kinds' stamp: 'rw 7/9/2003 11:12'! categoryKind ^#category! ! !AbstractEvent class methodsFor: 'item kinds' stamp: 'rw 7/9/2003 11:12'! classKind ^#class! ! !AbstractEvent class methodsFor: 'item kinds' stamp: 'rw 7/14/2003 11:41'! expressionKind ^#expression! ! !AbstractEvent class methodsFor: 'item kinds' stamp: 'rw 7/9/2003 11:12'! methodKind ^#method! ! !AbstractEvent class methodsFor: 'item kinds' stamp: 'rw 7/10/2003 12:36'! protocolKind ^#protocol! ! !AbstractEvent class methodsFor: 'temporary' stamp: 'rw 7/11/2003 10:23'! comment1 "Smalltalk organization removeElement: #ClassForTestingSystemChanges3 Smalltalk garbageCollect Smalltalk organizati classify:under: SystemChangeNotifier uniqueInstance releaseAll SystemChangeNotifier uniqueInstance noMoreNotificationsFor: aDependent. aDependent := SystemChangeNotifierTest new. SystemChangeNotifier uniqueInstance notifyOfAllSystemChanges: aDependent using: #event: SystemChangeNotifier uniqueInstance classAdded: #Foo inCategory: #FooCat | eventSource dependentObject | eventSource := EventManager new. dependentObject := Object new. register - dependentObject becomes dependent: eventSource when: #anEvent send: #error to: dependentObject. unregister dependentObject: eventSource removeDependent: dependentObject. [eventSource triggerEvent: #anEvent] on: Error do: [:exc | self halt: 'Should not be!!']."! ! !AbstractEvent class methodsFor: 'temporary' stamp: 'rw 7/11/2003 10:24'! comment2 "HTTPSocket useProxyServerNamed: 'proxy.telenet.be' port: 8080 TestRunner open -------------------- We propose two orthogonal groups to categorize each event: (1) the 'change type': added, removed, modified, renamed + the composite 'changed' (see below for an explanation) (2) the 'item type': class, method, instance variable, pool variable, protocol, category + the composite 'any' (see below for an explanation). The list of supported events is the cross product of these two lists (see below for an explicit enumeration of the events). Depending on the change type, certain information related to the change is always present (for adding, the new things that was added, for removals, what was removed, for renaming, the old and the new name, etc.). Depending on the item type, information regarding the item is present (for a method, which class it belongs to). Certain events 'overlap', for example, a method rename triggers a class change. To capture this I impose a hierarchy on the 'item types' (just put some numbers to clearly show the idea. They don't need numbers, really. Items at a certain categories are included by items one category number higher): level 1 category level 2 class level 3 instance variable, pool variable, protocol, method. Changes propagate according to this tree: any 'added', 'removed' or 'renamed' change type in level X triggers a 'changed' change type in level X - 1. A 'modified' change type does not trigger anything special. For example, a method additions triggers a class modification. This does not trigger a category modification. Note that we added 'composite events': wildcards for the 'change type' ('any' - any system additions) and for the 'item type' ('Changed' - all changes related to classes), and one for 'any change systemwide' (systemChanged). This result is this list of Events: classAdded classRemoved classModified classRenamed (?) classChanged (composite) methodAdded methodRemoved methodModified methodRenamed (?) methodChanged (composite) instanceVariableAdded instanceVariableRemoved instanceVariableModified instanceVariableRenamed (?) instanceVariableChanged (composite) protocolAdded protocolRemoved protocolModified protocolRenamed (?) protocolChanged (composite) poolVariableAdded poolVariableRemoved poolVariableModified poolVariableRenamed (?) poolChanged (composite) categoryAdded categoryRemoved categoryModified categeryRenamed (?) categoryChanged (composite) anyAdded (composite) anyRemoved (composite) anyModified (composite) anyRenamed (composite) anyChanged (composite) To check: can we pass somehow the 'source' of the change (a browser, a file-in, something else) ? Maybe by checking the context, but should not be too expensive either... I found this useful in some of my tools, but it might be too advanced to have in general. Tools that need this can always write code to check it for them. But is not always simple... Utilities (for the recent methods) and ChangeSet are the two main clients at this moment. Important: make it very explicit that the event is send synchronously (or asynchronously, would we take that route). category class comment protocol method OR category Smalltalk class comment protocol method ?? Smalltalk category \ / class / | \ comment | protocol | / method "! ! !AbstractEvent class methodsFor: 'temporary' stamp: 'rw 7/11/2003 15:43'! comment3 "Things to consider for trapping: ClassOrganizer>>#changeFromCategorySpecs: Problem: I want to trap this to send the appropriate bunch of ReCategorization events, but ClassOrganizer instances do not know where they belong to (what class, or what system); it just uses symbols. So I cannot trigger the change, because not enough information is available. This is a conceptual problem: the organization is stand-alone implementation-wise, while conceptually it belongs to a class. The clean solution could be to reroute this message to a class, but this does not work for all of the senders (that would work from the browserm but not for the file-in). Browser>>#categorizeAllUncategorizedMethods Problem: should be trapped to send a ReCategorization event. However, this is model code that should not be in the Browser. Clean solution is to move it out of there to the model, and then trap it there (or reroute it to one of the trapped places). Note: Debugger>>#contents:notifying: recompiles methods when needed, so I trapped it to get updates. However, I need to find a way to write a unit test for this. Haven't gotten around yet for doing this though... "! ! Object subclass: #AbstractFont instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Graphics-Fonts'! !AbstractFont commentStamp: '' prior: 0! AbstractFont defines the generic interface that all fonts need to implement.! !AbstractFont methodsFor: '*FreeType-addition' stamp: 'tween 7/29/2006 14:36'! displayStrikeoutOn: aDisplayContext from: baselineStartPoint to: baselineEndPoint "display the strikeout if appropriate for the receiver"! ! !AbstractFont methodsFor: '*FreeType-addition' stamp: 'tween 7/29/2006 13:51'! displayUnderlineOn: aDisplayContext from: baselineStartPoint to: baselineEndPoint "display the underline if appropriate for the receiver"! ! !AbstractFont methodsFor: '*FreeType-addition' stamp: 'tween 8/10/2006 07:16'! emphasisString "Answer a translated string that represents the receiver's emphasis." ^self emphasisStringFor: self emphasis! ! !AbstractFont methodsFor: '*FreeType-addition' stamp: 'tween 8/10/2006 07:13'! emphasisStringFor: emphasisCode "Answer a translated string that represents the attributes given in emphasisCode." ^self class emphasisStringFor: emphasisCode! ! !AbstractFont methodsFor: '*FreeType-addition' stamp: 'tween 3/29/2007 13:43'! hasDistinctGlyphsForAll: asciiString "Answer true if the receiver has glyphs for all the characters in asciiString and no single glyph is shared by more than one character, false otherwise. The default behaviour is to answer true, but subclasses may reimplement" ^true! ! !AbstractFont methodsFor: '*FreeType-addition' stamp: 'tween 3/29/2007 13:25'! hasGlyphsForAll: asciiString "Answer true if the receiver has glyphs for all the characters in asciiString, false otherwise. The default behaviour is to answer true, but subclasses may reimplement" ^true! ! !AbstractFont methodsFor: '*FreeType-addition' stamp: 'tween 4/6/2007 12:58'! isSubPixelPositioned "Answer true if the receiver is currently using subpixel positioned glyphs, false otherwise. This affects how padded space sizes are calculated when composing text. Currently, only FreeTypeFonts are subPixelPositioned, and only when not Hinted" ^false ! ! !AbstractFont methodsFor: '*FreeType-addition' stamp: 'tween 3/29/2007 13:32'! isSymbolFont "Answer true if the receiver is a Symbol font, false otherwise. The default is to answer false, subclasses can reimplement" ^false! ! !AbstractFont methodsFor: '*FreeType-addition' stamp: 'tween 3/10/2007 13:08'! kerningLeft: leftChar right: rightChar ^0! ! !AbstractFont methodsFor: '*FreeType-addition' stamp: 'tween 3/31/2007 20:17'! linearWidthOf: aCharacter "This is the scaled, unrounded advance width." ^self widthOf: aCharacter! ! !AbstractFont methodsFor: '*FreeType-addition' stamp: 'tween 4/3/2007 16:47'! widthAndKernedWidthOfLeft: leftCharacter right: rightCharacterOrNil into: aTwoElementArray "Set the first element of aTwoElementArray to the width of leftCharacter and the second element to the width of left character when kerned with rightCharacterOrNil. Answer aTwoElementArray" | w k | w := self widthOf: leftCharacter. rightCharacterOrNil isNil ifTrue:[ aTwoElementArray at: 1 put: w; at: 2 put: w] ifFalse:[ k := self kerningLeft: leftCharacter right: rightCharacterOrNil. aTwoElementArray at: 1 put: w; at: 2 put: w+k]. ^aTwoElementArray ! ! !AbstractFont methodsFor: 'accessing' stamp: 'yo 1/7/2005 11:19'! ascent self subclassResponsibility. ! ! !AbstractFont methodsFor: 'accessing' stamp: 'yo 1/7/2005 11:18'! ascentOf: aCharacter ^ self ascent. ! ! !AbstractFont methodsFor: 'accessing' stamp: 'nk 4/2/2004 11:06'! baseKern ^0! ! !AbstractFont methodsFor: 'accessing' stamp: 'yo 1/7/2005 11:18'! basicAscentOf: aCharacter ^ self ascent. ! ! !AbstractFont methodsFor: 'accessing' stamp: 'yo 1/7/2005 11:19'! basicDescentOf: aCharacter ^ self descent. ! ! !AbstractFont methodsFor: 'accessing' stamp: 'ar 5/19/2000 14:56'! characterToGlyphMap "Return the character to glyph mapping table. If the table is not provided the character scanner will query the font directly for the width of each individual character." ^nil! ! !AbstractFont methodsFor: 'accessing' stamp: 'nk 3/15/2004 18:57'! derivativeFonts ^#()! ! !AbstractFont methodsFor: 'accessing' stamp: 'yo 1/7/2005 11:20'! descent self subclassResponsibility. ! ! !AbstractFont methodsFor: 'accessing' stamp: 'yo 1/7/2005 11:20'! descentOf: aCharacter ^ self descent. ! ! !AbstractFont methodsFor: 'accessing' stamp: 'nk 8/31/2004 09:15'! familyName "Answer the name to be used as a key in the TextConstants dictionary." ^self subclassResponsibility! ! !AbstractFont methodsFor: 'accessing' stamp: 'nk 8/31/2004 09:14'! height "Answer the height of the receiver, total of maximum extents of characters above and below the baseline." ^self subclassResponsibility! ! !AbstractFont methodsFor: 'accessing' stamp: 'nk 5/26/2003 09:45'! isRegular ^false! ! !AbstractFont methodsFor: 'accessing' stamp: 'nk 8/31/2004 09:14'! lineGrid "Answer the relative space between lines" ^self subclassResponsibility! ! !AbstractFont methodsFor: 'accessing' stamp: 'nk 4/2/2004 11:33'! pixelSize "Make sure that we don't return a Fraction" ^ TextStyle pointsToPixels: self pointSize! ! !AbstractFont methodsFor: 'accessing' stamp: 'nk 4/1/2004 10:48'! pointSize self subclassResponsibility.! ! !AbstractFont methodsFor: 'accessing' stamp: 'nk 7/11/2004 21:15'! textStyle ^ TextStyle actualTextStyles detect: [:aStyle | aStyle fontArray includes: self] ifNone: [ TextStyle fontArray: { self } ]! ! !AbstractFont methodsFor: 'accessing' stamp: 'nk 3/22/2004 15:15'! textStyleName "Answer the name to be used as a key in the TextConstants dictionary." ^self familyName! ! !AbstractFont methodsFor: 'accessing' stamp: 'ar 5/19/2000 14:57'! xTable "Return the xTable for the font. The xTable defines the left x-value for each individual glyph in the receiver. If such a table is not provided, the character scanner will ask the font directly for the appropriate width of each individual character." ^nil! ! !AbstractFont methodsFor: 'caching' stamp: 'nk 3/15/2004 18:47'! releaseCachedState ! ! !AbstractFont methodsFor: 'displaying' stamp: 'ar 5/19/2000 14:59'! displayString: aString on: aDisplayContext from: startIndex to: stopIndex at: aPoint kern: kernDelta "Draw the given string from startIndex to stopIndex at aPoint on the (already prepared) display context." ^self subclassResponsibility! ! !AbstractFont methodsFor: 'displaying' stamp: 'yo 1/7/2005 11:36'! displayString: aString on: aDisplayContext from: startIndex to: stopIndex at: aPoint kern: kernDelta baselineY: baselineY "Draw the given string from startIndex to stopIndex at aPoint on the (already prepared) display context." ^self subclassResponsibility! ! !AbstractFont methodsFor: 'displaying' stamp: 'ar 5/19/2000 14:59'! installOn: aDisplayContext foregroundColor: foregroundColor backgroundColor: backgroundColor "Install the receiver on the given DisplayContext (either BitBlt or Canvas) for further drawing operations." ^self subclassResponsibility! ! !AbstractFont methodsFor: 'measuring' stamp: 'lr 7/4/2009 10:42'! approxWidthOfText: aText "Return the width of aText -- quickly, and a little bit dirty. Used by lists morphs containing Text objects to get a quick, fairly accurate measure of the width of a list item." | w | (aText isNil or: [ aText size == 0 ]) ifTrue: [ ^ 0 ]. w := self widthOfString: aText asString. "If the text has no emphasis, just return the string size. If it is empasized, just approximate the width by adding about 20% to the width" ((aText runLengthFor: 1) == aText size and: [ (aText emphasisAt: 1) == 0 ]) ifTrue: [ ^ w ] ifFalse: [ ^ w * 6 // 5 ]! ! !AbstractFont methodsFor: 'measuring' stamp: 'ar 5/19/2000 14:58'! widthOf: aCharacter "Return the width of the given character" ^self subclassResponsibility! ! !AbstractFont methodsFor: 'measuring' stamp: 'ar 12/31/2001 14:25'! widthOfString: aString aString ifNil:[^0]. ^self widthOfString: aString from: 1 to: aString size. " TextStyle default defaultFont widthOfString: 'zort' 21 "! ! !AbstractFont methodsFor: 'measuring' stamp: 'lr 7/4/2009 10:42'! widthOfString: aString from: startIndex to: stopIndex "Measure the length of the given string between start and stop index" | character resultX | resultX := 0. startIndex to: stopIndex do: [ :i | character := aString at: i. resultX := resultX + (self widthOf: character) ]. ^ resultX! ! !AbstractFont methodsFor: 'measuring' stamp: 'sps 3/23/2004 15:50'! widthOfStringOrText: aStringOrText aStringOrText ifNil:[^0]. ^aStringOrText isText ifTrue:[self approxWidthOfText: aStringOrText ] ifFalse:[self widthOfString: aStringOrText ] ! ! !AbstractFont methodsFor: 'notifications' stamp: 'nk 4/2/2004 11:25'! pixelsPerInchChanged "The definition of TextStyle class>>pixelsPerInch has changed. Do whatever is necessary."! ! !AbstractFont methodsFor: 'testing' stamp: 'yo 2/12/2007 19:34'! isFontSet ^ false. ! ! !AbstractFont methodsFor: 'testing' stamp: 'nk 6/25/2003 12:54'! isTTCFont ^false! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AbstractFont class instanceVariableNames: ''! !AbstractFont class methodsFor: 'as yet unclassified' stamp: 'eem 6/11/2008 12:35'! emphasisStringFor: emphasisCode "Answer a translated string that represents the attributes given in emphasisCode." | emphases | emphasisCode = 0 ifTrue: [ ^'Normal' translated ]. emphases := (IdentityDictionary new) at: 1 put: 'Bold' translated; at: 2 put: 'Italic' translated; at: 4 put: 'Underlined' translated; at: 8 put: 'Narrow' translated; at: 16 put: 'StruckOut' translated; yourself. ^String streamContents: [ :s | | bit | bit := 1. [ bit < 32 ] whileTrue: [ | code | code := emphasisCode bitAnd: bit. code isZero ifFalse: [ s nextPutAll: (emphases at: code); space ]. bit := bit bitShift: 1 ]. s position isZero ifFalse: [ s skip: -1 ]. ]! ! DialogWindow subclass: #AbstractFontSelectorDialogWindow instanceVariableNames: 'fontFamilies selectedFont textPreviewMorph fontFamilyIndex fontSizeIndex isBold isItalic isUnderlined isStruckOut previewText' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Widgets-Windows'! !AbstractFontSelectorDialogWindow commentStamp: 'gvc 5/18/2007 13:04' prior: 0! Dialog based font chooser with preview.! !AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 5/3/2007 15:40'! fontFamilies "Answer the set of available fonts families that are supported as Text objects in the font that they represent." ^fontFamilies ifNil: [ self fontFamilies: self defaultFontFamilies. fontFamilies]! ! !AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 5/3/2007 15:02'! fontFamilies: anObject "Set the value of fontFamilies" fontFamilies := anObject! ! !AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 5/3/2007 14:30'! fontFamilyIndex "Answer the value of fontFamilyIndex" ^ fontFamilyIndex! ! !AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 5/3/2007 15:19'! fontFamilyIndex: anObject "Set the value of fontFamilyIndex" fontFamilyIndex := anObject. self updateSelectedFont! ! !AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 5/3/2007 14:30'! fontSizeIndex "Answer the value of fontSizeIndex" ^ fontSizeIndex! ! !AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 5/3/2007 15:19'! fontSizeIndex: anObject "Set the value of fontSizeIndex" fontSizeIndex := anObject. self updateSelectedFont! ! !AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 5/3/2007 15:12'! isBold "Answer the value of isBold" ^ isBold! ! !AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 4/21/2009 17:07'! isBold: anObject "Set the value of isBold" isBold := anObject. self changed: #isBold! ! !AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 5/3/2007 15:12'! isItalic "Answer the value of isItalic" ^ isItalic! ! !AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 4/21/2009 17:07'! isItalic: anObject "Set the value of isItalic" isItalic := anObject. self changed: #isItalic! ! !AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 5/3/2007 15:12'! isStruckOut "Answer the value of isStruckOut" ^ isStruckOut! ! !AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 4/21/2009 17:07'! isStruckOut: anObject "Set the value of isStruckOut" isStruckOut := anObject. self changed: #isStruckOut! ! !AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 5/3/2007 15:12'! isUnderlined "Answer the value of isUnderlined" ^ isUnderlined! ! !AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 4/21/2009 17:07'! isUnderlined: anObject "Set the value of isUnderlined" isUnderlined := anObject. self changed: #isUnderlined! ! !AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 4/21/2009 17:30'! previewText "Answer the value of previewText" ^previewText asText addAttribute: (TextEmphasis new emphasisCode: self textEmphasisCode)! ! !AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 5/18/2007 13:07'! previewText: anObject "Set the value of previewText" previewText := anObject. self changed: #previewText! ! !AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 5/3/2007 13:41'! selectedFont "Answer the value of selectedFont" ^ selectedFont! ! !AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 10/9/2007 14:19'! selectedFont: anObject "Set the value of selectedFont" selectedFont := anObject ifNil: [TextStyle defaultFont]. self updateFromSelectedFont! ! !AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 5/3/2007 13:41'! textPreviewMorph "Answer the value of textPreviewMorph" ^ textPreviewMorph! ! !AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 5/3/2007 13:41'! textPreviewMorph: anObject "Set the value of textPreviewMorph" textPreviewMorph := anObject! ! !AbstractFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 9/26/2008 15:49'! defaultFontFamilies "Answer the set of available fonts families that are supported in the font that they represent." self subclassResponsibility! ! !AbstractFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 9/26/2008 15:31'! defaultPreviewText "Answer the default text to use for the preview of the font." ^(33 to: 127) asByteArray asString! ! !AbstractFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 5/3/2007 15:47'! familyName "Answer the selected family name or nil if none." (self fontFamilyIndex between: 1 and: self fontFamilies size) ifFalse: [^nil]. ^(self fontFamilies at: self fontFamilyIndex) asString! ! !AbstractFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 5/3/2007 16:03'! fontSize "Answer the selected font size or nil if none." (self fontSizeIndex between: 1 and: self fontSizes size) ifFalse: [^nil]. ^self fontSizes at: self fontSizeIndex! ! !AbstractFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 5/3/2007 14:31'! fontSizes "Answer the set of available fonts sizes that are supported." ^#(6 7 8 9 10 11 12 13 14 15 16 18 20 21 22 24 26 28 32 36 48)! ! !AbstractFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 4/21/2009 17:22'! initialize "Initialize the receiver." self isBold: false; isItalic: false; isUnderlined: false; isStruckOut: false; previewText: self defaultPreviewText; fontFamilyIndex: 0; fontSizeIndex: 0. super initialize! ! !AbstractFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 7/16/2007 13:43'! isFreeTypeInstalled "Answer whether FreeType appears to be installed." ^Smalltalk includesKey: #FreeTypeFont! ! !AbstractFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 9/26/2008 15:35'! matchingFont "Answer the font that matches the selections." self subclassResponsibility! ! !AbstractFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 4/21/2009 17:02'! newBoldButtonMorph "Answer a button for the boldness of the font." ^self newButtonFor: self getState: #isBold action: #toggleBold arguments: nil getEnabled: nil labelForm: self theme smallBoldIcon help: 'Toggle bold font' translated! ! !AbstractFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 4/21/2009 17:48'! newContentMorph "Answer a new content morph." self textPreviewMorph: self newTextPreviewMorph. ^(self newColumn: { (self newRow: { self newGroupbox: 'Family' translated for: self newFontFamilyMorph. (self newColumn: { (self newGroupbox: 'Style' translated for: self newFontStyleButtonRowMorph) vResizing: #shrinkWrap. self newGroupbox: 'Point size' translated for: self newFontSizeMorph}) hResizing: #shrinkWrap}) vResizing: #spaceFill. (self newGroupbox: 'Preview' translated for: self textPreviewMorph) vResizing: #shrinkWrap}) minWidth: 350; minHeight: 400! ! !AbstractFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 8/7/2007 11:49'! newFontFamilyMorph "Answer a list for the font family of the font." |highestFont| highestFont := self fontFamilies first fontAt: 1 withStyle: TextStyle default. self fontFamilies do: [:ff | |f| f := ff fontAt: 1 withStyle: TextStyle default. f height > highestFont height ifTrue: [highestFont := f]]. ^(self newListFor: self list: #fontFamilies selected: #fontFamilyIndex changeSelected: #fontFamilyIndex: help: nil) font: highestFont! ! !AbstractFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 8/7/2007 11:49'! newFontSizeMorph "Answer a list for the font size of the font." ^self newListFor: self list: #fontSizes selected: #fontSizeIndex changeSelected: #fontSizeIndex: help: nil! ! !AbstractFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 4/21/2009 17:48'! newFontStyleButtonRowMorph "Answer a new font style button row morph." ^self newRow: { self newBoldButtonMorph. self newItalicButtonMorph. self newUnderlinedButtonMorph. self newStruckOutButtonMorph}! ! !AbstractFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 4/21/2009 17:02'! newItalicButtonMorph "Answer a button for the italic emphasis of the font." ^self newButtonFor: self getState: #isItalic action: #toggleItalic arguments: nil getEnabled: nil labelForm: self theme smallItalicIcon help: 'Toggle italic font' translated! ! !AbstractFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 4/21/2009 17:02'! newStruckOutButtonMorph "Answer a button for the struck out emphasis of the font." ^self newButtonFor: self getState: #isStruckOut action: #toggleStruckOut arguments: nil getEnabled: nil labelForm: self theme smallStrikeOutIcon help: 'Toggle struck-out font' translated! ! !AbstractFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 5/3/2007 16:31'! newTextPreviewMorph "Answer a text entry morph for the preview of the font." ^(self newTextEditorFor: self getText: #previewText setText: nil getEnabled: nil) vResizing: #rigid; enabled: false; extent: 20@90! ! !AbstractFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 4/21/2009 17:02'! newUnderlinedButtonMorph "Answer a button for the italic emphasis of the font." ^self newButtonFor: self getState: #isUnderlined action: #toggleUnderlined arguments: nil getEnabled: nil labelForm: self theme smallUnderlineIcon help: 'Toggle underlined font' translated! ! !AbstractFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 4/21/2009 17:33'! textEmphasisCode "Answer the current bitmask for the text emphasis." ^(((self isBold ifTrue: [1] ifFalse: [0]) bitOr: (self isItalic ifTrue: [2] ifFalse: [0])) bitOr: (self isUnderlined ifTrue: [4] ifFalse: [0])) bitOr: (self isStruckOut ifTrue: [16] ifFalse: [0])! ! !AbstractFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 5/3/2007 15:31'! toggleBold "Toggle the font bold emphasis." self isBold: self isBold not. self updateSelectedFont! ! !AbstractFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 5/3/2007 15:31'! toggleItalic "Toggle the font italic emphasis." self isItalic: self isItalic not. self updateSelectedFont! ! !AbstractFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 5/3/2007 15:31'! toggleStruckOut "Toggle the font struck out emphasis." self isStruckOut: self isStruckOut not. self updateSelectedFont! ! !AbstractFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 5/3/2007 15:31'! toggleUnderlined "Toggle the font underlined emphasis." self isUnderlined: self isUnderlined not. self updateSelectedFont! ! !AbstractFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 4/21/2009 17:21'! updateFromSelectedFont "Update our state based on the selected font." self subclassResponsibility! ! !AbstractFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 5/4/2007 10:25'! updateSelectedFont "Update the selected font to reflect the choices." self selectedFont: self matchingFont! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AbstractFontSelectorDialogWindow class instanceVariableNames: ''! !AbstractFontSelectorDialogWindow class methodsFor: 'as yet unclassified' stamp: 'gvc 5/21/2007 12:42'! taskbarIcon "Answer the icon for the receiver in a task bar." ^MenuIcons smallFontsIcon! ! Model subclass: #AbstractHierarchicalList instanceVariableNames: 'currentSelection' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Explorer'! !AbstractHierarchicalList commentStamp: '' prior: 0! Contributed by Bob Arning as part of the ObjectExplorer package. ! !AbstractHierarchicalList methodsFor: 'as yet unclassified' stamp: 'RAA 6/21/1999 15:22'! genericMenu: aMenu aMenu add: 'no menu yet' target: self selector: #yourself. ^aMenu! ! !AbstractHierarchicalList methodsFor: 'as yet unclassified' stamp: 'RAA 4/7/1999 16:44'! getCurrentSelection ^currentSelection! ! !AbstractHierarchicalList methodsFor: 'as yet unclassified' stamp: 'RAA 4/7/1999 16:46'! noteNewSelection: x currentSelection := x. self changed: #getCurrentSelection. currentSelection ifNil: [^self]. currentSelection sendSettingMessageTo: self. ! ! !AbstractHierarchicalList methodsFor: 'as yet unclassified' stamp: 'RAA 4/7/1999 16:53'! perform: selector orSendTo: otherTarget "Selector was just chosen from a menu by a user. If can respond, then perform it on myself. If not, send it to otherTarget, presumably the editPane from which the menu was invoked." (self respondsTo: selector) ifTrue: [^ self perform: selector] ifFalse: [^ otherTarget perform: selector]! ! !AbstractHierarchicalList methodsFor: 'as yet unclassified' stamp: 'RAA 4/7/1999 16:47'! update: aSymbol aSymbol == #hierarchicalList ifTrue: [ ^self changed: #getList ]. super update: aSymbol! ! Object subclass: #AbstractLauncher instanceVariableNames: 'parameters' classVariableNames: '' poolDictionaries: '' category: 'System-Support'! !AbstractLauncher commentStamp: '' prior: 0! The class AutoStart in combination with the Launcher classes provides a mechanism for starting Squeak from the command line or a web page. Parameters on the command line or in the embed tag in the web page a parsed and stored in the lauchner's parameter dictionary. Subclasses can access these parameters to determine what to do. CommandLineLauncherExample provides an example for a command line application. if you start squeak with a command line 'class Integer' it will launch a class browser on class Integer. To enable this execute CommandLineLauncherExample activate before you save the image. To disable execute CommandLineLauncherExample deactivate The PluginLauchner is an example how to use this framework to start Squeak as a browser plugin. It looks for a parameter 'src' which should point to a file containing a squeak script.! !AbstractLauncher methodsFor: 'running' stamp: 'tk 10/24/2001 06:40'! startUp "A backstop for subclasses. Note that this is not a class message (most startUps are class messages)." ! ! !AbstractLauncher methodsFor: 'private' stamp: 'dc 5/30/2008 10:17'! commandLine: aString "Start up this launcher from within Squeak as if it Squeak been launched the given command line." | dict tokens cmd arg | dict := Dictionary new. tokens := (aString findTokens: ' ') readStream. [ cmd := tokens next. arg := tokens next. cmd ~~ nil and: [ arg ~~ nil ] ] whileTrue: [ dict at: cmd put: arg ]. self parameters: dict. self startUp! ! !AbstractLauncher methodsFor: 'private' stamp: 'mir 9/23/1999 13:18'! determineParameterNameFrom: alternateParameterNames "Determine which of the given alternate parameter names is actually used." ^alternateParameterNames detect: [:each | self includesParameter: each asUppercase] ifNone: [nil] ! ! !AbstractLauncher methodsFor: 'private' stamp: 'mir 1/11/2000 16:35'! includesParameter: parName "Return if the parameter named parName exists." ^self parameters includesKey: parName asUppercase! ! !AbstractLauncher methodsFor: 'private' stamp: 'mdr 4/10/2001 10:50'! numericParameterAtOneOf: alternateParameterNames ifAbsent: aBlock "Return the parameter named using one of the alternate names or an empty string" | parameterValue | parameterValue := self parameterAtOneOf: alternateParameterNames. parameterValue isEmpty ifTrue: [^aBlock value]. ^[Number readFrom: parameterValue] ifError: aBlock ! ! !AbstractLauncher methodsFor: 'private' stamp: 'mir 8/4/1999 14:19'! parameterAt: parName "Return the parameter named parName or an empty string" ^self parameterAt: parName ifAbsent: ['']! ! !AbstractLauncher methodsFor: 'private' stamp: 'mir 1/11/2000 16:36'! parameterAt: parName ifAbsent: aBlock "Return the parameter named parName. Evaluate the block if parameter does not exist." ^self parameters at: parName asUppercase ifAbsent: [aBlock value]! ! !AbstractLauncher methodsFor: 'private' stamp: 'mir 9/23/1999 12:09'! parameterAtOneOf: alternateParameterNames | parameterName | "Return the parameter named using one of the alternate names or an empty string" parameterName := self determineParameterNameFrom: alternateParameterNames. ^parameterName isNil ifTrue: [''] ifFalse: [self parameterAt: parameterName ifAbsent: ['']]! ! !AbstractLauncher methodsFor: 'private' stamp: 'marcus.denker 9/14/2008 18:54'! parameters parameters ifNil: [parameters := self class extractParameters]. ^parameters! ! !AbstractLauncher methodsFor: 'private' stamp: 'mir 7/29/1999 10:21'! parameters: startupParameters parameters := startupParameters! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AbstractLauncher class instanceVariableNames: ''! !AbstractLauncher class methodsFor: 'activation' stamp: 'mir 8/6/1999 18:14'! activate "Register this launcher with the auto start class" self autoStarter addLauncher: self! ! !AbstractLauncher class methodsFor: 'activation'! deactivate "Unregister this launcher with the auto start class" self autoStarter removeLauncher: self! ! !AbstractLauncher class methodsFor: 'private' stamp: 'mir 8/4/1999 13:57'! autoStarter ^AutoStart! ! !AbstractLauncher class methodsFor: 'private' stamp: 'sd 9/30/2003 13:55'! extractParameters ^ SmalltalkImage current extractParameters! ! Object subclass: #AbstractObjectsAsMethod instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Tests-ObjectsAsMethods'! !AbstractObjectsAsMethod methodsFor: 'as yet unclassified' stamp: 'md 3/1/2006 14:25'! flushCache! ! !AbstractObjectsAsMethod methodsFor: 'as yet unclassified' stamp: 'md 3/1/2006 14:23'! methodClass: aMethodClass! ! !AbstractObjectsAsMethod methodsFor: 'as yet unclassified' stamp: 'md 3/1/2006 14:23'! selector: aSymbol! ! Morph subclass: #AbstractResizerMorph instanceVariableNames: 'dotColor handleColor lastMouse' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Windows'! !AbstractResizerMorph commentStamp: 'jmv 1/29/2006 17:15' prior: 0! I am the superclass of a hierarchy of morph specialized in allowing the user to resize or rearrange windows and panes.! !AbstractResizerMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 3/27/2008 21:34'! adoptPaneColor: paneColor "Just get the resizer fill style for the theme." paneColor ifNil: [^super adoptPaneColor: paneColor]. self fillStyle: (self theme resizerGripNormalFillStyleFor: self)! ! !AbstractResizerMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 3/12/2007 10:59'! mouseUp: anEvent "Change the cursor back to normal if necessary." (self bounds containsPoint: anEvent cursorPoint) ifFalse: [ anEvent hand showTemporaryCursor: nil. self setDefaultColors; changed]! ! !AbstractResizerMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 5/13/2008 10:20'! shouldDraw "Answer whether the resizer should be drawn." ^self fillStyle isTransparent not! ! !AbstractResizerMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 5/13/2008 10:35'! shouldInvalidateOnMouseTransition "Answer whether the resizer should be invalidated when the mouse enters or leaves." ^false! ! !AbstractResizerMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 5/13/2008 10:36'! mouseEnter: anEvent self isCursorOverHandle ifTrue: [self setInverseColors. self shouldInvalidateOnMouseTransition ifTrue: [self changed]. "avoid unnecessary invalidation" anEvent hand showTemporaryCursor: self resizeCursor]! ! !AbstractResizerMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 5/13/2008 10:36'! mouseLeave: anEvent anEvent hand showTemporaryCursor: nil. self setDefaultColors. self shouldInvalidateOnMouseTransition ifTrue: [self changed]. "avoid unnecessary invalidation"! ! !AbstractResizerMorph methodsFor: 'as yet unclassified' stamp: 'jrp 7/5/2005 21:36'! dotColor ^ dotColor ifNil: [self setDefaultColors. dotColor]! ! !AbstractResizerMorph methodsFor: 'as yet unclassified' stamp: 'jrp 7/5/2005 21:35'! handleColor ^ handleColor ifNil: [self setDefaultColors. handleColor]! ! !AbstractResizerMorph methodsFor: 'as yet unclassified' stamp: 'jrp 7/5/2005 21:37'! handlesMouseDown: anEvent ^ true! ! !AbstractResizerMorph methodsFor: 'as yet unclassified' stamp: 'jrp 7/5/2005 21:37'! handlesMouseOver: anEvent ^ true ! ! !AbstractResizerMorph methodsFor: 'as yet unclassified' stamp: 'md 2/24/2006 23:01'! initialize super initialize. self color: Color transparent! ! !AbstractResizerMorph methodsFor: 'as yet unclassified' stamp: 'jrp 7/5/2005 21:40'! isCursorOverHandle ^ true! ! !AbstractResizerMorph methodsFor: 'as yet unclassified' stamp: 'jrp 7/5/2005 21:42'! mouseDown: anEvent lastMouse := anEvent cursorPoint! ! !AbstractResizerMorph methodsFor: 'as yet unclassified' stamp: 'jrp 7/5/2005 21:37'! resizeCursor self subclassResponsibility! ! !AbstractResizerMorph methodsFor: 'as yet unclassified' stamp: 'jrp 7/29/2005 13:25'! setDefaultColors handleColor := Color lightGray lighter lighter. dotColor := Color gray lighter! ! !AbstractResizerMorph methodsFor: 'as yet unclassified' stamp: 'jrp 7/30/2005 21:30'! setInverseColors handleColor := Color lightGray. dotColor := Color white! ! Object subclass: #AbstractSoundSystem instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'System-Support'! !AbstractSoundSystem commentStamp: 'gk 2/24/2004 08:34' prior: 0! This is the abstract base class for a sound system. A sound system offers a small protocol for playing sounds and making beeps and works like a facade towards the rest of Squeak. A sound system is registered in the application registry SoundService and can be accessed by "SoundService default" like for example: SoundService default playSoundNamed: 'croak' The idea is that as much sound playing as possible should go through this facade. This way we decouple the sound system from the rest of Squeak and make it pluggable. It also is a perfect spot to check for the Preference class>>soundsEnabled. Two basic subclasses exist at the time of this writing, the BaseSoundSystem which represents the standard Squeak sound system, and the DummySoundSystem which is a dummy implementation that can be used when there is no sound card available, or when the base sound system isn't in the image, or when you simply don't want to use the available sound card.! !AbstractSoundSystem methodsFor: 'misc' stamp: 'gk 2/23/2004 19:52'! randomBitsFromSoundInput: bitCount self subclassResponsibility! ! !AbstractSoundSystem methodsFor: 'misc' stamp: 'gk 2/23/2004 19:52'! sampledSoundChoices self subclassResponsibility! ! !AbstractSoundSystem methodsFor: 'misc' stamp: 'gk 2/23/2004 19:53'! shutDown "Default is to do nothing."! ! !AbstractSoundSystem methodsFor: 'misc' stamp: 'gk 2/23/2004 19:56'! soundNamed: soundName self subclassResponsibility! ! !AbstractSoundSystem methodsFor: 'playing' stamp: 'gk 2/24/2004 23:27'! beep "Make a primitive beep." self subclassResponsibility! ! !AbstractSoundSystem methodsFor: 'playing' stamp: 'gk 2/23/2004 19:47'! playSampledSound: samples rate: rate self subclassResponsibility! ! !AbstractSoundSystem methodsFor: 'playing' stamp: 'gk 2/23/2004 19:50'! playSoundNamed: soundName self subclassResponsibility! ! !AbstractSoundSystem methodsFor: 'playing' stamp: 'gk 2/23/2004 19:51'! playSoundNamed: soundName ifAbsentReadFrom: aifFileName self subclassResponsibility! ! !AbstractSoundSystem methodsFor: 'playing' stamp: 'gk 2/23/2004 19:51'! playSoundNamedOrBeep: soundName self subclassResponsibility! ! PluggableTextMorph subclass: #AcceptableCleanTextMorph instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Pluggable Widgets'! !AcceptableCleanTextMorph methodsFor: 'menu commands' stamp: 'dgd 2/21/2003 22:50'! accept "Overridden to allow accept of clean text" | textToAccept ok | textToAccept := textMorph asText. ok := setTextSelector isNil or: [setTextSelector numArgs = 2 ifTrue: [model perform: setTextSelector with: textToAccept with: self] ifFalse: [model perform: setTextSelector with: textToAccept]]. ok ifTrue: [self setText: self getText. self hasUnacceptedEdits: false]! ! FileDirectory subclass: #AcornFileDirectory instanceVariableNames: '' classVariableNames: 'LegalCharMap' poolDictionaries: '' category: 'Files-Directories'! !AcornFileDirectory methodsFor: 'file name utilities' stamp: 'stephaneducasse 2/4/2006 20:31'! checkName: aFileName fixErrors: fixing "Check if the file name contains any invalid characters" | fName hasBadChars correctedName newChar| fName := super checkName: aFileName fixErrors: fixing. correctedName := String streamContents:[:s| fName do:[:c| (newChar := LegalCharMap at: c asciiValue +1) ifNotNil:[s nextPut: newChar]]]. hasBadChars := fName ~= correctedName. (hasBadChars and:[fixing not]) ifTrue:[^self error:'Invalid file name']. hasBadChars ifFalse:[^ fName]. ^ correctedName! ! !AcornFileDirectory methodsFor: 'file name utilities' stamp: 'tpr 11/5/2004 13:08'! fullPathFor: path "if the arg is an empty string, just return my path name converted via the language stuff. If the arg seems to be a rooted path, return it raw, assuming it is already ok. Otherwise cons up a path" path isEmpty ifTrue:[^pathName asSqueakPathName]. ((path includes: $$ ) or:[path includes: $:]) ifTrue:[^path]. ^pathName asSqueakPathName, self slash, path! ! !AcornFileDirectory methodsFor: 'path access' stamp: 'tpr 11/30/2003 21:42'! pathParts "Return the path from the root of the file system to this directory as an array of directory names. This version tries to cope with the RISC OS' strange filename formatting; filesystem::discname/$/path/to/file where the $ needs to be considered part of the filingsystem-discname atom." | pathList | pathList := super pathParts. (pathList indexOf: '$') = 2 ifTrue: ["if the second atom is root ($) then stick $ on the first atom and drop the second. Yuck" ^ Array streamContents: [:a | a nextPut: (pathList at: 1), '/$'. 3 to: pathList size do: [:i | a nextPut: (pathList at: i)]]]. ^ pathList! ! !AcornFileDirectory methodsFor: 'testing' stamp: 'tpr 4/28/2004 21:54'! directoryExists: filenameOrPath "if the path is a root,we have to treat it carefully" (filenameOrPath endsWith: '$') ifTrue:[^(FileDirectory on: filenameOrPath) exists]. ^(self directoryNamed: filenameOrPath ) exists! ! !AcornFileDirectory methodsFor: 'private' stamp: 'stephaneducasse 2/4/2006 20:31'! directoryContentsFor: fullPath "Return a collection of directory entries for the files and directories in the directory with the given path. See primLookupEntryIn:index: for further details." "FileDirectory default directoryContentsFor: ''" | entries extraPath | entries := super directoryContentsFor: fullPath. fullPath isNullPath ifTrue: [ "For Acorn we also make sure that at least the parent of the current dir is added - sometimes this is in a filing system that has not been (or cannot be) polled for disc root names" extraPath := self class default containingDirectory. "Only add the extra path if we haven't already got the root of the current dir in the list" entries detect: [:ent | extraPath fullName beginsWith: ent name] ifNone: [entries := entries copyWith: (DirectoryEntry name: extraPath fullName creationTime: 0 modificationTime: 0 isDirectory: true fileSize: 0)]]. ^ entries ! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AcornFileDirectory class instanceVariableNames: ''! !AcornFileDirectory class methodsFor: '*network-uri' stamp: 'tpr 5/4/2005 17:22'! privateFullPathForURI: aURI "derive the full filepath from aURI" | first path | path := String streamContents: [ :s | first := false. aURI pathComponents do: [ :p | first ifTrue: [ s nextPut: self pathNameDelimiter ]. first := true. s nextPutAll: p ] ]. ^path unescapePercents ! ! !AcornFileDirectory class methodsFor: 'initialization' stamp: 'stephaneducasse 2/4/2006 20:32'! initialize "Set up the legal chars map for filenames. May need extending for unicode etc. Basic rule is that any char legal for use in filenames will have a non-nil entry in this array; except for space, this is the same character. Space is transcoded to a char 160 to be a 'hard space' " "AcornFileDirectory initialize" | aVal | LegalCharMap := Array new: 256. Character alphabet do:[:c| LegalCharMap at: c asciiValue +1 put: c. LegalCharMap at: (aVal := c asUppercase) asciiValue +1 put: aVal]. '`!!()-_=+[{]};~,./1234567890' do:[:c| LegalCharMap at: c asciiValue + 1 put: c]. LegalCharMap at: Character space asciiValue +1 put: (Character value:160 "hardspace"). LegalCharMap at: 161 put: (Character value:160 "hardspace")."secondary mapping to keep it in strings"! ! !AcornFileDirectory class methodsFor: 'platform specific' stamp: 'md 10/26/2003 13:16'! isActiveDirectoryClass "Does this class claim to be that properly active subclass of FileDirectory for the current platform? On Acorn, the test is whether platformName is 'RiscOS' (on newer VMs) or if the primPathNameDelimiter is $. (on older ones), which is what we would like to use for a dirsep if only it would work out. See pathNameDelimiter for more woeful details - then just get on and enjoy Squeak" ^ SmalltalkImage current platformName = 'RiscOS' or: [self primPathNameDelimiter = $.]! ! !AcornFileDirectory class methodsFor: 'platform specific' stamp: 'tpr 8/1/2003 16:38'! isCaseSensitive "Risc OS ignores the case of file names" ^ false! ! !AcornFileDirectory class methodsFor: 'platform specific' stamp: 'TPR 7/20/1999 17:52'! maxFileNameLength ^ 255 ! ! !AcornFileDirectory class methodsFor: 'platform specific' stamp: 'TPR 5/10/1998 21:45'! pathNameDelimiter "Acorn RiscOS uses a dot as the directory separator and has no real concept of filename extensions. We tried to make code handle this, but there are just too many uses of dot as a filename extension - so fake it out by pretending to use a slash. The file prims do conversions instead. Sad, but pragmatic" ^ $/ ! ! HostWindowProxy subclass: #AcornWindowProxy instanceVariableNames: 'flags' classVariableNames: 'BackButton CloseButton HasTitleBar IconiseButton ToggleSizeButton' poolDictionaries: '' category: 'Graphics-External-Ffenestri'! !AcornWindowProxy methodsFor: 'window decorations' stamp: 'tpr 10/6/2004 16:32'! addButton: buttonFlag "we need a button on the window. If there is already one, ignore this. If the host window does not yet exist we need only set the flag. If there is already a window, we will need to destroy the old window, add the flag and recreate" "do we already have a button? - if so just return" (self hasButton: buttonFlag) ifTrue:[^self]. "add the close button flag" self addFlag: buttonFlag. "note that we have a titlebar in order for the button to exist" self addFlag: HasTitleBar. "if we have a window recreate it" self isOpen ifTrue:[self recreate]! ! !AcornWindowProxy methodsFor: 'window decorations' stamp: 'tpr 10/6/2004 15:01'! addCloseButton "we need a close button on the window. If there is already one, ignore this. If the host window does not yet exist we need only set the flag. If there is already a window, we will need to destroy the old window, add the flag and recreate" ^self addButton: CloseButton! ! !AcornWindowProxy methodsFor: 'window decorations' stamp: 'lr 7/4/2009 10:42'! addFlag: flagVal "add flagVal to the flags" flags ifNil: [ flags := 0 ]. flags := flags bitOr: flagVal! ! !AcornWindowProxy methodsFor: 'window decorations' stamp: 'tpr 10/6/2004 15:01'! addIconiseButton "we need a iconise button on the window. If there is already one, ignore this. If the host window does not yet exist we need only set the flag. If there is already a window, we will need to destroy the old window, add the flag and recreate" ^self addButton: IconiseButton! ! !AcornWindowProxy methodsFor: 'window decorations' stamp: 'tpr 10/6/2004 15:25'! addToggleSizeButton "we need a toggle size button on the window. If there is already one, ignore this. If the host window does not yet exist we need only set the flag. If there is already a window, we will need to destroy the old window, add the flag and recreate" ^self addButton: ToggleSizeButton! ! !AcornWindowProxy methodsFor: 'window decorations' stamp: 'lr 7/4/2009 10:42'! attributes | val | ^ flags ifNil: [ super attributes ] ifNotNil: [ (val := ByteArray new: 4) longAt: 1 put: flags bigEndian: false. val ]! ! !AcornWindowProxy methodsFor: 'window decorations' stamp: 'tpr 10/7/2004 11:37'! defaultWindowType "set myself up for use as a normal window titlebar, close, iconise & size buttons" self addCloseButton; addIconiseButton; addToggleSizeButton! ! !AcornWindowProxy methodsFor: 'window decorations' stamp: 'tpr 10/6/2004 15:20'! hasButton: buttonFlag "do I have the button?" flags ifNil:[^false]. ^flags anyMask: buttonFlag! ! !AcornWindowProxy methodsFor: 'window decorations' stamp: 'tpr 10/11/2004 18:31'! hasTitleBar "do I have a title bar set?" ^self hasButton: HasTitleBar! ! !AcornWindowProxy methodsFor: 'window decorations' stamp: 'tpr 10/6/2004 16:33'! windowTitle: titleString "set the window title. If the window is open and doesn't already have a titlebar, add the title bar, recreate and set the title" (self isOpen and: [self hasTitleBar not]) ifTrue:[ "note that we have a titlebar in order for the title to exist" self addFlag: HasTitleBar. self recreate]. super windowTitle: titleString! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AcornWindowProxy class instanceVariableNames: ''! !AcornWindowProxy class methodsFor: 'class initialization' stamp: 'lr 7/4/2009 10:42'! initialize "AcornWindowProxy initialize" "Encode attributes in a 4byte ByteArary to be treated as an int in the vm" BackButton := 16777216. CloseButton := 33554432. IconiseButton := 0. "handled by OS completely independently" ToggleSizeButton := 134217728. HasTitleBar := 67108864! ! !AcornWindowProxy class methodsFor: 'system startup' stamp: 'tpr 10/1/2004 16:28'! isActiveHostWindowProxyClass "Am I active?" ^SmalltalkImage current platformName = 'RiscOS'! ! Array variableSubclass: #ActionSequence instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'System-Object Events'! !ActionSequence commentStamp: 'tlk 5/7/2006 20:02' prior: 0! An ActionSequence is an array that lists the object's dependant objects.! !ActionSequence methodsFor: 'converting' stamp: 'reThink 2/18/2001 15:12'! asActionSequence ^self! ! !ActionSequence methodsFor: 'converting' stamp: 'rw 7/20/2003 16:03'! asActionSequenceTrappingErrors ^WeakActionSequenceTrappingErrors withAll: self! ! !ActionSequence methodsFor: 'converting' stamp: 'reThink 2/18/2001 15:28'! asMinimalRepresentation self size = 0 ifTrue: [^nil]. self size = 1 ifTrue: [^self first]. ^self! ! !ActionSequence methodsFor: 'evaluating' stamp: 'reThink 2/18/2001 17:51'! value "Answer the result of evaluating the elements of the receiver." | answer | self do: [:each | answer := each value]. ^answer! ! !ActionSequence methodsFor: 'evaluating' stamp: 'reThink 2/18/2001 17:52'! valueWithArguments: anArray | answer | self do: [:each | answer := each valueWithArguments: anArray]. ^answer! ! !ActionSequence methodsFor: 'printing' stamp: 'SqR 07/28/2001 18:25'! printOn: aStream self size < 2 ifTrue: [^super printOn: aStream]. aStream nextPutAll: '#('. self do: [:each | each printOn: aStream] separatedBy: [aStream cr]. aStream nextPut: $)! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ActionSequence class instanceVariableNames: ''! AbstractEvent subclass: #AddedEvent instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'System-Change Notification'! !AddedEvent methodsFor: 'printing' stamp: 'rw 6/30/2003 09:31'! printEventKindOn: aStream aStream nextPutAll: 'Added'! ! !AddedEvent methodsFor: 'testing' stamp: 'rw 6/30/2003 08:35'! isAdded ^true! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AddedEvent class instanceVariableNames: ''! !AddedEvent class methodsFor: 'accessing' stamp: 'rw 7/19/2003 09:52'! changeKind ^#Added! ! !AddedEvent class methodsFor: 'accessing' stamp: 'NS 1/20/2004 12:22'! supportedKinds "All the kinds of items that this event can take." ^ Array with: self classKind with: self methodKind with: self categoryKind with: self protocolKind! ! Object variableSubclass: #AdditionalMethodState instanceVariableNames: 'method selector' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Methods'! !AdditionalMethodState commentStamp: '' prior: 0! I am class holding state for compiled methods. All my instance variables should be actually part of the CompiledMethod itself, but the current implementation of the VM doesn't allow this. Currently I hold the selector and any pragmas or properties the compiled method has. Pragmas and properties are stored in indexable fields; pragmas as instances of Pragma, properties as instances of Association. I am a reimplementation of much of MethodProperties, but eliminating the explicit properties and pragmas dictionaries. Hence I answer true to isMethodProperties.! !AdditionalMethodState methodsFor: 'testing' stamp: 'eem 11/27/2008 13:12'! analogousCodeTo: aMethodProperties | bs | (bs := self basicSize) ~= aMethodProperties basicSize ifTrue: [^false]. 1 to: bs do: [:i| ((self basicAt: i) analogousCodeTo: (aMethodProperties basicAt: i)) ifFalse: [^false]]. ^true! ! !AdditionalMethodState methodsFor: 'testing' stamp: 'bgf 12/6/2008 12:15'! hasLiteralSuchThat: aBlock "Answer true if litBlock returns true for any literal in this array, even if embedded in further array structure. This method is only intended for private use by CompiledMethod hasLiteralSuchThat:" 1 to: self basicSize do: [:i | | propertyOrPragma "" | propertyOrPragma := self basicAt: i. (propertyOrPragma isVariableBinding ifTrue: [(aBlock value: propertyOrPragma key) or: [(aBlock value: propertyOrPragma value) or: [propertyOrPragma value isArray and: [propertyOrPragma value hasLiteralSuchThat: aBlock]]]] ifFalse: [propertyOrPragma hasLiteralSuchThat: aBlock]) ifTrue: [^true]]. ^false! ! !AdditionalMethodState methodsFor: 'testing' stamp: 'eem 11/29/2008 16:40'! hasLiteralThorough: literal "Answer true if any literal in these properties is literal, even if embedded in array structure." 1 to: self basicSize do: [:i | | propertyOrPragma "" | propertyOrPragma := self basicAt: i. (propertyOrPragma isVariableBinding ifTrue: [propertyOrPragma key == literal or: [propertyOrPragma value == literal or: [propertyOrPragma value isArray and: [propertyOrPragma value hasLiteral: literal]]]] ifFalse: [propertyOrPragma hasLiteral: literal]) ifTrue: [^true]]. ^false! ! !AdditionalMethodState methodsFor: 'testing' stamp: 'eem 12/1/2008 10:53'! includes: aPropertyOrPragma "" "Test if the property or pragma is present." 1 to: self basicSize do: [:i | (self basicAt: i) = aPropertyOrPragma ifTrue: [^true]]. ^false! ! !AdditionalMethodState methodsFor: 'testing' stamp: 'eem 12/1/2008 10:53'! includesKey: aKey "Test if the property aKey or pragma with selector aKey is present." 1 to: self basicSize do: [:i | (self basicAt: i) key == aKey ifTrue: [^true]]. ^false! ! !AdditionalMethodState methodsFor: 'testing' stamp: 'eem 11/29/2008 13:47'! isEmpty ^self basicSize = 0! ! !AdditionalMethodState methodsFor: 'testing' stamp: 'md 2/19/2006 11:24'! isMethodProperties ^true! ! !AdditionalMethodState methodsFor: 'testing' stamp: 'eem 12/1/2008 16:49'! notEmpty ^self basicSize > 0! ! !AdditionalMethodState methodsFor: 'testing' stamp: 'JohanBrichau 10/7/2009 20:07'! refersToLiteral: aLiteral ^ self pragmas anySatisfy: [ :pragma | pragma hasLiteral: aLiteral ]! ! !AdditionalMethodState methodsFor: 'accessing' stamp: 'eem 11/29/2008 10:19'! at: aKey "Answer the property value or pragma associated with aKey." ^self at: aKey ifAbsent: [self error: 'not found']! ! !AdditionalMethodState methodsFor: 'accessing' stamp: 'eem 12/1/2008 10:55'! at: aKey ifAbsent: aBlock "Answer the property value or pragma associated with aKey or, if aKey isn't found, answer the result of evaluating aBlock." 1 to: self basicSize do: [:i | | propertyOrPragma "" | (propertyOrPragma := self basicAt: i) key == aKey ifTrue: [^propertyOrPragma isVariableBinding ifTrue: [propertyOrPragma value] ifFalse: [propertyOrPragma]]]. ^aBlock value! ! !AdditionalMethodState methodsFor: 'accessing' stamp: 'eem 12/1/2008 10:54'! at: aKey ifAbsentPut: aBlock "Answer the property value or pragma associated with aKey or, if aKey isn't found, answer the result of evaluating aBlock." 1 to: self basicSize do: [:i | | propertyOrPragma "" | (propertyOrPragma := self basicAt: i) key == aKey ifTrue: [^propertyOrPragma isVariableBinding ifTrue: [propertyOrPragma value] ifFalse: [propertyOrPragma]]]. ^method propertyValueAt: aKey put: aBlock value! ! !AdditionalMethodState methodsFor: 'accessing' stamp: 'eem 12/1/2008 10:56'! at: aKey put: aValue "Replace the property value or pragma associated with aKey." 1 to: self basicSize do: [:i | | propertyOrPragma "" | (propertyOrPragma := self basicAt: i) key == aKey ifTrue: [propertyOrPragma isVariableBinding ifTrue: [propertyOrPragma value: aValue] ifFalse: [self basicAt: i put: aValue]]]. ^method propertyValueAt: aKey put: aValue! ! !AdditionalMethodState methodsFor: 'accessing' stamp: 'eem 11/29/2008 18:36'! keysAndValuesDo: aBlock "Enumerate the receiver with all the keys and values." 1 to: self basicSize do: [:i | | propertyOrPragma "" | (propertyOrPragma := self basicAt: i) isVariableBinding ifTrue: [aBlock value: propertyOrPragma key value: propertyOrPragma value] ifFalse: [aBlock value: propertyOrPragma keyword value: propertyOrPragma]]! ! !AdditionalMethodState methodsFor: 'accessing' stamp: 'eem 11/29/2008 14:11'! pragmas "Answer the raw messages comprising my pragmas." | pragmaStream | pragmaStream := WriteStream on: (Array new: self basicSize). 1 to: self basicSize do: [:i | | propertyOrPragma "" | (propertyOrPragma := self basicAt: i) isVariableBinding ifFalse: [pragmaStream nextPut: propertyOrPragma]]. ^pragmaStream contents! ! !AdditionalMethodState methodsFor: 'accessing' stamp: 'eem 11/29/2008 10:25'! properties | propertyStream | propertyStream := WriteStream on: (Array new: self basicSize * 2). 1 to: self basicSize do: [:i | | propertyOrPragma "" | (propertyOrPragma := self basicAt: i) isVariableBinding ifTrue: [propertyStream nextPut: propertyOrPragma key; nextPut: propertyOrPragma value]]. ^IdentityDictionary newFromPairs: propertyStream contents! ! !AdditionalMethodState methodsFor: 'accessing' stamp: 'eem 11/29/2008 19:32'! removeKey: aKey ifAbsent: aBlock "Remove the property with aKey. Answer the value or, if aKey isn't found, answer the result of evaluating aBlock." 1 to: self basicSize do: [:i | | propertyOrPragma "" | propertyOrPragma := self basicAt: i. (propertyOrPragma isVariableBinding ifTrue: [propertyOrPragma key] ifFalse: [propertyOrPragma keyword]) == aKey ifTrue: [^method removeProperty: aKey]]. ^aBlock value! ! !AdditionalMethodState methodsFor: 'accessing' stamp: 'md 2/16/2006 17:50'! selector ^selector! ! !AdditionalMethodState methodsFor: 'accessing' stamp: 'md 2/16/2006 17:50'! selector: aSymbol selector := aSymbol! ! !AdditionalMethodState methodsFor: 'accessing' stamp: 'eem 11/29/2008 18:28'! setMethod: aMethod method := aMethod. 1 to: self basicSize do: [:i| | propertyOrPragma "" | (propertyOrPragma := self basicAt: i) isVariableBinding ifFalse: [propertyOrPragma setMethod: aMethod]]! ! !AdditionalMethodState methodsFor: 'copying' stamp: 'eem 11/29/2008 18:35'! copyWith: aPropertyOrPragma "" "Answer a copy of the receiver which includes aPropertyOrPragma" | bs copy | (Association == aPropertyOrPragma class or: [Pragma == aPropertyOrPragma class]) ifFalse: [self error: self class name, ' instances should hold only Associations or Pragmas.']. copy := self class new: (bs := self basicSize) + 1. 1 to: bs do: [:i| copy basicAt: i put: (self basicAt: i)]. copy basicAt: bs + 1 put: aPropertyOrPragma. ^copy selector: selector; setMethod: method; yourself ! ! !AdditionalMethodState methodsFor: 'copying' stamp: 'eem 11/29/2008 18:35'! copyWithout: aPropertyOrPragma "" "Answer a copy of the receiver which no longer includes aPropertyOrPragma" | bs copy offset | copy := self class new: (bs := self basicSize) - ((self includes: aPropertyOrPragma) ifTrue: [1] ifFalse: [0]). offset := 0. 1 to: bs do: [:i| (self basicAt: i) = aPropertyOrPragma ifTrue: [offset := 1] ifFalse: [copy basicAt: i - offset put: (self basicAt: i)]]. ^copy selector: selector; setMethod: method; yourself ! ! !AdditionalMethodState methodsFor: 'properties' stamp: 'eem 11/29/2008 10:28'! includesProperty: aKey "Test if the property aKey is present." 1 to: self basicSize do: [:i | | propertyOrPragma "" | propertyOrPragma := self basicAt: i. (propertyOrPragma isVariableBinding and: [propertyOrPragma key == aKey]) ifTrue: [^true]]. ^false! ! !AdditionalMethodState methodsFor: 'properties' stamp: 'eem 11/29/2008 10:18'! propertyKeysAndValuesDo: aBlock "Enumerate the receiver with all the keys and values." 1 to: self basicSize do: [:i | | propertyOrPragma "" | (propertyOrPragma := self basicAt: i) isVariableBinding ifTrue: [aBlock value: propertyOrPragma key value: propertyOrPragma value]]! ! !AdditionalMethodState methodsFor: 'properties' stamp: 'eem 11/29/2008 11:46'! propertyValueAt: aKey "Answer the property value associated with aKey." ^ self propertyValueAt: aKey ifAbsent: [ self error: 'Property not found' ].! ! !AdditionalMethodState methodsFor: 'properties' stamp: 'eem 11/29/2008 11:45'! propertyValueAt: aKey ifAbsent: aBlock "Answer the property value associated with aKey or, if aKey isn't found, answer the result of evaluating aBlock." 1 to: self basicSize do: [:i | | propertyOrPragma "" | propertyOrPragma := self basicAt: i. (propertyOrPragma isVariableBinding and: [propertyOrPragma key == aKey]) ifTrue: [^propertyOrPragma value]]. ^aBlock value! ! !AdditionalMethodState methodsFor: 'properties' stamp: 'lr 2/6/2006 20:48'! removeKey: aKey "Remove the property with aKey. Answer the property or raise an error if aKey isn't found." ^ self removeKey: aKey ifAbsent: [ self error: 'Property not found' ].! ! !AdditionalMethodState methodsFor: 'decompiling' stamp: 'eem 6/11/2009 17:06'! method: aMethodNodeOrNil "For decompilation" method := aMethodNodeOrNil! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AdditionalMethodState class instanceVariableNames: ''! !AdditionalMethodState class methodsFor: 'instance creation' stamp: 'eem 11/29/2008 18:48'! forMethod: aMethod selector: aSelector ^(self basicNew: 0) selector: aSelector; setMethod: aMethod; yourself! ! !AdditionalMethodState class methodsFor: 'instance creation' stamp: 'eem 11/28/2008 12:26'! selector: aSelector with: aPropertyOrPragma ^(self basicNew: 1) selector: aSelector; basicAt: 1 put: aPropertyOrPragma; yourself! ! MessageDialogWindow subclass: #AlertDialogWindow instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Widgets-Windows'! !AlertDialogWindow commentStamp: 'gvc 5/18/2007 13:52' prior: 0! Message dialog with a warning icon.! !AlertDialogWindow methodsFor: 'visual properties' stamp: 'gvc 5/18/2007 10:27'! icon "Answer an icon for the receiver." ^self theme warningIcon! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AlertDialogWindow class instanceVariableNames: ''! !AlertDialogWindow class methodsFor: 'as yet unclassified' stamp: 'gvc 5/22/2007 11:50'! taskbarIcon "Answer the icon for the receiver in a task bar." ^self theme smallWarningIcon! ! RectangleMorph subclass: #AlignmentMorph instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Basic'! !AlignmentMorph commentStamp: 'kfr 10/27/2003 10:25' prior: 0! Used for layout. Since all morphs now support layoutPolicy the main use of this class is no longer needed. Kept around for compability. Supports a few methods not found elsewhere that can be convenient, eg. newRow ! !AlignmentMorph methodsFor: 'adding' stamp: 'stephane.ducasse 1/15/2009 15:52'! addAColumn: aCollectionOfMorphs | col | col := self inAColumn: aCollectionOfMorphs. self addMorphBack: col. ^col! ! !AlignmentMorph methodsFor: 'adding' stamp: 'stephane.ducasse 1/15/2009 15:52'! addARow: aCollectionOfMorphs | row | row := self inARow: aCollectionOfMorphs. self addMorphBack: row. ^row! ! !AlignmentMorph methodsFor: 'adding' stamp: 'stephane.ducasse 1/15/2009 15:52'! addARowCentered: aCollectionOfMorphs ^(self addARow: aCollectionOfMorphs) hResizing: #shrinkWrap; wrapCentering: #center; cellPositioning: #leftCenter! ! !AlignmentMorph methodsFor: 'adding' stamp: 'stephane.ducasse 1/15/2009 15:52'! addARowCentered: aCollectionOfMorphs cellInset: cellInsetInteger ^(self addARow: aCollectionOfMorphs) hResizing: #shrinkWrap; wrapCentering: #center; cellPositioning: #leftCenter; cellInset: cellInsetInteger! ! !AlignmentMorph methodsFor: 'classification' stamp: 'di 5/7/1998 01:20'! isAlignmentMorph ^ true ! ! !AlignmentMorph methodsFor: 'event handling' stamp: 'sw 5/6/1998 15:58'! wantsKeyboardFocusFor: aSubmorph aSubmorph wouldAcceptKeyboardFocus ifTrue: [^ true]. ^ super wantsKeyboardFocusFor: aSubmorph! ! !AlignmentMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:36'! defaultBorderWidth "answer the default border width for the receiver" ^ 0! ! !AlignmentMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:24'! defaultColor "answer the default color/fill style for the receiver" ^ Color r: 0.8 g: 1.0 b: 0.8! ! !AlignmentMorph methodsFor: 'initialization' stamp: 'stephane.ducasse 1/15/2009 15:58'! initialize super initialize. self layoutPolicy: TableLayout new; listDirection: #leftToRight; wrapCentering: #topLeft; hResizing: #spaceFill; vResizing: #spaceFill; layoutInset: 2; rubberBandCells: true "from AlignmentMorphBob1which was merged in this class, in an effort to remove alignementBob1 and still preserving the addInRow behavior" " self listDirection: #topToBottom. self layoutInset: 0. self hResizing: #rigid. self vResizing: #rigid"! ! !AlignmentMorph methodsFor: 'initialization' stamp: 'ar 11/9/2000 20:34'! openInWindowLabeled: aString inWorld: aWorld self layoutInset: 0. ^super openInWindowLabeled: aString inWorld: aWorld.! ! !AlignmentMorph methodsFor: 'object filein' stamp: 'gm 2/22/2003 13:12'! convertOldAlignmentsNov2000: varDict using: smartRefStrm "major change - much of AlignmentMorph is now implemented more generally in Morph" "These are going away #('orientation' 'centering' 'hResizing' 'vResizing' 'inset' 'minCellSize' 'layoutNeeded' 'priorFullBounds')" | orientation centering hResizing vResizing inset minCellSize inAlignment | orientation := varDict at: 'orientation'. centering := varDict at: 'centering'. hResizing := varDict at: 'hResizing'. vResizing := varDict at: 'vResizing'. inset := varDict at: 'inset'. minCellSize := varDict at: 'minCellSize'. (orientation == #horizontal or: [orientation == #vertical]) ifTrue: [self layoutPolicy: TableLayout new]. self cellPositioning: #topLeft. self rubberBandCells: true. orientation == #horizontal ifTrue: [self listDirection: #leftToRight]. orientation == #vertical ifTrue: [self listDirection: #topToBottom]. centering == #topLeft ifTrue: [self wrapCentering: #topLeft]. centering == #bottomRight ifTrue: [self wrapCentering: #bottomRight]. centering == #center ifTrue: [self wrapCentering: #center. orientation == #horizontal ifTrue: [self cellPositioning: #leftCenter] ifFalse: [self cellPositioning: #topCenter]]. (inset isNumber or: [inset isPoint]) ifTrue: [self layoutInset: inset]. (minCellSize isNumber or: [minCellSize isPoint]) ifTrue: [self minCellSize: minCellSize]. (self hasProperty: #clipToOwnerWidth) ifTrue: [self clipSubmorphs: true]. "now figure out if our owner was an AlignmentMorph, even if it is reshaped..." inAlignment := false. owner isMorph ifTrue: [(owner isAlignmentMorph) ifTrue: [inAlignment := true]] ifFalse: ["e.g., owner may be reshaped" (owner class instanceVariablesString findString: 'orientation centering hResizing vResizing') > 0 ifTrue: ["this was an alignment morph being reshaped" inAlignment := true]]. "And check for containment in system windows" owner isSystemWindow ifTrue: [inAlignment := true]. (hResizing == #spaceFill and: [inAlignment not]) ifTrue: [self hResizing: #shrinkWrap] ifFalse: [self hResizing: hResizing]. (vResizing == #spaceFill and: [inAlignment not]) ifTrue: [self vResizing: #shrinkWrap] ifFalse: [self vResizing: vResizing]! ! !AlignmentMorph methodsFor: 'visual properties' stamp: 'sw 11/5/2001 15:11'! canHaveFillStyles "Return true if the receiver can have general fill styles; not just colors. This method is for gradually converting old morphs." ^ self class == AlignmentMorph "no subclasses"! ! !AlignmentMorph methodsFor: 'visual properties' stamp: 'stephane.ducasse 1/15/2009 15:52'! fancyText: aString font: aFont color: aColor | answer tm col | col := ColorTheme current dialog3DTitles ifTrue: [aColor] ifFalse: [aColor negated]. tm := TextMorph new. tm beAllFont: aFont; color: col; contents: aString. answer := self inAColumn: {tm}. ColorTheme current dialog3DTitles ifTrue: ["" tm addDropShadow. tm shadowPoint: 5 @ 5 + tm bounds center]. tm lock. ^ answer! ! !AlignmentMorph methodsFor: 'visual properties' stamp: 'stephane.ducasse 1/15/2009 15:53'! inAColumn: aCollectionOfMorphs | col | col := self class newColumn color: Color transparent; vResizing: #shrinkWrap; layoutInset: 1; wrapCentering: #center; cellPositioning: #topCenter. aCollectionOfMorphs do: [ :each | col addMorphBack: each]. ^col! ! !AlignmentMorph methodsFor: 'visual properties' stamp: 'stephane.ducasse 1/15/2009 15:54'! inARightColumn: aCollectionOfMorphs | col | col := self class newColumn color: Color transparent; vResizing: #shrinkWrap; layoutInset: 1; wrapCentering: #bottomRight; cellPositioning: #topCenter. aCollectionOfMorphs do: [:each | col addMorphBack: each]. ^ col! ! !AlignmentMorph methodsFor: 'visual properties' stamp: 'stephane.ducasse 1/15/2009 15:55'! inARow: aCollectionOfMorphs | row | row := self class newRow color: Color transparent; vResizing: #shrinkWrap; layoutInset: 2; wrapCentering: #center; cellPositioning: #leftCenter. aCollectionOfMorphs do: [:each | row addMorphBack: each]. ^ row! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AlignmentMorph class instanceVariableNames: ''! !AlignmentMorph class methodsFor: 'instance creation' stamp: 'dgd 9/20/2003 19:05'! columnPrototype "Answer a prototypical column" | sampleMorphs aColumn | sampleMorphs := #(red yellow green) collect: [:aColor | Morph new extent: 130 @ 38; color: (Color perform: aColor); setNameTo: aColor asString; yourself]. aColumn := self inAColumn: sampleMorphs. aColumn setNameTo: 'Column'. aColumn color: Color veryVeryLightGray. aColumn cellInset: 4; layoutInset: 6. aColumn enableDragNDrop. aColumn setBalloonText: 'Things dropped into here will automatically be organized into a column. Once you have added your own items here, you will want to remove the sample colored rectangles that this started with, and you will want to change this balloon help message to one of your own!!' translated. ^ aColumn! ! !AlignmentMorph class methodsFor: 'instance creation' stamp: 'sw 11/2/2001 04:45'! inAColumn: aCollectionOfMorphs "Answer a columnar AlignmentMorph holding the given collection" | col | col := self newColumn color: Color transparent; vResizing: #shrinkWrap; hResizing: #shrinkWrap; layoutInset: 1; borderColor: Color black; borderWidth: 1; wrapCentering: #center; cellPositioning: #topCenter. aCollectionOfMorphs do: [:each | col addMorphBack: each]. ^ col! ! !AlignmentMorph class methodsFor: 'instance creation' stamp: 'sw 11/5/2001 15:11'! inARow: aCollectionOfMorphs "Answer a row-oriented AlignmentMorph holding the given collection" | aRow | aRow := self newRow color: Color transparent; vResizing: #shrinkWrap; hResizing: #shrinkWrap; layoutInset: 1; borderColor: Color black; borderWidth: 1; wrapCentering: #center; cellPositioning: #topCenter. aCollectionOfMorphs do: [ :each | aRow addMorphBack: each]. ^ aRow! ! !AlignmentMorph class methodsFor: 'instance creation' stamp: 'ar 11/9/2000 20:51'! newColumn ^ self new listDirection: #topToBottom; hResizing: #spaceFill; extent: 1@1; vResizing: #spaceFill ! ! !AlignmentMorph class methodsFor: 'instance creation' stamp: 'ar 11/9/2000 20:50'! newRow ^ self new listDirection: #leftToRight; hResizing: #spaceFill; vResizing: #spaceFill; extent: 1@1; borderWidth: 0 ! ! !AlignmentMorph class methodsFor: 'instance creation' stamp: 'ar 11/9/2000 20:37'! newSpacer: aColor "Answer a space-filling instance of me of the given color." ^ self new hResizing: #spaceFill; vResizing: #spaceFill; layoutInset: 0; borderWidth: 0; extent: 1@1; color: aColor. ! ! !AlignmentMorph class methodsFor: 'instance creation' stamp: 'ar 11/9/2000 20:37'! newVariableTransparentSpacer "Answer a space-filling instance of me of the given color." ^ self new hResizing: #spaceFill; vResizing: #spaceFill; layoutInset: 0; borderWidth: 0; extent: 1@1; color: Color transparent ! ! !AlignmentMorph class methodsFor: 'instance creation' stamp: 'dgd 9/20/2003 19:05'! rowPrototype "Answer a prototypical row" | sampleMorphs aRow | sampleMorphs := (1 to: (2 + 3 atRandom)) collect: [:integer | EllipseMorph new extent: ((60 + (20 atRandom)) @ (80 + ((20 atRandom)))); color: Color random; setNameTo: ('egg', integer asString); yourself]. aRow := self inARow: sampleMorphs. aRow setNameTo: 'Row'. aRow enableDragNDrop. aRow cellInset: 6. aRow layoutInset: 8. aRow setBalloonText: 'Things dropped into here will automatically be organized into a row. Once you have added your own items here, you will want to remove the sample colored eggs that this started with, and you will want to change this balloon help message to one of your own!!' translated. aRow color: Color veryVeryLightGray. ^ aRow "AlignmentMorph rowPrototype openInHand"! ! !AlignmentMorph class methodsFor: 'scripting' stamp: 'sw 11/16/2004 00:44'! defaultNameStemForInstances "The code just below, now commented out, resulted in every instance of every sublcass of AlignmentMorph being given a default name of the form 'Alignment1', rather than the desired 'MoviePlayer1', 'ScriptEditor2', etc." "^ 'Alignment'" ^ super defaultNameStemForInstances! ! ColorMappingCanvas subclass: #AlphaBlendingCanvas instanceVariableNames: 'alpha' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Support'! !AlphaBlendingCanvas methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 9/1/2008 16:31'! image: aForm at: aPoint sourceRect: sourceRect rule: rule "Draw the given form. For the 'paint' combination rule use stenciling otherwise simply fill the source rectangle. Do a blendAlpha if the rule is blend to cope with translucent images being drawn (via translucentImage:...)." rule = Form paint ifTrue:[ ^myCanvas image: aForm at: aPoint sourceRect: sourceRect rule: Form paintAlpha alpha: alpha. ]. rule = Form over ifTrue:[ ^myCanvas image: aForm at: aPoint sourceRect: sourceRect rule: Form blendAlpha alpha: alpha. ]. rule = Form blend ifTrue:[ ^myCanvas image: aForm at: aPoint sourceRect: sourceRect rule: Form blendAlpha alpha: alpha. ].! ! !AlphaBlendingCanvas methodsFor: 'accessing' stamp: 'ar 8/8/2001 14:24'! alpha ^alpha! ! !AlphaBlendingCanvas methodsFor: 'accessing' stamp: 'ar 8/8/2001 14:24'! alpha: newAlpha alpha := newAlpha.! ! !AlphaBlendingCanvas methodsFor: 'initialization' stamp: 'ar 8/8/2001 14:18'! on: aCanvas myCanvas := aCanvas. alpha := 1.0.! ! !AlphaBlendingCanvas methodsFor: 'private' stamp: 'ar 8/8/2001 14:23'! mapColor: aColor aColor isColor ifFalse:[^aColor]. "Should not happen but who knows..." aColor isTransparent ifTrue:[^aColor]. aColor isOpaque ifTrue:[^aColor alpha: alpha]. ^aColor alpha: (aColor alpha * alpha)! ! ImageMorph subclass: #AlphaImageMorph instanceVariableNames: 'alpha cachedForm layout scale enabled' classVariableNames: 'DefaultImage' poolDictionaries: '' category: 'Polymorph-Widgets'! !AlphaImageMorph commentStamp: 'gvc 5/18/2007 13:52' prior: 0! Displays an image with the specified alpha value (translucency) and optional scale and layout (scaled, top-right etc.).! !AlphaImageMorph methodsFor: 'accessing' stamp: 'gvc 9/26/2006 09:40'! alpha "Answer the value of alpha" ^ alpha! ! !AlphaImageMorph methodsFor: 'accessing' stamp: 'gvc 8/8/2007 15:34'! alpha: anObject "Set the value of alpha" alpha := anObject. self cachedForm: nil; changed; changed: #alpha! ! !AlphaImageMorph methodsFor: 'accessing' stamp: 'gvc 1/13/2009 17:58'! cachedForm "Answer the value of cachedForm" |form i effectiveAlpha| cachedForm ifNil: [ i := self image. self layout == #scaled ifTrue: [self extent = i extent ifFalse: [i := i magnify: i boundingBox by: (self extent / i extent) smoothing: 2]] ifFalse: [self scale ~= 1 ifTrue: [i := i magnify: i boundingBox by: self scale smoothing: 2]]. effectiveAlpha := self enabled ifTrue: [self alpha] ifFalse: [self alpha / 2]. effectiveAlpha = 1.0 ifTrue: [self cachedForm: i] ifFalse: [form := Form extent: i extent depth: 32. form fillColor: (Color white alpha: 0.003922). (form getCanvas asAlphaBlendingCanvas: effectiveAlpha) drawImage: i at: 0@0. self cachedForm: form]]. ^cachedForm! ! !AlphaImageMorph methodsFor: 'accessing' stamp: 'gvc 9/27/2006 15:02'! cachedForm: anObject "Set the value of cachedForm" cachedForm := anObject! ! !AlphaImageMorph methodsFor: 'accessing' stamp: 'gvc 1/13/2009 17:56'! enabled "Answer the value of enabled" ^enabled! ! !AlphaImageMorph methodsFor: 'accessing' stamp: 'gvc 1/13/2009 17:57'! enabled: anObject "Set the value of enabled" enabled := anObject. self cachedForm: nil; changed! ! !AlphaImageMorph methodsFor: 'accessing' stamp: 'gvc 9/28/2006 14:15'! image: anImage "Clear the cached form." ^self image: anImage size: anImage extent! ! !AlphaImageMorph methodsFor: 'accessing' stamp: 'gvc 8/27/2009 16:14'! image: aForm size: aPoint "Set the image to be the form scaled to the given size and padded if neccesary." |f f2| f := aForm scaledToSize: aPoint. (f depth < 32 and: [f depth > 4]) ifTrue: [f2 := Form extent: aPoint depth: 32. f2 fillColor: (Color white alpha: 0.003922). f2 getCanvas translucentImage: f at: 0@0. f2 fixAlpha] ifFalse: [f2 := f]. self cachedForm: nil. super image: f2. self extent: aPoint + (self borderWidth * 2). self changed: #imageExtent! ! !AlphaImageMorph methodsFor: 'accessing' stamp: 'gvc 6/30/2009 16:02'! imageExtent "Answer the extent of the original form." ^self image extent! ! !AlphaImageMorph methodsFor: 'accessing' stamp: 'gvc 10/11/2006 12:00'! layout "Answer the value of layout" ^ layout! ! !AlphaImageMorph methodsFor: 'accessing' stamp: 'gvc 8/8/2007 15:28'! layout: aSymbol "Set the value of layout" |old| (old := layout) = aSymbol ifTrue: [^self]. layout := aSymbol. (old = #scaled or: [aSymbol = #scaled]) ifTrue: [self cachedForm: nil]. self changed! ! !AlphaImageMorph methodsFor: 'accessing' stamp: 'gvc 8/8/2007 16:10'! layoutSymbols "Answer the available layout options." ^#(#center #tiled #scaled #topLeft #topCenter #topRight #rightCenter #bottomRight #bottomCenter #bottomLeft #leftCenter)! ! !AlphaImageMorph methodsFor: 'accessing' stamp: 'gvc 10/11/2006 12:43'! scale "Answer the value of scale" ^ scale! ! !AlphaImageMorph methodsFor: 'accessing' stamp: 'gvc 8/8/2007 15:34'! scale: aNumber "Set the value of scale" scale = aNumber ifTrue: [^self]. scale := aNumber. self cachedForm: nil; changed; changed: #scale! ! !AlphaImageMorph methodsFor: 'drawing' stamp: 'gvc 8/8/2007 16:25'! drawOn: aCanvas "Draw with the current alpha Can't do simple way since BitBlt rules are dodgy!!." aCanvas fillRectangle: self bounds fillStyle: self fillStyle borderStyle: self borderStyle. (self cachedForm width = 0 or: [self cachedForm height = 0]) ifTrue: [^self]. self layout == #tiled ifTrue: [aCanvas fillRectangle: self innerBounds fillStyle: (AlphaInfiniteForm with: self cachedForm)] ifFalse: [aCanvas clipBy: self innerBounds during: [:c | c translucentImage: self cachedForm at: self layoutPosition]]! ! !AlphaImageMorph methodsFor: 'geometry' stamp: 'gvc 10/11/2006 12:02'! extent: aPoint "Allow as normal." self perform: #extent: withArguments: {aPoint} inSuperclass: Morph ! ! !AlphaImageMorph methodsFor: 'geometry' stamp: 'gvc 8/8/2007 16:09'! layoutPosition "Answer the position that the cached form should be drawn based on the layout" self layout == #topCenter ifTrue: [^self innerBounds topCenter - (self cachedForm width // 2 @ 0)]. self layout == #topRight ifTrue: [^self innerBounds topRight - (self cachedForm width @ 0)]. self layout == #rightCenter ifTrue: [^self innerBounds rightCenter - (self cachedForm width @ (self cachedForm height // 2))]. self layout == #bottomRight ifTrue: [^self innerBounds bottomRight - self cachedForm extent]. self layout == #bottomCenter ifTrue: [^self innerBounds bottomCenter - (self cachedForm width // 2 @ self cachedForm height)]. self layout == #bottomLeft ifTrue: [^self innerBounds bottomLeft - (0 @ self cachedForm height)]. self layout == #leftCenter ifTrue: [^self innerBounds leftCenter - (0 @ (self cachedForm height // 2))]. self layout == #center ifTrue: [^self innerBounds center - (self cachedForm extent // 2)]. ^self innerBounds topLeft! ! !AlphaImageMorph methodsFor: 'geometry' stamp: 'gvc 10/22/2007 11:51'! optimalExtent "Answer the optimal extent for the receiver." ^self image extent * self scale + (self borderWidth * 2)! ! !AlphaImageMorph methodsFor: 'initialization' stamp: 'gvc 9/26/2006 12:40'! defaultColor "Answer the default color for the receiver." ^Color transparent! ! !AlphaImageMorph methodsFor: 'initialization' stamp: 'gvc 12/3/2007 11:37'! defaultImage "Answer the default image for the receiver." ^DefaultImage ifNil: [DefaultImage := DefaultForm asFormOfDepth: 32]! ! !AlphaImageMorph methodsFor: 'initialization' stamp: 'alain.plantec 5/28/2009 09:37'! initialize "Initialize the receiver. Use the 32 bit depth default image to avoid unnecessary conversions." super initialize. enabled := true. self scale: 1.0; layout: #topLeft; alpha: 1.0! ! InfiniteForm subclass: #AlphaInfiniteForm instanceVariableNames: 'origin extent' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Widgets-FillStyles'! !AlphaInfiniteForm commentStamp: 'gvc 5/18/2007 13:49' prior: 0! Alpha aware InfiniteForm.! !AlphaInfiniteForm methodsFor: 'accessing' stamp: 'gvc 10/7/2008 14:00'! extent "Answer the extent of the repeating area." ^extent ifNil: [SmallInteger maxVal @ SmallInteger maxVal]! ! !AlphaInfiniteForm methodsFor: 'accessing' stamp: 'gvc 10/3/2008 12:48'! extent: anObject "Set the value of extent" extent := anObject! ! !AlphaInfiniteForm methodsFor: 'accessing' stamp: 'gvc 10/3/2008 12:42'! origin "Answer the origin." ^origin ifNil: [0@0]! ! !AlphaInfiniteForm methodsFor: 'accessing' stamp: 'gvc 10/3/2008 12:42'! origin: aPoint "Set the origin." origin := aPoint! ! !AlphaInfiniteForm methodsFor: 'as yet unclassified' stamp: 'gvc 12/3/2008 17:09'! direction: aPoint "Ignore" ! ! !AlphaInfiniteForm methodsFor: 'displaying' stamp: 'gvc 10/7/2008 13:59'! computeBoundingBox "Refer to the comment in DisplayObject|computeBoundingBox." ^self origin extent: self extent! ! !AlphaInfiniteForm methodsFor: 'displaying' stamp: 'gvc 8/10/2009 11:42'! displayOnPort: aPort offsetBy: offset | targetBox patternBox savedMap top left | aPort destForm depth < 32 ifTrue: [^super displayOnPort: aPort offsetBy: offset]. "this version tries to get the form aligned where the user wants it and not just aligned with the cliprect" (patternForm isForm) ifFalse: [ "patternForm is a Pattern or Color; just use it as a mask for BitBlt" ^ aPort fill: aPort clipRect fillColor: patternForm rule: Form over]. "do it iteratively" targetBox := aPort clipRect. patternBox := patternForm boundingBox. savedMap := aPort colorMap. aPort sourceForm: patternForm; fillColor: nil; combinationRule: Form blend; sourceRect: (0@0 extent: patternBox extent); colorMap: (patternForm colormapIfNeededFor: aPort destForm). top := (targetBox top truncateTo: patternBox height) + offset y. left := (targetBox left truncateTo: patternBox width) + offset x. left to: (targetBox right - 1) by: patternBox width do: [:x | top to: (targetBox bottom - 1) by: patternBox height do: [:y | aPort destOrigin: x@y; copyBits]]. aPort colorMap: savedMap. ! ! GIFReadWriter subclass: #AnimatedGIFReadWriter instanceVariableNames: 'forms delays comments' classVariableNames: '' poolDictionaries: '' category: 'Graphics-Files'! !AnimatedGIFReadWriter methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! allImages | body colorTable | stream class == ReadWriteStream ifFalse: [ stream binary. self on: (ReadWriteStream with: stream contentsOfEntireFile) ]. localColorTable := nil. forms := OrderedCollection new. delays := OrderedCollection new. comments := OrderedCollection new. self readHeader. [ (body := self readBody) isNil ] whileFalse: [ colorTable := localColorTable ifNil: [ colorPalette ]. transparentIndex ifNotNil: [ transparentIndex + 1 > colorTable size ifTrue: [ colorTable := colorTable forceTo: transparentIndex + 1 paddingWith: Color white ]. colorTable at: transparentIndex + 1 put: Color transparent ]. body colors: colorTable. forms add: body. delays add: delay ]. ^ forms! ! !AnimatedGIFReadWriter methodsFor: 'accessing' stamp: 'mir 11/19/2003 14:16'! delays ^ delays! ! !AnimatedGIFReadWriter methodsFor: 'accessing' stamp: 'mir 11/19/2003 14:16'! forms ^ forms! ! !AnimatedGIFReadWriter methodsFor: 'private' stamp: 'mir 11/19/2003 12:25'! comment: aString comments add: aString! ! !AnimatedGIFReadWriter methodsFor: 'private-decoding' stamp: 'mir 11/19/2003 12:21'! readBitData | form | form := super readBitData. form offset: offset. ^form! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AnimatedGIFReadWriter class instanceVariableNames: ''! !AnimatedGIFReadWriter class methodsFor: 'image reading/writing' stamp: 'lr 7/4/2009 10:42'! formsFromFileNamed: fileName | stream | stream := FileStream readOnlyFileNamed: fileName. ^ self formsFromStream: stream! ! !AnimatedGIFReadWriter class methodsFor: 'image reading/writing' stamp: 'lr 7/4/2009 10:42'! formsFromStream: stream | reader | reader := self new on: stream reset. Cursor read showWhile: [ reader allImages. reader close ]. ^ reader! ! !AnimatedGIFReadWriter class methodsFor: 'image reading/writing' stamp: 'nk 6/12/2004 13:12'! typicalFileExtensions "Answer a collection of file extensions (lowercase) which files that I can read might commonly have" ^#('gif')! ! !AnimatedGIFReadWriter class methodsFor: 'image reading/writing' stamp: 'asm 12/11/2003 21:29'! wantsToHandleGIFs ^true! ! Object subclass: #Announcement instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Announcements-Core'! !Announcement methodsFor: '*announcements-view' stamp: 'lr 9/3/2006 16:17'! open self inspect! ! !Announcement methodsFor: 'converting' stamp: 'lr 10/3/2006 14:32'! asAnnouncement ^ self! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Announcement class instanceVariableNames: ''! !Announcement class methodsFor: 'converting' stamp: 'lr 10/3/2006 14:31'! asAnnouncement ^ self new! ! !Announcement class methodsFor: 'public' stamp: 'lr 9/20/2006 08:18'! , anAnnouncementClass ^ AnnouncementSet with: self with: anAnnouncementClass! ! !Announcement class methodsFor: 'testing' stamp: 'lr 10/3/2006 14:31'! handles: anAnnouncementClass ^ anAnnouncementClass isKindOf: self! ! Announcement subclass: #AnnouncementMockA instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Tests-Announcements'! Announcement subclass: #AnnouncementMockB instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Tests-Announcements'! AnnouncementMockB subclass: #AnnouncementMockC instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Tests-Announcements'! Set subclass: #AnnouncementSet instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Announcements-Core'! !AnnouncementSet methodsFor: 'adding' stamp: 'lr 6/13/2006 08:13'! , anAnnouncementClass self add: anAnnouncementClass! ! !AnnouncementSet methodsFor: 'testing' stamp: 'lr 10/3/2006 14:31'! handles: anAnnouncementClass ^ self anySatisfy: [ :each | each handles: anAnnouncementClass ]! ! Object subclass: #AnnouncementSpy instanceVariableNames: 'announcer announcements index' classVariableNames: '' poolDictionaries: '' category: 'Announcements-View'! !AnnouncementSpy methodsFor: 'accessing' stamp: 'lr 6/14/2006 17:02'! announcements ^ announcements! ! !AnnouncementSpy methodsFor: 'accessing' stamp: 'lr 9/3/2006 14:08'! announcements: aCollection announcements := aCollection. self changed: #announcements! ! !AnnouncementSpy methodsFor: 'accessing' stamp: 'lr 6/14/2006 17:04'! announcer ^ announcer! ! !AnnouncementSpy methodsFor: 'accessing' stamp: 'lr 9/25/2006 09:26'! announcer: anAnnouncer announcer ifNotNil: [ announcer unsubscribe: self ]. announcer := anAnnouncer. announcer ifNotNil: [ announcer subscribe: Announcement send: #announce: to: self ]! ! !AnnouncementSpy methodsFor: 'accessing' stamp: 'lr 6/14/2006 17:02'! index ^ index ! ! !AnnouncementSpy methodsFor: 'accessing' stamp: 'lr 6/14/2006 17:20'! index: anInteger index := anInteger. self changed: #index! ! !AnnouncementSpy methodsFor: 'accessing-dynamic' stamp: 'lr 9/3/2006 14:08'! extent ^ 250 @ 400! ! !AnnouncementSpy methodsFor: 'accessing-dynamic' stamp: 'lr 6/14/2006 17:03'! label ^ self announcer printString! ! !AnnouncementSpy methodsFor: 'actions' stamp: 'lr 9/3/2006 16:21'! clear self announcements: OrderedCollection new! ! !AnnouncementSpy methodsFor: 'actions' stamp: 'lr 9/25/2006 09:19'! close self announcer: nil! ! !AnnouncementSpy methodsFor: 'actions' stamp: 'lr 9/25/2006 09:25'! open (self announcements at: self index ifAbsent: [ ^ self ]) open! ! !AnnouncementSpy methodsFor: 'building' stamp: 'lr 9/3/2006 16:21'! buildMenu: aMenuMorph ^ aMenuMorph defaultTarget: self; add: 'open' action: #open; add: 'clear' action: #clear; yourself! ! !AnnouncementSpy methodsFor: 'building' stamp: 'lr 9/25/2006 09:20'! buildWith: aBuilder ^ aBuilder build: (aBuilder pluggableWindowSpec new model: self; label: self label; extent: self extent; closeAction: #close; children: (OrderedCollection new add: (aBuilder pluggableListSpec new model: self; list: #announcements; menu: #buildMenu:; getIndex: #index; setIndex: #index:; frame: (0 @ 0 corner: 1 @ 1); yourself); yourself); yourself)! ! !AnnouncementSpy methodsFor: 'initialization' stamp: 'lr 6/14/2006 17:03'! initialize super initialize. self announcements: OrderedCollection new. self index: 0! ! !AnnouncementSpy methodsFor: 'private' stamp: 'lr 9/3/2006 14:09'! announce: anAnnouncement self announcements add: anAnnouncement. self index: self announcements size. self changed: #announcements! ! !AnnouncementSpy methodsFor: 'private' stamp: 'lr 6/14/2006 17:19'! changed: aSymbol WorldState addDeferredUIMessage: [ super changed: aSymbol ]! ! !AnnouncementSpy methodsFor: 'private' stamp: 'lr 6/14/2006 17:29'! perform: selector orSendTo: otherTarget ^ (self respondsTo: selector) ifTrue: [ self perform: selector ] ifFalse: [ super perform: selector orSendTo: otherTarget ]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AnnouncementSpy class instanceVariableNames: ''! !AnnouncementSpy class methodsFor: 'instance-creation' stamp: 'lr 6/14/2006 17:05'! on: anAnnouncer ^ self new announcer: anAnnouncer; yourself! ! !AnnouncementSpy class methodsFor: 'instance-creation' stamp: 'lr 6/14/2006 17:05'! openOn: anAnnouncer ToolBuilder open: (self on: anAnnouncer)! ! Object subclass: #Announcer instanceVariableNames: 'subscriptions' classVariableNames: '' poolDictionaries: '' category: 'Announcements-Core'! !Announcer commentStamp: 'lr 3/2/2009 10:27' prior: 0! The code is based on the announcements as described by Vassili Bykov in . The implementation is a slightly extended and generalized version of the code found in OmniBrowser by Colin Putney.! !Announcer methodsFor: '*announcements-view' stamp: 'lr 9/20/2006 08:18'! open AnnouncementSpy openOn: self! ! !Announcer methodsFor: 'announce' stamp: 'lr 8/5/2008 12:06'! announce: anAnnouncement | announcement | announcement := anAnnouncement asAnnouncement. subscriptions ifNil: [ ^ announcement ]. subscriptions keysAndValuesDo: [ :class :actions | (class handles: announcement) ifTrue: [ actions valueWithArguments: (Array with: announcement) ] ]. ^ announcement! ! !Announcer methodsFor: 'convenience' stamp: 'lr 10/27/2006 14:26'! on: anAnnouncementClass do: aValuable ^ self subscribe: anAnnouncementClass do: aValuable! ! !Announcer methodsFor: 'convenience' stamp: 'lr 10/27/2006 14:27'! on: anAnnouncementClass send: aSelector to: anObject ^ self subscribe: anAnnouncementClass send: aSelector to: anObject! ! !Announcer methodsFor: 'convenience' stamp: 'tg 2/25/2009 12:05'! when: anAnnouncementClass do: aValuable ^ self subscribe: anAnnouncementClass do: aValuable! ! !Announcer methodsFor: 'subscription' stamp: 'lr 8/5/2008 12:05'! subscribe: anAnnouncementClass do: aValuable | actions | subscriptions ifNil: [ subscriptions := IdentityDictionary new ]. actions := subscriptions at: anAnnouncementClass ifAbsent: [ ActionSequence new ]. subscriptions at: anAnnouncementClass put: (actions copyWith: aValuable). ^ aValuable! ! !Announcer methodsFor: 'subscription' stamp: 'lr 10/27/2006 14:27'! subscribe: anAnnouncementClass send: aSelector to: anObject ^ self subscribe: anAnnouncementClass do: (MessageSend receiver: anObject selector: aSelector)! ! !Announcer methodsFor: 'subscription' stamp: 'lr 8/5/2008 12:05'! unsubscribe: anObject subscriptions ifNil: [ ^ self ]. subscriptions keysAndValuesDo: [ :class :actions | subscriptions at: class put: (actions reject: [ :each | each receiver == anObject ]) ]. subscriptions keysAndValuesRemove: [ :class :actions | actions isEmpty ]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Announcer class instanceVariableNames: ''! TestCase subclass: #AnnouncerTest instanceVariableNames: 'announcer' classVariableNames: '' poolDictionaries: '' category: 'Tests-Announcements'! !AnnouncerTest methodsFor: 'running' stamp: 'lr 9/25/2006 08:42'! setUp announcer := Announcer new! ! !AnnouncerTest methodsFor: 'testing' stamp: 'lr 3/2/2009 10:11'! testAnnounceClass self assert: (announcer announce: AnnouncementMockA) class = AnnouncementMockA! ! !AnnouncerTest methodsFor: 'testing' stamp: 'lr 3/2/2009 10:10'! testAnnounceInstance | instance | instance := AnnouncementMockA new. self assert: (announcer announce: instance) = instance! ! !AnnouncerTest methodsFor: 'testing' stamp: 'lr 3/2/2009 10:08'! testSubscribeBlock | announcement instance | announcer subscribe: AnnouncementMockA do: [ :ann | announcement := ann ]. announcement := nil. instance := announcer announce: AnnouncementMockA. self assert: announcement = instance. announcement := nil. instance := announcer announce: AnnouncementMockB. self assert: announcement isNil! ! !AnnouncerTest methodsFor: 'testing' stamp: 'lr 3/2/2009 10:07'! testSubscribeSend | announcement instance | announcer subscribe: AnnouncementMockA send: #value: to: [ :ann | announcement := ann ]. announcement := nil. instance := announcer announce: AnnouncementMockA. self assert: announcement = instance. announcement := nil. instance := announcer announce: AnnouncementMockB new. self assert: announcement isNil! ! !AnnouncerTest methodsFor: 'testing' stamp: 'lr 3/2/2009 10:07'! testSubscribeSet | announcement instance | announcer subscribe: AnnouncementMockA , AnnouncementMockC do: [ :ann | announcement := ann ]. announcement := nil. instance := announcer announce: AnnouncementMockA. self assert: announcement = instance. announcement := nil. instance := announcer announce: AnnouncementMockB. self assert: announcement isNil. announcement := nil. instance := announcer announce: AnnouncementMockC. self assert: announcement = instance! ! !AnnouncerTest methodsFor: 'testing' stamp: 'lr 3/2/2009 10:06'! testSubscribeSubclass | announcement instance | announcer subscribe: AnnouncementMockB do: [ :ann | announcement := ann ]. announcement := nil. instance := announcer announce: AnnouncementMockA. self assert: announcement isNil. announcement := nil. instance := announcer announce: AnnouncementMockB. self assert: announcement = instance. announcement := nil. instance := announcer announce: AnnouncementMockC. self assert: announcement = instance.! ! !AnnouncerTest methodsFor: 'testing' stamp: 'lr 9/25/2006 09:10'! testUnsubscribeBlock | announcement | announcer subscribe: AnnouncementMockA do: [ :ann | announcement := ann ]. announcer unsubscribe: self. announcement := nil. announcer announce: AnnouncementMockA new. self assert: announcement isNil! ! !AnnouncerTest methodsFor: 'testing' stamp: 'lr 9/25/2006 09:13'! testUnsubscribeSend | announcement receiver | announcer subscribe: AnnouncementMockA send: #value: to: (receiver := [ :ann | announcement := ann ]). announcer unsubscribe: receiver. announcement := nil. announcer announce: AnnouncementMockA new. self assert: announcement isNil! ! !AnnouncerTest methodsFor: 'testing' stamp: 'lr 9/25/2006 09:13'! testUnsubscribeSet | announcement | announcer subscribe: AnnouncementMockA , AnnouncementMockB do: [ :ann | announcement := ann ]. announcer unsubscribe: self. announcement := nil. announcer announce: AnnouncementMockA new. self assert: announcement isNil. announcement := nil. announcer announce: AnnouncementMockB new. self assert: announcement isNil.! ! Object subclass: #AppRegistry instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'System-Applications'! !AppRegistry commentStamp: 'ads 4/2/2003 15:30' prior: 0! AppRegistry is a simple little class, not much more than a wrapper around a collection. It's intended to help break dependencies between packages. For example, if you'd like to be able to send e-mail, you could use the bare-bones MailComposition class, or you could use the full-blown Celeste e-mail client. Instead of choosing one or the other, you can call "MailSender default" (where MailSender is a subclass of AppRegistry), and thus avoid creating a hard-coded dependency on either of the two mail senders. This will only really be useful, of course, for applications that have a very simple, general, well-defined interface. Most of the time, you're probably better off just marking your package as being dependent on a specific other package, and avoiding the hassle of this whole AppRegistry thing. But for simple things like e-mail senders or web browsers, it might be useful. ! !AppRegistry methodsFor: 'notes' stamp: 'ads 4/2/2003 15:04'! seeClassSide "All the code for AppRegistry is on the class side."! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AppRegistry class instanceVariableNames: 'registeredClasses default'! !AppRegistry class methodsFor: 'as yet unclassified' stamp: 'ads 3/29/2003 13:36'! appName "Defaults to the class name, which is probably good enough, but you could override this in subclasses if you want to." ^ self name! ! !AppRegistry class methodsFor: 'as yet unclassified' stamp: 'alain.plantec 2/8/2009 21:37'! askForDefault "self askForDefault" self registeredClasses isEmpty ifTrue: [self inform: 'There are no ', self appName, ' applications registered.'. ^ default := nil]. self registeredClasses size = 1 ifTrue: [^ default := self registeredClasses anyOne]. default := UIManager default chooseFrom: (self registeredClasses collect: [:c | c name]) values: self registeredClasses title: ('Which ' , self appName, ' would you prefer?') translated. default ifNil: [default := self registeredClasses first]. ^default.! ! !AppRegistry class methodsFor: 'as yet unclassified' stamp: 'ads 3/29/2003 13:11'! default ^ default ifNil: [self askForDefault]! ! !AppRegistry class methodsFor: 'as yet unclassified' stamp: 'nk 3/9/2004 12:33'! default: aClassOrNil "Sets my default to aClassOrNil. Answers the old default." | oldDefault | oldDefault := default. aClassOrNil ifNotNil: [ self register: aClassOrNil ]. default := aClassOrNil. ^ oldDefault! ! !AppRegistry class methodsFor: 'as yet unclassified' stamp: 'nk 3/9/2004 12:35'! defaultOrNil ^ default! ! !AppRegistry class methodsFor: 'as yet unclassified' stamp: 'ads 4/2/2003 15:25'! register: aProviderClass (self registeredClasses includes: aProviderClass) ifFalse: [default := nil. "so it'll ask for a new default, since if you're registering a new app you probably want to use it" self registeredClasses add: aProviderClass].! ! !AppRegistry class methodsFor: 'as yet unclassified' stamp: 'ads 3/29/2003 13:01'! registeredClasses ^ registeredClasses ifNil: [registeredClasses := OrderedCollection new]! ! !AppRegistry class methodsFor: 'as yet unclassified' stamp: 'ar 9/27/2005 21:48'! removeObsolete "AppRegistry removeObsoleteClasses" self registeredClasses copy do:[:cls| (cls class isObsolete or:[cls isBehavior and:[cls isObsolete]]) ifTrue:[self unregister: cls]]. self subclasses do:[:cls| cls removeObsolete].! ! !AppRegistry class methodsFor: 'as yet unclassified' stamp: 'ads 3/29/2003 13:03'! unregister: aProviderClass (default = aProviderClass) ifTrue: [default := nil]. self registeredClasses remove: aProviderClass ifAbsent: [].! ! Path subclass: #Arc instanceVariableNames: 'quadrant radius center' classVariableNames: '' poolDictionaries: '' category: 'ST80-Paths'! !Arc commentStamp: '' prior: 0! Arcs are an unusual implementation of splines due to Ted Kaehler. Imagine two lines that meet at a corner. Now imagine two moving points; one moves from the corner to the end on one line, the other moves from the end of the other line in to the corner. Now imagine a series of lines drawn between those moving points at each step along the way (they form a sort of spider web pattern). By connecting segments of the intersecting lines, a smooth curve is achieved that is tangent to both of the original lines. Voila.! !Arc methodsFor: 'accessing'! center "Answer the point at the center of the receiver." ^center! ! !Arc methodsFor: 'accessing'! center: aPoint "Set aPoint to be the receiver's center." center := aPoint! ! !Arc methodsFor: 'accessing'! center: aPoint radius: anInteger "The receiver is defined by a point at the center and a radius. The quadrant is not reset." center := aPoint. radius := anInteger! ! !Arc methodsFor: 'accessing'! center: aPoint radius: anInteger quadrant: section "Set the receiver's quadrant to be the argument, section. The size of the receiver is defined by the center and its radius." center := aPoint. radius := anInteger. quadrant := section! ! !Arc methodsFor: 'accessing'! quadrant "Answer the part of the circle represented by the receiver." ^quadrant! ! !Arc methodsFor: 'accessing'! quadrant: section "Set the part of the circle represented by the receiver to be the argument, section." quadrant := section! ! !Arc methodsFor: 'accessing'! radius "Answer the receiver's radius." ^radius! ! !Arc methodsFor: 'accessing'! radius: anInteger "Set the receiver's radius to be the argument, anInteger." radius := anInteger! ! !Arc methodsFor: 'display box access'! computeBoundingBox | aRectangle aPoint | aRectangle := center - radius + form offset extent: form extent + (radius * 2) asPoint. aPoint := center + form extent. quadrant = 1 ifTrue: [^ aRectangle encompass: center x @ aPoint y]. quadrant = 2 ifTrue: [^ aRectangle encompass: aPoint x @ aPoint y]. quadrant = 3 ifTrue: [^ aRectangle encompass: aPoint x @ center y]. quadrant = 4 ifTrue: [^ aRectangle encompass: center x @ center y]! ! !Arc methodsFor: 'displaying'! displayOn: aDisplayMedium at: aPoint clippingBox: clipRect rule: anInteger fillColor: aForm | nSegments line angle sin cos xn yn xn1 yn1 | nSegments := 12.0. line := Line new. line form: self form. angle := 90.0 / nSegments. sin := (angle * (2 * Float pi / 360.0)) sin. cos := (angle * (2 * Float pi / 360.0)) cos. quadrant = 1 ifTrue: [xn := radius asFloat. yn := 0.0]. quadrant = 2 ifTrue: [xn := 0.0. yn := 0.0 - radius asFloat]. quadrant = 3 ifTrue: [xn := 0.0 - radius asFloat. yn := 0.0]. quadrant = 4 ifTrue: [xn := 0.0. yn := radius asFloat]. nSegments asInteger timesRepeat: [xn1 := xn * cos + (yn * sin). yn1 := yn * cos - (xn * sin). line beginPoint: center + (xn asInteger @ yn asInteger). line endPoint: center + (xn1 asInteger @ yn1 asInteger). line displayOn: aDisplayMedium at: aPoint clippingBox: clipRect rule: anInteger fillColor: aForm. xn := xn1. yn := yn1]! ! !Arc methodsFor: 'displaying'! displayOn: aDisplayMedium transformation: aTransformation clippingBox: clipRect rule: anInteger fillColor: aForm | newArc tempCenter | newArc := Arc new. tempCenter := aTransformation applyTo: self center. newArc center: tempCenter x asInteger @ tempCenter y asInteger. newArc quadrant: self quadrant. newArc radius: (self radius * aTransformation scale x) asInteger. newArc form: self form. newArc displayOn: aDisplayMedium at: 0 @ 0 clippingBox: clipRect rule: anInteger fillColor: aForm! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Arc class instanceVariableNames: ''! !Arc class methodsFor: 'examples'! example "Click the button somewhere on the screen. The designated point will be the center of an Arc with radius 50 in the 4th quadrant." | anArc aForm | aForm := Form extent: 1 @ 30. "make a long thin Form for display" aForm fillBlack. "turn it black" anArc := Arc new. anArc form: aForm. "set the form for display" anArc radius: 50.0. anArc center: Sensor waitButton. anArc quadrant: 4. anArc displayOn: Display. Sensor waitButton "Arc example"! ! Object subclass: #Archive instanceVariableNames: 'members' classVariableNames: '' poolDictionaries: '' category: 'Compression-Archives'! !Archive commentStamp: '' prior: 0! This is the abstract superclass for file archives. Archives can be read from or written to files, and contain members that represent files and directories.! !Archive methodsFor: 'archive operations' stamp: 'nk 2/22/2001 19:09'! addDirectory: aFileName ^self addDirectory: aFileName as: aFileName ! ! !Archive methodsFor: 'archive operations' stamp: 'nk 12/20/2002 14:57'! addDirectory: aFileName as: anotherFileName | newMember | newMember := self memberClass newFromDirectory: aFileName. self addMember: newMember. newMember localFileName: anotherFileName. ^newMember! ! !Archive methodsFor: 'archive operations' stamp: 'nk 2/21/2001 18:29'! addFile: aFileName ^self addFile: aFileName as: aFileName! ! !Archive methodsFor: 'archive operations' stamp: 'nk 12/20/2002 15:03'! addFile: aFileName as: anotherFileName | newMember | newMember := self memberClass newFromFile: aFileName. self addMember: newMember. newMember localFileName: anotherFileName. ^newMember! ! !Archive methodsFor: 'archive operations' stamp: 'nk 2/22/2001 19:09'! addMember: aMember ^members addLast: aMember! ! !Archive methodsFor: 'archive operations' stamp: 'nk 12/20/2002 15:03'! addString: aString as: aFileName | newMember | newMember := self memberClass newFromString: aString named: aFileName. self addMember: newMember. newMember localFileName: aFileName. ^newMember! ! !Archive methodsFor: 'archive operations' stamp: 'tak 2/2/2005 13:22'! addTree: aFileNameOrDirectory match: aBlock | nameSize | nameSize := aFileNameOrDirectory isString ifTrue: [aFileNameOrDirectory size] ifFalse: [aFileNameOrDirectory pathName size]. ^ self addTree: aFileNameOrDirectory removingFirstCharacters: nameSize + 1 match: aBlock! ! !Archive methodsFor: 'archive operations' stamp: 'tak 2/2/2005 13:00'! addTree: aFileNameOrDirectory removingFirstCharacters: n ^ self addTree: aFileNameOrDirectory removingFirstCharacters: n match: [:e | true]! ! !Archive methodsFor: 'archive operations' stamp: 'eem 6/11/2008 12:47'! addTree: aFileNameOrDirectory removingFirstCharacters: n match: aBlock | dir fullPath relativePath | dir := (aFileNameOrDirectory isString) ifTrue: [ FileDirectory on: aFileNameOrDirectory ] ifFalse: [ aFileNameOrDirectory ]. fullPath := dir pathName, dir slash. relativePath := fullPath copyFrom: n + 1 to: fullPath size. (dir entries select: [ :entry | aBlock value: entry]) do: [ :ea | | fullName newMember | fullName := fullPath, ea name. newMember := ea isDirectory ifTrue: [ self memberClass newFromDirectory: fullName ] ifFalse: [ self memberClass newFromFile: fullName ]. newMember localFileName: relativePath, ea name. self addMember: newMember. ea isDirectory ifTrue: [ self addTree: fullName removingFirstCharacters: n match: aBlock]. ]. ! ! !Archive methodsFor: 'archive operations' stamp: 'nk 2/24/2001 14:12'! canWriteToFileNamed: aFileName "Catch attempts to overwrite existing zip file" ^(members anySatisfy: [ :ea | ea usesFileNamed: aFileName ]) not. ! ! !Archive methodsFor: 'archive operations' stamp: 'nk 2/22/2001 07:57'! contentsOf: aMemberOrName | member | member := self member: aMemberOrName. member ifNil: [ ^nil ]. ^member contents! ! !Archive methodsFor: 'archive operations' stamp: 'nk 12/20/2002 14:48'! extractMember: aMemberOrName | member | member := self member: aMemberOrName. member ifNil: [ ^nil ]. member extractToFileNamed: member localFileName inDirectory: FileDirectory default.! ! !Archive methodsFor: 'archive operations' stamp: 'nk 2/22/2001 07:57'! extractMember: aMemberOrName toFileNamed: aFileName | member | member := self member: aMemberOrName. member ifNil: [ ^nil ]. member extractToFileNamed: aFileName! ! !Archive methodsFor: 'archive operations' stamp: 'nk 11/11/2002 14:09'! extractMemberWithoutPath: aMemberOrName self extractMemberWithoutPath: aMemberOrName inDirectory: FileDirectory default.! ! !Archive methodsFor: 'archive operations' stamp: 'nk 12/20/2002 14:48'! extractMemberWithoutPath: aMemberOrName inDirectory: dir | member | member := self member: aMemberOrName. member ifNil: [ ^nil ]. member extractToFileNamed: (FileDirectory localNameFor: member localFileName) inDirectory: dir! ! !Archive methodsFor: 'archive operations' stamp: 'nk 12/20/2002 14:50'! memberNamed: aString "Return the first member whose zip name or local file name matches aString, or nil" ^members detect: [ :ea | ea fileName = aString or: [ ea localFileName = aString ]] ifNone: [ ]! ! !Archive methodsFor: 'archive operations' stamp: 'nk 2/21/2001 18:00'! memberNames ^members collect: [ :ea | ea fileName ]! ! !Archive methodsFor: 'archive operations' stamp: 'nk 2/21/2001 17:58'! members ^members! ! !Archive methodsFor: 'archive operations' stamp: 'nk 12/20/2002 14:50'! membersMatching: aString ^members select: [ :ea | (aString match: ea fileName) or: [ aString match: ea localFileName ] ]! ! !Archive methodsFor: 'archive operations' stamp: 'nk 2/21/2001 17:59'! numberOfMembers ^members size! ! !Archive methodsFor: 'archive operations' stamp: 'nk 2/22/2001 07:57'! removeMember: aMemberOrName | member | member := self member: aMemberOrName. member ifNotNil: [ members remove: member ]. ^member! ! !Archive methodsFor: 'archive operations' stamp: 'nk 2/22/2001 07:57'! replaceMember: aMemberOrName with: newMember | member | member := self member: aMemberOrName. member ifNotNil: [ members replaceAll: member with: newMember ]. ^member! ! !Archive methodsFor: 'archive operations' stamp: 'nk 2/22/2001 17:24'! setContentsOf: aMemberOrName to: aString | newMember oldMember | oldMember := self member: aMemberOrName. newMember := (self memberClass newFromString: aString named: oldMember fileName) copyFrom: oldMember. self replaceMember: oldMember with: newMember.! ! !Archive methodsFor: 'archive operations' stamp: 'nk 2/21/2001 20:58'! writeTo: aStream self subclassResponsibility! ! !Archive methodsFor: 'archive operations' stamp: 'stephane.ducasse 8/8/2009 12:32'! writeToFileNamed: aFileName | stream | "Catch attempts to overwrite existing zip file" (self canWriteToFileNamed: aFileName) ifFalse: [ ^self error: (aFileName, ' is needed by one or more members in this archive') ]. stream := StandardFileStream forceNewFileNamed: aFileName. [ self writeTo: stream ] ensure: [ stream close ]! ! !Archive methodsFor: 'initialization' stamp: 'alain.plantec 5/28/2009 09:39'! initialize super initialize. members := OrderedCollection new.! ! !Archive methodsFor: 'private' stamp: 'nk 2/22/2001 07:56'! member: aMemberOrName ^(members includes: aMemberOrName) ifTrue: [ aMemberOrName ] ifFalse: [ self memberNamed: aMemberOrName ].! ! !Archive methodsFor: 'private' stamp: 'nk 2/21/2001 18:14'! memberClass self subclassResponsibility! ! Object subclass: #ArchiveMember instanceVariableNames: 'fileName isCorrupt' classVariableNames: '' poolDictionaries: '' category: 'Compression-Archives'! !ArchiveMember commentStamp: '' prior: 0! This is the abstract superclass for archive members, which are files or directories stored in archives.! !ArchiveMember methodsFor: 'accessing' stamp: 'nk 2/22/2001 16:00'! fileName ^fileName! ! !ArchiveMember methodsFor: 'accessing' stamp: 'nk 2/22/2001 16:00'! fileName: aName fileName := aName! ! !ArchiveMember methodsFor: 'accessing' stamp: 'nk 3/7/2004 16:16'! isCorrupt ^isCorrupt ifNil: [ isCorrupt := false ]! ! !ArchiveMember methodsFor: 'accessing' stamp: 'nk 3/7/2004 16:06'! isCorrupt: aBoolean "Mark this member as being corrupt." isCorrupt := aBoolean! ! !ArchiveMember methodsFor: 'accessing' stamp: 'nk 12/20/2002 15:02'! localFileName: aString "Set my internal filename. Returns the (possibly new) filename. aString will be translated from local FS format into Unix format." ^fileName := aString copyReplaceAll: FileDirectory slash with: '/'.! ! !ArchiveMember methodsFor: 'initialization' stamp: 'ar 3/2/2001 18:46'! close ! ! !ArchiveMember methodsFor: 'initialization' stamp: 'alain.plantec 5/28/2009 09:39'! initialize super initialize. fileName := ''. isCorrupt := false.! ! !ArchiveMember methodsFor: 'printing' stamp: 'nk 12/20/2002 15:11'! printOn: aStream super printOn: aStream. aStream nextPut: $(; nextPutAll: self fileName; nextPut: $)! ! !ArchiveMember methodsFor: 'testing' stamp: 'nk 2/21/2001 19:43'! usesFileNamed: aFileName "Do I require aFileName? That is, do I care if it's clobbered?" ^false! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ArchiveMember class instanceVariableNames: ''! !ArchiveMember class methodsFor: 'as yet unclassified' stamp: 'nk 2/21/2001 18:33'! newDirectoryNamed: aString self subclassResponsibility! ! !ArchiveMember class methodsFor: 'as yet unclassified' stamp: 'nk 2/21/2001 18:32'! newFromFile: aFileName self subclassResponsibility! ! !ArchiveMember class methodsFor: 'as yet unclassified' stamp: 'nk 2/21/2001 18:32'! newFromString: aString self subclassResponsibility! ! Error subclass: #ArithmeticError instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Exceptions-Kernel'! ArrayedCollection variableSubclass: #Array instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Collections-Arrayed'! !Array commentStamp: '' prior: 0! I present an ArrayedCollection whose elements are objects.! !Array methodsFor: 'accessing' stamp: 'ar 8/26/2001 22:02'! atWrap: index "Optimized to go through the primitive if possible" ^ self at: index - 1 \\ self size + 1! ! !Array methodsFor: 'accessing' stamp: 'ar 8/26/2001 22:03'! atWrap: index put: anObject "Optimized to go through the primitive if possible" ^ self at: index - 1 \\ self size + 1 put: anObject! ! !Array methodsFor: 'arithmetic' stamp: 'raok 10/22/2002 20:09'! +* aCollection "Premultiply aCollection by self. aCollection should be an Array or Matrix. The name of this method is APL's +.x squished into Smalltalk syntax." ^aCollection preMultiplyByArray: self ! ! !Array methodsFor: 'arithmetic' stamp: 'raok 10/22/2002 20:10'! preMultiplyByArray: a "Answer a+*self where a is an Array. Arrays are always understood as column vectors, so an n element Array is an n*1 Array. This multiplication is legal iff self size = 1." self size = 1 ifFalse: [self error: 'dimensions do not conform']. ^a * self first! ! !Array methodsFor: 'arithmetic' stamp: 'eem 6/11/2008 12:49'! preMultiplyByMatrix: m "Answer m+*self where m is a Matrix." m columnCount = self size ifFalse: [self error: 'dimensions do not conform']. ^(1 to: m rowCount) collect: [:row | | s | s := 0. 1 to: self size do: [:k | s := (m at: row at: k) * (self at: k) + s]. s]! ! !Array methodsFor: 'comparing' stamp: 'ajh 2/2/2002 15:03'! literalEqual: other self class == other class ifFalse: [^ false]. self size = other size ifFalse: [^ false]. self with: other do: [:e1 :e2 | (e1 literalEqual: e2) ifFalse: [^ false]]. ^ true! ! !Array methodsFor: 'converting' stamp: 'sma 5/12/2000 17:32'! asArray "Answer with the receiver itself." ^ self! ! !Array methodsFor: 'converting' stamp: 'tpr 11/2/2004 11:31'! elementsExchangeIdentityWith: otherArray "This primitive performs a bulk mutation, causing all pointers to the elements of this array to be replaced by pointers to the corresponding elements of otherArray. At the same time, all pointers to the elements of otherArray are replaced by pointers to the corresponding elements of this array. The identityHashes remain with the pointers rather than with the objects so that objects in hashed structures should still be properly indexed after the mutation." otherArray class == Array ifFalse: [^ self error: 'arg must be array']. self size = otherArray size ifFalse: [^ self error: 'arrays must be same size']. (self anySatisfy: [:obj | obj class == SmallInteger]) ifTrue: [^ self error: 'can''t become SmallIntegers']. (otherArray anySatisfy: [:obj | obj class == SmallInteger]) ifTrue: [^ self error: 'can''t become SmallIntegers']. self with: otherArray do:[:a :b| a == b ifTrue:[^self error:'can''t become yourself']]. "Must have failed because not enough space in forwarding table (see ObjectMemory-prepareForwardingTableForBecoming:with:twoWay:). Do GC and try again only once" (Smalltalk bytesLeft: true) = Smalltalk primitiveGarbageCollect ifTrue: [^ self primitiveFailed]. ^ self elementsExchangeIdentityWith: otherArray! ! !Array methodsFor: 'converting' stamp: 'di 3/28/1999 10:23'! elementsForwardIdentityTo: otherArray "This primitive performs a bulk mutation, causing all pointers to the elements of this array to be replaced by pointers to the corresponding elements of otherArray. The identityHashes remain with the pointers rather than with the objects so that the objects in this array should still be properly indexed in any existing hashed structures after the mutation." self primitiveFailed! ! !Array methodsFor: 'converting' stamp: 'brp 9/26/2003 08:09'! elementsForwardIdentityTo: otherArray copyHash: copyHash "This primitive performs a bulk mutation, causing all pointers to the elements of this array to be replaced by pointers to the corresponding elements of otherArray. The identityHashes remain with the pointers rather than with the objects so that the objects in this array should still be properly indexed in any existing hashed structures after the mutation." self primitiveFailed! ! !Array methodsFor: 'converting' stamp: 'nice 4/16/2009 09:35'! evalStrings "Allows you to construct literal arrays. #(true false nil '5@6' 'Set new' '''text string''') evalStrings gives an array with true, false, nil, a Point, a Set, and a String instead of just a bunch of Symbols" ^ self collect: [:each | | item | item := each. (each isString and: [each isSymbol not]) ifTrue: [ item := Compiler evaluate: each]. each class == Array ifTrue: [item := item evalStrings]. item]! ! !Array methodsFor: 'copying' stamp: 'ar 2/11/2001 01:55'! copyWithDependent: newElement self size = 0 ifTrue:[^DependentsArray with: newElement]. ^self copyWith: newElement! ! !Array methodsFor: 'file in/out' stamp: 'tk 9/28/2000 15:35'! objectForDataStream: refStrm | dp | "I am about to be written on an object file. If I am one of two shared global arrays, write a proxy instead." self == (TextConstants at: #DefaultTabsArray) ifTrue: [ dp := DiskProxy global: #TextConstants selector: #at: args: #(DefaultTabsArray). refStrm replace: self with: dp. ^ dp]. self == (TextConstants at: #DefaultMarginTabsArray) ifTrue: [ dp := DiskProxy global: #TextConstants selector: #at: args: #(DefaultMarginTabsArray). refStrm replace: self with: dp. ^ dp]. ^ super objectForDataStream: refStrm! ! !Array methodsFor: 'filter streaming' stamp: 'MPW 1/1/1901 01:42'! byteEncode:aStream aStream writeArray:self. ! ! !Array methodsFor: 'filter streaming' stamp: 'MPW 1/1/1901 01:55'! storeOnStream:aStream self isLiteral ifTrue: [super storeOnStream:aStream] ifFalse:[aStream writeCollection:self]. ! ! !Array methodsFor: 'printing' stamp: 'sd 7/31/2005 21:44'! printOn: aStream self isLiteral ifTrue: [self printAsLiteralFormOn: aStream. ^ self]. self isSelfEvaluating ifTrue: [self printAsSelfEvaluatingFormOn: aStream. ^ self]. super printOn: aStream! ! !Array methodsFor: 'printing'! storeOn: aStream "Use the literal form if possible." self isLiteral ifTrue: [aStream nextPut: $#; nextPut: $(. self do: [:element | element printOn: aStream. aStream space]. aStream nextPut: $)] ifFalse: [super storeOn: aStream]! ! !Array methodsFor: 'self evaluating' stamp: 'sd 7/31/2005 21:44'! isSelfEvaluating ^ (self allSatisfy: [:each | each isSelfEvaluating]) and: [self class == Array]! ! !Array methodsFor: 'self evaluating' stamp: 'sd 7/31/2005 21:44'! printAsLiteralFormOn: aStream aStream nextPut: $#. self printElementsOn: aStream ! ! !Array methodsFor: 'self evaluating' stamp: 'MarcusDenker 10/5/2009 11:44'! printAsSelfEvaluatingFormOn: aStream aStream nextPut: ${. self do: [:el | aStream print: el] separatedBy: [ aStream nextPutAll: '. ']. aStream nextPut: $}! ! !Array methodsFor: 'testing' stamp: 'eem 5/8/2008 11:13'! isArray ^true! ! !Array methodsFor: 'testing' stamp: 'sma 5/12/2000 14:11'! isLiteral ^ self allSatisfy: [:each | each isLiteral]! ! !Array methodsFor: 'private' stamp: 'marcus.denker 9/28/2008 09:57'! hasLiteral: literal "Answer true if literal is identical to any literal in this array, even if imbedded in further array structure. This method is only intended for private use by CompiledMethod hasLiteralSymbol:" 1 to: self size do: [:index | | lit | (lit := self at: index) == literal ifTrue: [^ true]. (lit class == Array and: [lit hasLiteral: literal]) ifTrue: [^ true]]. ^ false! ! !Array methodsFor: 'private' stamp: 'md 3/1/2006 21:09'! hasLiteralSuchThat: testBlock "Answer true if testBlock returns true for any literal in this array, even if imbedded in further Arrays or CompiledMethods. This method is only intended for private use by CompiledMethod hasLiteralSuchThat:" | lit | 1 to: self size do: [:index | (testBlock value: (lit := self at: index)) ifTrue: [^ true]. (lit hasLiteralSuchThat: testBlock) ifTrue: [^ true]]. ^ false! ! !Array methodsFor: 'private' stamp: 'G.C 10/22/2008 09:59'! refersToLiteral: literal "Answer true if literal is identical to any literal in this array, even if imbedded in further array structures or closure methods" 1 to: self size do: [ :index | | lit | (lit := self at: index) == literal ifTrue: [ ^ true ]. (lit refersToLiteral: literal) ifTrue: [ ^ true ] ]. ^ false! ! !Array methodsFor: 'private'! replaceFrom: start to: stop with: replacement startingAt: repStart "Primitive. This destructively replaces elements from start to stop in the receiver starting at index, repStart, in the collection, replacement. Answer the receiver. Range checks are performed in the primitive only. Optional. See Object documentation whatIsAPrimitive." super replaceFrom: start to: stop with: replacement startingAt: repStart! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Array class instanceVariableNames: ''! !Array class methodsFor: 'brace support' stamp: 'di 11/18/1999 22:53'! braceStream: nElements "This method is used in compilation of brace constructs. It MUST NOT be deleted or altered." ^ WriteStream basicNew braceArray: (self new: nElements) ! ! !Array class methodsFor: 'brace support' stamp: 'di 11/19/1999 08:16'! braceWith: a "This method is used in compilation of brace constructs. It MUST NOT be deleted or altered." | array | array := self new: 1. array at: 1 put: a. ^ array! ! !Array class methodsFor: 'brace support' stamp: 'di 11/19/1999 08:15'! braceWith: a with: b "This method is used in compilation of brace constructs. It MUST NOT be deleted or altered." | array | array := self new: 2. array at: 1 put: a. array at: 2 put: b. ^ array! ! !Array class methodsFor: 'brace support' stamp: 'di 11/19/1999 08:17'! braceWith: a with: b with: c "This method is used in compilation of brace constructs. It MUST NOT be deleted or altered." | array | array := self new: 3. array at: 1 put: a. array at: 2 put: b. array at: 3 put: c. ^ array! ! !Array class methodsFor: 'brace support' stamp: 'di 11/19/1999 08:17'! braceWith: a with: b with: c with: d "This method is used in compilation of brace constructs. It MUST NOT be deleted or altered." | array | array := self new: 4. array at: 1 put: a. array at: 2 put: b. array at: 3 put: c. array at: 4 put: d. ^ array! ! !Array class methodsFor: 'brace support' stamp: 'di 11/19/1999 08:16'! braceWithNone "This method is used in compilation of brace constructs. It MUST NOT be deleted or altered." ^ self new: 0! ! !Array class methodsFor: 'instance creation' stamp: 'md 7/19/2004 12:34'! new: sizeRequested "Answer an instance of this class with the number of indexable variables specified by the argument, sizeRequested. This is a shortcut (direct call of primitive, no #initialize, for performance" "This method runs primitively if successful" ^ self basicNew: sizeRequested "Exceptional conditions will be handled in basicNew:" ! ! TestCase subclass: #ArrayLiteralTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Tests-Compiler'! !ArrayLiteralTest methodsFor: 'initialization' stamp: 'avi 2/16/2004 21:09'! tearDown self class removeSelector: #array! ! !ArrayLiteralTest methodsFor: 'tests' stamp: 'lr 1/29/2009 20:34'! testByteArrayBase self class compile: 'array ^ #[2r1010 8r333 16rFF]'. self assert: (self array isKindOf: ByteArray). self assert: (self array size = 3). self assert: (self array first = 10). self assert: (self array second = 219). self assert: (self array last = 255) ! ! !ArrayLiteralTest methodsFor: 'tests' stamp: 'lr 1/29/2009 20:35'! testByteArrayEmpty self class compile: 'array ^ #[]'. self assert: (self array isKindOf: ByteArray). self assert: (self array isEmpty)! ! !ArrayLiteralTest methodsFor: 'tests' stamp: 'lr 1/29/2009 20:36'! testByteArrayLiteral self class compile: 'array ^ #[ 1 2 3 4 ]'. self assert: (self array = self array). self assert: (self array == self array)! ! !ArrayLiteralTest methodsFor: 'tests' stamp: 'lr 1/29/2009 20:45'! testByteArrayLong self class compile: 'array ^ #[ ' , ((0 to: 255) inject: ' ' into: [ :r :e | r , ' ' , e asString ]) , ' ]'. self assert: (self array isKindOf: ByteArray). self assert: (self array size = 256). 0 to: 255 do: [ :index | self assert: (self array at: index + 1) = index ]! ! !ArrayLiteralTest methodsFor: 'tests' stamp: 'lr 1/29/2009 20:32'! testByteArrayRange self class compile: 'array ^ #[ 0 255 ]'. self assert: (self array isKindOf: ByteArray). self assert: (self array size = 2). self assert: (self array first = 0). self assert: (self array last = 255)! ! !ArrayLiteralTest methodsFor: 'tests' stamp: 'Henrik Sperre Johansen 3/23/2009 13:55'! testByteArrayWithinArray self class compile: 'array ^ #( #[1] #[2] )'. self assert: (self array isKindOf: Array). self assert: (self array size = 2). self assert: (self array first isKindOf: ByteArray). self assert: (self array first first = 1). self assert: (self array last isKindOf: ByteArray). self assert: (self array last first = 2) ! ! !ArrayLiteralTest methodsFor: 'tests' stamp: 'avi 2/16/2004 21:08'! testReservedIdentifiers self class compile: 'array ^ #(nil true false)'. self assert: self array = {nil. true. false}.! ! !ArrayLiteralTest methodsFor: 'tests' stamp: 'avi 2/16/2004 21:09'! testSymbols self class compile: 'array ^ #(#nil #true #false #''nil'' #''true'' #''false'')'. self assert: self array = {#nil. #true. #false. #nil. #true. #false}.! ! CollectionRootTest subclass: #ArrayTest uses: TEmptySequenceableTest + TSequencedElementAccessTest + TCloneTest + TIncludesWithIdentityCheckTest + TCopyTest + TSetArithmetic + TCreationWithTest + TPutBasicTest + TConvertTest - {} + TSortTest + TOccurrencesForMultiplinessTest + TIterateSequencedReadableTest + TSequencedConcatenationTest + TReplacementSequencedTest + TAsStringCommaAndDelimiterSequenceableTest + TBeginsEndsWith + TPrintOnSequencedTest + TIndexAccess + TSubCollectionAccess + TConvertAsSetForMultiplinessIdentityTest + TCopyPartOfSequenceable + TCopySequenceableSameContents + TCopySequenceableWithOrWithoutSpecificElements + TCopySequenceableWithReplacement + TIndexAccessForMultipliness + TCopyPartOfSequenceableForMultipliness + TConvertAsSortedTest + TPutTest + TSequencedStructuralEqualityTest instanceVariableNames: 'example1 literalArray selfEvaluatingArray otherArray nonSEArray1 nonSEarray2 example2 empty collection result withoutEqualElements withEqualElements withCharacters unsortedCollection sortedInAscendingOrderCollection sizeCollection collectionNotIncluded removedCollection elementInForCopy elementNotInForCopy firstIndex secondIndex replacementCollection indexArray valueArray nonEmptyMoreThan1Element subCollectionNotIn replacementCollectionSameSize oldSubCollection nonEmpty1Element collectionOfCollection collectionOfFloatWithEqualElements floatCollectionWithSameBeginingAnEnd collectionWithoutNil duplicateElement collection5Elements' classVariableNames: '' poolDictionaries: '' category: 'CollectionsTests-Arrayed'! !ArrayTest commentStamp: '' prior: 0! This is the unit test for the class Array. Unit tests are a good way to exercise the functionality of your system in a repeatable and automatic manner. They are therefore recommended if you plan to release anything. For more information, see: - http://www.c2.com/cgi/wiki?UnitTest - http://minnow.cc.gatech.edu/squeak/1547 - the sunit class category! !ArrayTest methodsFor: 'helpers' stamp: 'stephane.ducasse 1/12/2009 17:12'! aValue ^ 33! ! !ArrayTest methodsFor: 'helpers' stamp: 'stephane.ducasse 1/12/2009 17:13'! anIndex ^ 2! ! !ArrayTest methodsFor: 'helpers' stamp: 'stephane.ducasse 1/12/2009 17:19'! anotherValue ^ 66! ! !ArrayTest methodsFor: 'initialization' stamp: 'stephane.ducasse 10/6/2008 16:53'! collection ^ collection ! ! !ArrayTest methodsFor: 'initialization' stamp: 'stephane.ducasse 10/5/2008 15:06'! empty ^ empty! ! !ArrayTest methodsFor: 'initialization' stamp: 'stephane.ducasse 10/5/2008 15:06'! nonEmpty ^ example1! ! !ArrayTest methodsFor: 'initialization' stamp: 'stephane.ducasse 10/6/2008 16:54'! result ^ result! ! !ArrayTest methodsFor: 'initialization' stamp: 'delaunay 5/14/2009 14:00'! setUp literalArray := #(1 true 3 #four). selfEvaluatingArray := { 1. true. (3/4). Color black. (2 to: 4) . 5 }. nonSEArray1 := { 1 . Set with: 1 }. nonSEarray2 := { Smalltalk associationAt: #Array }. example1 := #(1 2 3 4 5) copy. indexArray:= {2. 3. 4.}. valueArray:={0. 0. 0.}. oldSubCollection:= {2. 3. 4.}. nonEmptyMoreThan1Element:= example1. subCollectionNotIn:= {1. 8. 3.}. collectionNotIncluded:= {7. 8. 9.}. removedCollection:= { 2. 4. }. example2 := {1. 2. 3/4. 4. 5}. collection := #(1 -2 3 1). collectionWithoutNil := #( 1 2 3 4). result := {SmallInteger. SmallInteger. SmallInteger. SmallInteger.}. empty := #(). duplicateElement := 5.2. withEqualElements := {1.5. duplicateElement . 6.1. 2.0. duplicateElement .} . withoutEqualElements := {1.1. 4.4. 6.5. 2.4. 3.1.}. withCharacters := {$a. $x. $d. $c. $m.}. unsortedCollection := {1. 2. 8. 5. 6. 7.}. sortedInAscendingOrderCollection := {1. 2. 3. 4. 5. 6.}. elementInForCopy:= 2. elementNotInForCopy:= 9. firstIndex:= 2. secondIndex:= 4. replacementCollection:= {4. 3. 2. 1.}. replacementCollectionSameSize := {5. 4. 3.}. nonEmpty1Element:={ 5.}. collectionOfCollection:={1.5. 5.5. 6.5.}. collectionOfFloatWithEqualElements:={1.5. 5.5. 6.5. 1.5}. floatCollectionWithSameBeginingAnEnd := {1.5. 5.5. 1.5 copy}. collection5Elements := { 1. 2. 5. 3. 4.}.! ! !ArrayTest methodsFor: 'parameters'! accessValuePutIn "return access the element put in the non-empty collection" ^ self perform: self selectorToAccessValuePutIn! ! !ArrayTest methodsFor: 'parameters'! accessValuePutInOn: s "return access the element put in the non-empty collection" ^ s perform: self selectorToAccessValuePutIn! ! !ArrayTest methodsFor: 'parameters' stamp: 'stephane.ducasse 10/5/2008 15:12'! selectorToAccessValuePutIn "return the selector of the method that should be invoked to access an element" ^ #second! ! !ArrayTest methodsFor: 'parameters' stamp: 'stephane.ducasse 10/9/2008 18:49'! valuePutIn "the value that we will put in the non empty collection" ^ 2! ! !ArrayTest methodsFor: 'requirements' stamp: 'stephane.ducasse 10/30/2008 19:02'! accessCollection ^ example1! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/24/2009 14:45'! anotherElementNotIn ^ elementNotInForCopy ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/29/2009 12:05'! anotherElementOrAssociationIn " return an element (or an association for Dictionary ) present in 'collection' " ^ self collection anyOne.! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/29/2009 12:05'! anotherElementOrAssociationNotIn " return an element (or an association for Dictionary )not present in 'collection' " ^ elementNotInForCopy ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/9/2009 11:11'! collectionInForIncluding ^ self nonEmpty copyWithoutFirst.! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/23/2009 15:16'! collectionMoreThan1NoDuplicates " return a collection of size 5 without equal elements" ^ withoutEqualElements ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 14:01'! collectionMoreThan5Elements " return a collection including at least 5 elements" ^ collection5Elements ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 3/30/2009 10:51'! collectionNotIncluded ^ collectionNotIncluded.! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/15/2009 14:07'! collectionOfFloat ^ collectionOfCollection! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/17/2009 10:28'! collectionWith1TimeSubcollection ^ (self oldSubCollection copyWithoutFirst),self oldSubCollection,(self oldSubCollection copyWithoutFirst). ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/17/2009 10:29'! collectionWith2TimeSubcollection ^ (self oldSubCollection copyWithoutFirst),self oldSubCollection,(self oldSubCollection copyWithoutFirst),self oldSubCollection .! ! !ArrayTest methodsFor: 'requirements' stamp: 'cyrille.delaunay 3/26/2009 09:58'! collectionWithCharacters ^ withCharacters.! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/28/2009 13:49'! collectionWithCopy "return a collection of type 'self collectionWIithoutEqualsElements clas' containing no elements equals ( with identity equality) but 2 elements only equals with classic equality" | result collection | collection := OrderedCollection withAll: self elementsCopyNonIdenticalWithoutEqualElements. collection add: collection first copy. result := self elementsCopyNonIdenticalWithoutEqualElements class withAll: collection. ^ result! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/28/2009 10:22'! collectionWithCopyNonIdentical " return a collection that include elements for which 'copy' return a different object (this is not the case of SmallInteger)" ^ collectionOfCollection! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/17/2009 15:24'! collectionWithElementsToRemove ^ removedCollection! ! !ArrayTest methodsFor: 'requirements' stamp: 'cyrille.delaunay 3/26/2009 09:57'! collectionWithEqualElements ^ withEqualElements.! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/28/2009 13:50'! collectionWithIdentical "return a collection of type : 'self collectionWIithoutEqualsElements class containing two elements equals ( with identity equality)" | result collection element | collection := OrderedCollection withAll: self elementsCopyNonIdenticalWithoutEqualElements. element := collection first. collection add: element. result := self elementsCopyNonIdenticalWithoutEqualElements class withAll: collection. ^ result! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/27/2009 14:17'! collectionWithNonIdentitySameAtEndAndBegining " return a collection with elements at end and begining equals only with classic equality (they are not the same object). (others elements of the collection are not equal to those elements)" ^ floatCollectionWithSameBeginingAnEnd ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/22/2009 11:15'! collectionWithSameAtEndAndBegining " return a collection with elements at end and begining equals . (others elements of the collection are not equal to those elements)" ^ floatCollectionWithSameBeginingAnEnd ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/24/2009 10:27'! collectionWithSortableElements " return a collection elements that can be sorte ( understanding message ' < ' or ' > ')" ^ withoutEqualElements ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 10:25'! collectionWithoutEqualElements ^ withoutEqualElements .! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/16/2009 15:49'! collectionWithoutEqualsElements ^ withoutEqualElements ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/23/2009 11:39'! collectionWithoutNilElements " return a collection that doesn't includes a nil element and that doesn't includes equal elements'" ^ collectionWithoutNil ! ! !ArrayTest methodsFor: 'requirements' stamp: 'damienpollet 1/30/2009 17:27'! element ^ 3! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/15/2009 14:22'! elementInCollectionOfFloat ^ collectionOfCollection atRandom! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 3/31/2009 10:28'! elementInForCopy ^ elementInForCopy ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 14:39'! elementInForElementAccessing " return an element inculded in 'accessCollection '" ^ self accessCollection anyOne! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/14/2009 13:55'! elementInForIncludesTest ^ elementInForCopy ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/10/2009 14:49'! elementInForIndexAccess ^ elementInForCopy ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/23/2009 15:18'! elementInForIndexAccessing ^ withoutEqualElements anyOne! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/2/2009 11:54'! elementInForOccurrences ^ elementInForCopy ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/6/2009 10:16'! elementInForReplacement ^ elementInForCopy ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/24/2009 14:45'! elementNotIn "return an element not included in 'nonEmpty' " ^ elementNotInForCopy ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 3/31/2009 10:29'! elementNotInForCopy ^ elementNotInForCopy ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 14:39'! elementNotInForElementAccessing " return an element not included in 'accessCollection' " ^ elementNotInForCopy ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/7/2009 11:18'! elementNotInForIndexAccessing ^elementNotInForCopy ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/24/2009 14:45'! elementNotInForOccurrences ^ elementNotInForCopy ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/13/2009 16:13'! elementTwiceInForOccurrences " return an element included exactly two time in # collectionWithEqualElements" ^ duplicateElement ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/28/2009 13:46'! elementsCopyNonIdenticalWithoutEqualElements " return a collection that does niot include equal elements ( classic equality )" ^ collectionOfCollection! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/2/2009 16:41'! firstCollection ^example1 ! ! !ArrayTest methodsFor: 'requirements' stamp: 'damiencassou 1/27/2009 10:35'! firstEven "Returns the first even number of #collection" ^ -2! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 3/31/2009 10:29'! firstIndex ^ firstIndex ! ! !ArrayTest methodsFor: 'requirements' stamp: 'damiencassou 1/27/2009 10:35'! firstOdd "Returns the first odd number of #collection" ^ 1! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/21/2009 14:00'! floatCollectionWithSameAtEndAndBegining " return a collection with elements at end and begining equals only with classic equality (they are not the same object). (others elements of the collection are not equal to those elements)" ^ floatCollectionWithSameBeginingAnEnd ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 3/31/2009 16:00'! indexArray ^ indexArray .! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/16/2009 15:59'! indexInForCollectionWithoutDuplicates ^ 2.! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/16/2009 16:56'! indexInNonEmpty ^ 2 ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/9/2009 15:53'! integerCollection ^example1 .! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 10:28'! integerCollectionWithoutEqualElements ^{1. 2. 6. 5.}! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/27/2009 10:53'! moreThan3Elements " return a collection including atLeast 3 elements" ^ example1 ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/27/2009 10:53'! moreThan4Elements " return a collection including at leat 4 elements" ^ example1 ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/6/2009 10:16'! newElement ^999! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/8/2009 11:40'! nonEmpty1Element ^ nonEmpty1Element ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/2/2009 15:20'! nonEmptyMoreThan1Element ^nonEmptyMoreThan1Element .! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/6/2009 11:41'! oldSubCollection ^oldSubCollection ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 3/31/2009 10:29'! replacementCollection ^replacementCollection .! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/6/2009 10:32'! replacementCollectionSameSize ^replacementCollectionSameSize ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/23/2009 11:29'! resultForCollectElementsClass " return the retsult expected by collecting the class of each element of collectionWithoutNilElements" ^ result ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/2/2009 16:41'! secondCollection ^example2 ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 3/31/2009 10:29'! secondIndex ^ secondIndex ! ! !ArrayTest methodsFor: 'requirements' stamp: 'damienpollet 1/13/2009 16:59'! sizeCollection ^ self collection! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 3/31/2009 14:08'! smallerIndex ^ firstIndex -1! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 3/27/2009 15:20'! sortedInAscendingOrderCollection ^sortedInAscendingOrderCollection . ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/3/2009 11:35'! subCollectionNotIn ^subCollectionNotIn ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 3/27/2009 15:20'! unsortedCollection ^unsortedCollection .! ! !ArrayTest methodsFor: 'requirements'! valueArray " return a collection (with the same size than 'indexArray' )of values to be put in 'nonEmpty' at indexes in 'indexArray' " | result | result := Array new: self indexArray size. 1 to: result size do: [:i | result at:i put: (self aValue ). ]. ^ result.! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/28/2009 14:11'! withEqualElements " return a collection of float including equal elements (classic equality)" ^ collectionOfFloatWithEqualElements! ! !ArrayTest methodsFor: 'test - copy' stamp: 'delaunay 4/17/2009 15:26'! elementToAdd ^ 55! ! !ArrayTest methodsFor: 'test - creation' stamp: 'stephane.ducasse 12/9/2008 22:00'! collectionClass ^ Array! ! !ArrayTest methodsFor: 'test - creation'! testOfSize "self debug: #testOfSize" | aCol | aCol := self collectionClass ofSize: 3. self assert: (aCol size = 3). ! ! !ArrayTest methodsFor: 'test - creation'! testWith "self debug: #testWith" | aCol element | element := self collectionMoreThan5Elements anyOne. aCol := self collectionClass with: element. self assert: (aCol includes: element).! ! !ArrayTest methodsFor: 'test - creation'! testWithAll "self debug: #testWithAll" | aCol collection | collection := self collectionMoreThan5Elements asOrderedCollection . aCol := self collectionClass withAll: collection . collection do: [ :each | self assert: (aCol occurrencesOf: each ) = ( collection occurrencesOf: each ) ]. self assert: (aCol size = collection size ).! ! !ArrayTest methodsFor: 'test - creation'! testWithWith "self debug: #testWithWith" | aCol collection element1 element2 | collection := self collectionMoreThan5Elements asOrderedCollection copyFrom: 1 to: 2 . element1 := collection at: 1. element2 := collection at:2. aCol := self collectionClass with: element1 with: element2 . self assert: (aCol occurrencesOf: element1 ) == ( collection occurrencesOf: element1). self assert: (aCol occurrencesOf: element2 ) == ( collection occurrencesOf: element2). ! ! !ArrayTest methodsFor: 'test - creation'! testWithWithWith "self debug: #testWithWithWith" | aCol collection | collection := self collectionMoreThan5Elements asOrderedCollection copyFrom:1 to: 3 . aCol := self collectionClass with: (collection at:1) with: ( collection at:2 ) with: ( collection at: 3). 1 to: 3 do: [ :i | self assert: ( aCol occurrencesOf: ( collection at: i ) ) = ( collection occurrencesOf: ( collection at: i ) ) ].! ! !ArrayTest methodsFor: 'test - creation'! testWithWithWithWith "self debug: #testWithWithWithWith" | aCol collection | collection := self collectionMoreThan5Elements asOrderedCollection copyFrom: 1 to: 4. aCol := self collectionClass with: (collection at:1) with: ( collection at:2 ) with: ( collection at: 3) with: ( collection at: 4). 1 to: 3 do: [ :i | self assert: ( aCol occurrencesOf: ( collection at: i ) ) = ( collection occurrencesOf: ( collection at: i ) ) ].! ! !ArrayTest methodsFor: 'test - creation'! testWithWithWithWithWith "self debug: #testWithWithWithWithWith" | aCol collection | collection := self collectionMoreThan5Elements asOrderedCollection copyFrom: 1 to: 5 . aCol := self collectionClass with: (collection at:1) with: ( collection at:2 ) with: ( collection at: 3) with: (collection at: 4 ) with: ( collection at: 5 ). 1 to: 3 do: [ :i | self assert: ( aCol occurrencesOf: ( collection at: i ) ) = ( collection occurrencesOf: ( collection at: i ) ) ].! ! !ArrayTest methodsFor: 'test - equality'! testEqualSign "self debug: #testEqualSign" self deny: (self empty = self nonEmpty).! ! !ArrayTest methodsFor: 'test - equality'! testEqualSignIsTrueForNonIdenticalButEqualCollections "self debug: #testEqualSignIsTrueForNonIdenticalButEqualCollections" self assert: (self empty = self empty copy). self assert: (self empty copy = self empty). self assert: (self empty copy = self empty copy). self assert: (self nonEmpty = self nonEmpty copy). self assert: (self nonEmpty copy = self nonEmpty). self assert: (self nonEmpty copy = self nonEmpty copy).! ! !ArrayTest methodsFor: 'test - equality'! testEqualSignOfIdenticalCollectionObjects "self debug: #testEqualSignOfIdenticalCollectionObjects" self assert: (self empty = self empty). self assert: (self nonEmpty = self nonEmpty). ! ! !ArrayTest methodsFor: 'test - iterate' stamp: 'luc.fabresse 11/29/2008 23:10'! expectedSizeAfterReject ^1! ! !ArrayTest methodsFor: 'test - iterate' stamp: 'stephane.ducasse 10/6/2008 17:39'! speciesClass ^ Array! ! !ArrayTest methodsFor: 'test - iterate' stamp: 'damienpollet 1/13/2009 16:28'! testAnySatisfy self assert: ( self collection anySatisfy: [:each | each = -2]). self deny: (self collection anySatisfy: [:each | each isString]).! ! !ArrayTest methodsFor: 'test - iterate' stamp: 'delaunay 4/14/2009 14:12'! testDo | res | res := OrderedCollection new. self collection do: [:each | res add: each class]. self assert: res asArray = self result.! ! !ArrayTest methodsFor: 'test - iterate' stamp: 'delaunay 4/14/2009 14:13'! testDo2 | res | res := OrderedCollection new. self collection do: [:each | res add: each class]. self assert: res asArray = self result. ! ! !ArrayTest methodsFor: 'testing' stamp: 'zz 12/5/2005 17:12'! testIsArray self assert: example1 isArray! ! !ArrayTest methodsFor: 'testing' stamp: 'apb 4/21/2006 08:59'! testIsLiteral "We work with a copy of literalArray, to avoid corrupting the code." | l | l := literalArray copy. self assert: l isLiteral. l at: 1 put: self class. self deny: l isLiteral! ! !ArrayTest methodsFor: 'testing' stamp: 'zz 12/5/2005 17:18'! testIsSelfEvaluating self assert: example1 isSelfEvaluating. example1 at: 1 put: Bag new. self deny: example1 isSelfEvaluating. example1 at: 1 put: 1.! ! !ArrayTest methodsFor: 'testing' stamp: 'zz 12/5/2005 17:50'! testLiteralEqual self deny: (example1 literalEqual: example1 asIntegerArray)! ! !ArrayTest methodsFor: 'testing' stamp: 'dc 5/24/2007 10:56'! testNewWithSize |array| array := Array new: 5. self assert: array size = 5. 1 to: 5 do: [:index | self assert: (array at: index) isNil]! ! !ArrayTest methodsFor: 'testing' stamp: 'stephane.ducasse 10/6/2008 16:53'! testPremultiply self assert: example1 +* #(2 ) = #(2 4 6 8 10 ) ! ! !ArrayTest methodsFor: 'testing' stamp: 'delaunay 5/4/2009 15:15'! testPrinting self assert: literalArray printString = '#(1 true 3 #four)'. self assert: (literalArray = (Compiler evaluate: literalArray printString)). "self assert: selfEvaluatingArray printString = '{1. true. (3/4). Color black. (2 to: 4). 5}'." self assert: (selfEvaluatingArray = (Compiler evaluate: selfEvaluatingArray printString)). self assert: nonSEArray1 printString = 'an Array(1 a Set(1))'. self assert: nonSEarray2 printString = '{#Array->Array}' ! ! !ArrayTest methodsFor: 'tests - accessing' stamp: 'delaunay 4/10/2009 16:19'! testAtWrap2 | tabTest | tabTest := #(5 6 8 ). self assert: (tabTest atWrap: 2) = 6. self assert: (tabTest atWrap: 7) = 5. self assert: (tabTest atWrap: 5) = 6. self assert: (tabTest atWrap: 0) = 8. self assert: (tabTest atWrap: 1) = 5. self assert: (tabTest atWrap: -2) = 5! ! !ArrayTest methodsFor: 'tests - as identity set'! testAsIdentitySetWithIdentityEqualsElements | result | result := self collectionWithIdentical asIdentitySet. " Only one element should have been removed as two elements are equals with Identity equality" self assert: result size = (self collectionWithIdentical size - 1). self collectionWithIdentical do: [ :each | (self collectionWithIdentical occurrencesOf: each) > 1 ifTrue: [ "the two elements equals only with classic equality shouldn't 'have been removed" self assert: (result asOrderedCollection occurrencesOf: each) = 1 " the other elements are still here" ] ifFalse: [ self assert: (result asOrderedCollection occurrencesOf: each) = 1 ] ]. self assert: result class = IdentitySet! ! !ArrayTest methodsFor: 'tests - as identity set'! testAsIdentitySetWithoutIdentityEqualsElements | result collection | collection := self collectionWithCopy. result := collection asIdentitySet. " no elements should have been removed as no elements are equels with Identity equality" self assert: result size = collection size. collection do: [ :each | (collection occurrencesOf: each) = (result asOrderedCollection occurrencesOf: each) ]. self assert: result class = IdentitySet! ! !ArrayTest methodsFor: 'tests - as set tests'! testAsIdentitySetWithEqualsElements | result collection | collection := self withEqualElements . result := collection asIdentitySet. collection do: [ :each | self assert: (result occurrencesOf: each) = 1 ]. self assert: result class = IdentitySet.! ! !ArrayTest methodsFor: 'tests - as set tests'! testAsSetWithEqualsElements | result | result := self withEqualElements asSet. self withEqualElements do: [ :each | self assert: (result occurrencesOf: each) = 1 ]. self assert: result class = Set! ! !ArrayTest methodsFor: 'tests - as sorted collection'! testAsSortedArray | result collection | collection := self collectionWithSortableElements . result := collection asSortedArray. self assert: (result class includesBehavior: Array). self assert: result isSorted. self assert: result size = collection size! ! !ArrayTest methodsFor: 'tests - as sorted collection'! testAsSortedCollection | aCollection result | aCollection := self collectionWithSortableElements . result := aCollection asSortedCollection. self assert: (result class includesBehavior: SortedCollection). result do: [ :each | self assert: (aCollection occurrencesOf: each) = (result occurrencesOf: each) ]. self assert: result size = aCollection size.! ! !ArrayTest methodsFor: 'tests - as sorted collection'! testAsSortedCollectionWithSortBlock | result tmp | result := self collectionWithSortableElements asSortedCollection: [:a :b | a > b]. self assert: (result class includesBehavior: SortedCollection). result do: [ :each | self assert: (self collectionWithSortableElements occurrencesOf: each) = (result occurrencesOf: each) ]. self assert: result size = self collectionWithSortableElements size. tmp:=result at: 1. result do: [:each| self assert: tmp>=each. tmp:=each]. ! ! !ArrayTest methodsFor: 'tests - at put'! testAtPut "self debug: #testAtPut" self nonEmpty at: self anIndex put: self aValue. self assert: (self nonEmpty at: self anIndex) = self aValue. ! ! !ArrayTest methodsFor: 'tests - at put'! testAtPutOutOfBounds "self debug: #testAtPutOutOfBounds" self should: [self empty at: self anIndex put: self aValue] raise: Error ! ! !ArrayTest methodsFor: 'tests - at put'! testAtPutTwoValues "self debug: #testAtPutTwoValues" self nonEmpty at: self anIndex put: self aValue. self nonEmpty at: self anIndex put: self anotherValue. self assert: (self nonEmpty at: self anIndex) = self anotherValue.! ! !ArrayTest methodsFor: 'tests - begins ends with'! testsBeginsWith self assert: (self nonEmpty beginsWith:(self nonEmpty copyUpTo: self nonEmpty size)). self assert: (self nonEmpty beginsWith:(self nonEmpty )). self deny: (self nonEmpty beginsWith:(self nonEmpty copyWith:self nonEmpty first)).! ! !ArrayTest methodsFor: 'tests - begins ends with'! testsBeginsWithEmpty self deny: (self nonEmpty beginsWith:(self empty)). self deny: (self empty beginsWith:(self nonEmpty )). ! ! !ArrayTest methodsFor: 'tests - begins ends with'! testsEndsWith self assert: (self nonEmpty endsWith:(self nonEmpty copyWithoutFirst)). self assert: (self nonEmpty endsWith:(self nonEmpty )). self deny: (self nonEmpty endsWith:(self nonEmpty copyWith:self nonEmpty first)).! ! !ArrayTest methodsFor: 'tests - begins ends with'! testsEndsWithEmpty self deny: (self nonEmpty endsWith:(self empty )). self deny: (self empty endsWith:(self nonEmpty )). ! ! !ArrayTest methodsFor: 'tests - comma and delimiter'! testAsCommaStringEmpty self assert: self empty asCommaString = ''. self assert: self empty asCommaStringAnd = ''. ! ! !ArrayTest methodsFor: 'tests - comma and delimiter'! testAsCommaStringMore "self assert: self oneTwoThreeItemCol asCommaString = '1, 2, 3'. self assert: self oneTwoThreeItemCol asCommaStringAnd = '1, 2 and 3' " | result resultAnd index allElementsAsString | result:= self nonEmpty asCommaString . resultAnd:= self nonEmpty asCommaStringAnd . index := 1. (result findBetweenSubStrs: ',' )do: [:each | index = 1 ifTrue: [self assert: each= ((self nonEmpty at:index)asString)] ifFalse: [self assert: each= (' ',(self nonEmpty at:index) asString)]. index:=index+1 ]. "verifying esultAnd :" allElementsAsString:=(resultAnd findBetweenSubStrs: ',' ). 1 to: allElementsAsString size do: [:i | i<(allElementsAsString size ) ifTrue: [ i = 1 ifTrue:[self assert: (allElementsAsString at:i)=((self nonEmpty at:i) asString)] ifFalse:[self assert: (allElementsAsString at:i)=(' ',(self nonEmpty at:i) asString)] ]. i=(allElementsAsString size) ifTrue:[ i = 1 ifTrue:[self assert: (allElementsAsString at:i)=( (self nonEmpty at:i ) asString ,' and ', (self nonEmpty at: ( i + 1) ) asString )] ifFalse:[self assert: (allElementsAsString at:i)=( ' ' , (self nonEmpty at:i ) asString ,' and ', (self nonEmpty at: ( i + 1) ) asString )] ]. ].! ! !ArrayTest methodsFor: 'tests - comma and delimiter'! testAsCommaStringOne "self assert: self oneItemCol asCommaString = '1'. self assert: self oneItemCol asCommaStringAnd = '1'." self assert: self nonEmpty1Element asCommaString = (self nonEmpty1Element first asString). self assert: self nonEmpty1Element asCommaStringAnd = (self nonEmpty1Element first asString). ! ! !ArrayTest methodsFor: 'tests - comma and delimiter'! testAsStringOnDelimiterEmpty | delim emptyStream | delim := ', '. emptyStream := ReadWriteStream on: ''. self empty asStringOn: emptyStream delimiter: delim. self assert: emptyStream contents = ''. ! ! !ArrayTest methodsFor: 'tests - comma and delimiter'! testAsStringOnDelimiterLastEmpty | delim emptyStream | delim := ', '. emptyStream := ReadWriteStream on: ''. self empty asStringOn: emptyStream delimiter: delim last:'and'. self assert: emptyStream contents = ''. ! ! !ArrayTest methodsFor: 'tests - comma and delimiter'! testAsStringOnDelimiterLastMore | delim multiItemStream result last allElementsAsString | delim := ', '. last := 'and'. result:=''. multiItemStream := ReadWriteStream on:result. self nonEmpty asStringOn: multiItemStream delimiter: ', ' last: last. allElementsAsString:=(result findBetweenSubStrs: ', ' ). 1 to: allElementsAsString size do: [:i | i<(allElementsAsString size-1 ) ifTrue: [self assert: (allElementsAsString at:i)=((self nonEmpty at:i)asString)]. i=(allElementsAsString size-1) ifTrue:[ self deny: (allElementsAsString at:i)=(last)asString]. i=(allElementsAsString size) ifTrue: [self assert: (allElementsAsString at:i)=((self nonEmpty at:(i-1))asString)]. ]. ! ! !ArrayTest methodsFor: 'tests - comma and delimiter'! testAsStringOnDelimiterLastOne | delim oneItemStream result | delim := ', '. result:=''. oneItemStream := ReadWriteStream on: result. self nonEmpty1Element asStringOn: oneItemStream delimiter: delim last: 'and'. oneItemStream do:[:each | self assert: each = (self nonEmpty1Element first asString)]. ! ! !ArrayTest methodsFor: 'tests - comma and delimiter'! testAsStringOnDelimiterMore | delim multiItemStream result index | "delim := ', '. multiItemStream := '' readWrite. self oneTwoThreeItemCol asStringOn: multiItemStream delimiter: ', '. self assert: multiItemStream contents = '1, 2, 3'." delim := ', '. result:=''. multiItemStream := ReadWriteStream on:result. self nonEmpty asStringOn: multiItemStream delimiter: ', '. index:=1. (result findBetweenSubStrs: ', ' )do: [:each | self assert: each= ((self nonEmpty at:index)asString). index:=index+1 ].! ! !ArrayTest methodsFor: 'tests - comma and delimiter'! testAsStringOnDelimiterOne | delim oneItemStream result | "delim := ', '. oneItemStream := '' readWrite. self oneItemCol asStringOn: oneItemStream delimiter: delim. self assert: oneItemStream contents = '1'." delim := ', '. result:=''. oneItemStream := ReadWriteStream on: result. self nonEmpty1Element asStringOn: oneItemStream delimiter: delim. oneItemStream do:[:each | self assert: each = (self nonEmpty1Element first asString)]. ! ! !ArrayTest methodsFor: 'tests - concatenation'! testConcatenation | result index | result:= self firstCollection,self secondCollection . "first part : " index := 1. self firstCollection do: [:each | self assert: (self firstCollection at: index)=each. index := index+1.]. "second part : " 1 to: self secondCollection size do: [:i | self assert: (self secondCollection at:i)= (result at:index). index:=index+1]. "size : " self assert: result size = (self firstCollection size + self secondCollection size).! ! !ArrayTest methodsFor: 'tests - concatenation'! testConcatenationWithEmpty | result | result:= self empty,self secondCollection . 1 to: self secondCollection size do: [:i | self assert: (self secondCollection at:i)= (result at:i). ]. "size : " self assert: result size = ( self secondCollection size).! ! !ArrayTest methodsFor: 'tests - converting'! assertNoDuplicates: aCollection whenConvertedTo: aClass | result | result := self collectionWithEqualElements asIdentitySet. self assert: (result class includesBehavior: IdentitySet). self collectionWithEqualElements do: [ :initial | self assert: (result occurrencesOf: initial) = 1 ]! ! !ArrayTest methodsFor: 'tests - converting'! assertNonDuplicatedContents: aCollection whenConvertedTo: aClass | result | result := aCollection perform: ('as' , aClass name) asSymbol. self assert: (result class includesBehavior: aClass). result do: [ :each | self assert: (aCollection occurrencesOf: each) = (result occurrencesOf: each) ]. ^ result! ! !ArrayTest methodsFor: 'tests - converting' stamp: 'cyrille.delaunay 3/26/2009 12:35'! assertSameContents: aCollection whenConvertedTo: aClass | result | result := aCollection perform: ('as' , aClass name) asSymbol. self assert: (result class includesBehavior: aClass). result do: [ :each | self assert: (aCollection occurrencesOf: each) = (result occurrencesOf: each) ]. self assert: result size = aCollection size! ! !ArrayTest methodsFor: 'tests - converting' stamp: 'cyrille.delaunay 3/26/2009 14:55'! testAsArray "self debug: #testAsArray3" self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: Array! ! !ArrayTest methodsFor: 'tests - converting'! testAsBag self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: Bag! ! !ArrayTest methodsFor: 'tests - converting'! testAsByteArray | res | self shouldnt: [self integerCollectionWithoutEqualElements ] raise: Error. self integerCollectionWithoutEqualElements do: [ :each | self assert: each class = SmallInteger] . res := true. self integerCollectionWithoutEqualElements detect: [ :each | (self integerCollectionWithoutEqualElements occurrencesOf: each) > 1 ] ifNone: [ res := false ]. self assert: res = false. self assertSameContents: self integerCollectionWithoutEqualElements whenConvertedTo: ByteArray! ! !ArrayTest methodsFor: 'tests - converting'! testAsIdentitySet "test with a collection without equal elements :" self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: IdentitySet. ! ! !ArrayTest methodsFor: 'tests - converting'! testAsOrderedCollection self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: OrderedCollection! ! !ArrayTest methodsFor: 'tests - converting'! testAsSet | | "test with a collection without equal elements :" self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: Set. ! ! !ArrayTest methodsFor: 'tests - copy' stamp: 'delaunay 4/17/2009 15:26'! testCopyEmptyWith "self debug: #testCopyWith" | res | res := self empty copyWith: self elementToAdd. self assert: res size = (self empty size + 1). self assert: (res includes: self elementToAdd)! ! !ArrayTest methodsFor: 'tests - copy' stamp: 'delaunay 4/17/2009 15:26'! testCopyEmptyWithout "self debug: #testCopyEmptyWithout" | res | res := self empty copyWithout: self elementToAdd. self assert: res size = self empty size. self deny: (res includes: self elementToAdd)! ! !ArrayTest methodsFor: 'tests - copy' stamp: 'delaunay 4/17/2009 15:24'! testCopyEmptyWithoutAll "self debug: #testCopyEmptyWithoutAll" | res | res := self empty copyWithoutAll: self collectionWithElementsToRemove. self assert: res size = self empty size. self collectionWithElementsToRemove do: [ :each | self deny: (res includes: each) ]! ! !ArrayTest methodsFor: 'tests - copy' stamp: 'delaunay 4/17/2009 15:26'! testCopyNonEmptyWith "self debug: #testCopyNonEmptyWith" | res | res := self nonEmpty copyWith: self elementToAdd. "here we do not test the size since for a non empty set we would get a problem. Then in addition copy is not about duplicate management. The element should be in at the end." self assert: (res includes: self elementToAdd). self nonEmpty do: [ :each | res includes: each ]! ! !ArrayTest methodsFor: 'tests - copy'! testCopyNonEmptyWithout "self debug: #testCopyNonEmptyWithout" | res anElementOfTheCollection | anElementOfTheCollection := self nonEmpty anyOne. res := (self nonEmpty copyWithout: anElementOfTheCollection). "here we do not test the size since for a non empty set we would get a problem. Then in addition copy is not about duplicate management. The element should be in at the end." self deny: (res includes: anElementOfTheCollection). self nonEmpty do: [:each | (each = anElementOfTheCollection) ifFalse: [self assert: (res includes: each)]]. ! ! !ArrayTest methodsFor: 'tests - copy' stamp: 'delaunay 4/17/2009 15:24'! testCopyNonEmptyWithoutAll "self debug: #testCopyNonEmptyWithoutAll" | res | res := self nonEmpty copyWithoutAll: self collectionWithElementsToRemove. "here we do not test the size since for a non empty set we would get a problem. Then in addition copy is not about duplicate management. The element should be in at the end." self collectionWithElementsToRemove do: [ :each | self deny: (res includes: each) ]. self nonEmpty do: [ :each | (self collectionWithElementsToRemove includes: each) ifFalse: [ self assert: (res includes: each) ] ]! ! !ArrayTest methodsFor: 'tests - copy' stamp: 'delaunay 3/30/2009 10:33'! testCopyNonEmptyWithoutAllNotIncluded ! ! !ArrayTest methodsFor: 'tests - copy' stamp: 'delaunay 4/17/2009 15:26'! testCopyNonEmptyWithoutNotIncluded "self debug: #testCopyNonEmptyWithoutNotIncluded" | res | res := self nonEmpty copyWithout: self elementToAdd. "here we do not test the size since for a non empty set we would get a problem. Then in addition copy is not about duplicate management. The element should be in at the end." self nonEmpty do: [ :each | self assert: (res includes: each) ]! ! !ArrayTest methodsFor: 'tests - copy - clone'! testCopyCreatesNewObject "self debug: #testCopyCreatesNewObject" | copy | copy := self nonEmpty copy. self deny: self nonEmpty == copy. ! ! !ArrayTest methodsFor: 'tests - copy - clone'! testCopyEmpty "self debug: #testCopyEmpty" | copy | copy := self empty copy. self assert: copy isEmpty.! ! !ArrayTest methodsFor: 'tests - copy - clone'! testCopyNonEmpty "self debug: #testCopyNonEmpty" | copy | copy := self nonEmpty copy. self deny: copy isEmpty. self assert: copy size = self nonEmpty size. self nonEmpty do: [:each | copy includes: each]! ! !ArrayTest methodsFor: 'tests - copying part of sequenceable'! testCopyAfter | result index collection | collection := self collectionWithoutEqualsElements . index:= self indexInForCollectionWithoutDuplicates . result := collection copyAfter: (collection at:index ). "verifying content: " (1) to: result size do: [:i | self assert: (collection at:(i + index ))=(result at: (i))]. "verify size: " self assert: result size = (collection size - index).! ! !ArrayTest methodsFor: 'tests - copying part of sequenceable'! testCopyAfterEmpty | result | result := self empty copyAfter: self collectionWithoutEqualsElements first. self assert: result isEmpty. ! ! !ArrayTest methodsFor: 'tests - copying part of sequenceable'! testCopyAfterLast | result index collection | collection := self collectionWithoutEqualsElements . index:= self indexInForCollectionWithoutDuplicates . result := collection copyAfterLast: (collection at:index ). "verifying content: " (1) to: result size do: [:i | self assert: (collection at:(i + index ))=(result at: (i))]. "verify size: " self assert: result size = (collection size - index).! ! !ArrayTest methodsFor: 'tests - copying part of sequenceable'! testCopyAfterLastEmpty | result | result := self empty copyAfterLast: self collectionWithoutEqualsElements first. self assert: result isEmpty.! ! !ArrayTest methodsFor: 'tests - copying part of sequenceable'! testCopyEmptyMethod | result | result := self collectionWithoutEqualsElements copyEmpty . self assert: result isEmpty . self assert: result class= self nonEmpty class.! ! !ArrayTest methodsFor: 'tests - copying part of sequenceable'! testCopyFromTo | result index collection | collection := self collectionWithoutEqualsElements . index :=self indexInForCollectionWithoutDuplicates . result := collection copyFrom: index to: collection size . "verify content of 'result' : " 1 to: result size do: [:i | self assert: (result at:i)=(collection at: (i + index - 1))]. "verify size of 'result' : " self assert: result size = (collection size - index + 1).! ! !ArrayTest methodsFor: 'tests - copying part of sequenceable'! testCopyUpTo | result index collection | collection := self collectionWithoutEqualsElements . index:= self indexInForCollectionWithoutDuplicates . result := collection copyUpTo: (collection at:index). "verify content of 'result' :" 1 to: result size do: [:i| self assert: (collection at:i)=(result at:i)]. "verify size of 'result' :" self assert: result size = (index-1). ! ! !ArrayTest methodsFor: 'tests - copying part of sequenceable'! testCopyUpToEmpty | result | result := self empty copyUpTo: self collectionWithoutEqualsElements first. self assert: result isEmpty. ! ! !ArrayTest methodsFor: 'tests - copying part of sequenceable'! testCopyUpToLast | result index collection | collection := self collectionWithoutEqualsElements . index:= self indexInForCollectionWithoutDuplicates . result := collection copyUpToLast: (collection at:index). "verify content of 'result' :" 1 to: result size do: [:i| self assert: (collection at:i)=(result at:i)]. "verify size of 'result' :" self assert: result size = (index-1).! ! !ArrayTest methodsFor: 'tests - copying part of sequenceable'! testCopyUpToLastEmpty | result | result := self empty copyUpToLast: self collectionWithoutEqualsElements first. self assert: result isEmpty.! ! !ArrayTest methodsFor: 'tests - copying part of sequenceable for multipliness'! testCopyAfterLastWithDuplicate | result element collection | collection := self collectionWithSameAtEndAndBegining . element := collection first. " collectionWithSameAtEndAndBegining first and last elements are equals. 'copyAfter:' should copy after the last occurence of element :" result := collection copyAfterLast: (element ). "verifying content: " self assert: result isEmpty. ! ! !ArrayTest methodsFor: 'tests - copying part of sequenceable for multipliness'! testCopyAfterWithDuplicate | result element collection | collection := self collectionWithSameAtEndAndBegining . element := collection last. " collectionWithSameAtEndAndBegining first and last elements are equals. 'copyAfter:' should copy after the first occurence :" result := collection copyAfter: (element ). "verifying content: " 1 to: result size do: [:i | self assert: (collection at:(i + 1 )) = (result at: (i)) ]. "verify size: " self assert: result size = (collection size - 1).! ! !ArrayTest methodsFor: 'tests - copying part of sequenceable for multipliness'! testCopyUpToLastWithDuplicate | result element collection | collection := self collectionWithSameAtEndAndBegining . element := collection first. " collectionWithSameAtEndAndBegining first and last elements are equals. 'copyUpToLast:' should copy until the last occurence :" result := collection copyUpToLast: (element ). "verifying content: " 1 to: result size do: [:i | self assert: (result at: i ) = ( collection at: i ) ]. self assert: result size = (collection size - 1). ! ! !ArrayTest methodsFor: 'tests - copying part of sequenceable for multipliness'! testCopyUpToWithDuplicate | result element collection | collection := self collectionWithSameAtEndAndBegining . element := collection last. " collectionWithSameAtEndAndBegining first and last elements are equals. 'copyUpTo:' should copy until the first occurence :" result := collection copyUpTo: (element ). "verifying content: " self assert: result isEmpty. ! ! !ArrayTest methodsFor: 'tests - copying same contents'! testReverse | result | result := self nonEmpty reverse . "verify content of 'result: '" 1 to: result size do: [:i | self assert: ((result at:i)=(self nonEmpty at:(self nonEmpty size-i+1)))]. "verify size of 'result' :" self assert: result size=self nonEmpty size.! ! !ArrayTest methodsFor: 'tests - copying same contents'! testReversed | result | result := self nonEmpty reversed . "verify content of 'result: '" 1 to: result size do: [:i | self assert: ((result at:i)=(self nonEmpty at:(self nonEmpty size-i+1)))]. "verify size of 'result' :" self assert: result size=self nonEmpty size.! ! !ArrayTest methodsFor: 'tests - copying same contents'! testShallowCopy | result | result := self nonEmpty shallowCopy . "verify content of 'result: '" 1 to: self nonEmpty size do: [:i | self assert: ((result at:i)=(self nonEmpty at:i))]. "verify size of 'result' :" self assert: result size=self nonEmpty size.! ! !ArrayTest methodsFor: 'tests - copying same contents'! testShallowCopyEmpty | result | result := self empty shallowCopy . self assert: result isEmpty .! ! !ArrayTest methodsFor: 'tests - copying same contents'! testShuffled | result | result := self nonEmpty shuffled . "verify content of 'result: '" result do: [:each | self assert: (self nonEmpty occurrencesOf: each)=(result occurrencesOf: each)]. "verify size of 'result' :" self assert: result size=self nonEmpty size.! ! !ArrayTest methodsFor: 'tests - copying same contents'! testSortBy " can only be used if the collection tested can include sortable elements :" | result tmp | self shouldnt: [ self collectionWithSortableElements ] raise: Error. self shouldnt: [self collectionWithSortableElements anyOne < self collectionWithSortableElements anyOne] raise: Error. result := self collectionWithSortableElements sortBy: [ :a :b | a < b ]. "verify content of 'result' : " result do: [ :each | (self collectionWithSortableElements occurrencesOf: each) = (result occurrencesOf: each) ]. tmp := result first. result do: [ :each | self assert: each >= tmp. tmp := each ]. "verify size of 'result' :" self assert: result size = self collectionWithSortableElements size! ! !ArrayTest methodsFor: 'tests - copying with or without'! testCopyWithFirst | index element result | index:= self indexInNonEmpty . element:= self nonEmpty at: index. result := self nonEmpty copyWithFirst: element. self assert: result size = (self nonEmpty size + 1). self assert: result first = element . 2 to: result size do: [ :i | self assert: (result at: i) = ( self nonEmpty at: ( i - 1 ))].! ! !ArrayTest methodsFor: 'tests - copying with or without'! testCopyWithSequenceable | result index element | index := self indexInNonEmpty . element := self nonEmpty at: index. result := self nonEmpty copyWith: (element ). self assert: result size = (self nonEmpty size + 1). self assert: result last = element . 1 to: (result size - 1) do: [ :i | self assert: (result at: i) = ( self nonEmpty at: ( i ))].! ! !ArrayTest methodsFor: 'tests - copying with or without'! testCopyWithoutFirst | result | result := self nonEmpty copyWithoutFirst. self assert: result size = (self nonEmpty size - 1). 1 to: result size do: [:i | self assert: (result at: i)= (self nonEmpty at: (i + 1))].! ! !ArrayTest methodsFor: 'tests - copying with or without'! testCopyWithoutIndex | result index | index := self indexInNonEmpty . result := self nonEmpty copyWithoutIndex: index . "verify content of 'result:'" 1 to: result size do: [:i | i<( index ) ifTrue: [self assert: ((result at:i )= (self nonEmpty at:i))]. i>=( index ) ifTrue: [self assert: (result at:i )= (self nonEmpty at:(i+1))]]. "verify size of result : " self assert: result size=(self nonEmpty size -1).! ! !ArrayTest methodsFor: 'tests - copying with or without'! testForceToPaddingStartWith | result element | element := self nonEmpty at: self indexInNonEmpty . result := self nonEmpty forceTo: (self nonEmpty size+2) paddingStartWith: ( element ). "verify content of 'result' : " 1 to: 2 do: [:i | self assert: ( element ) = ( result at:(i) ) ]. 3 to: result size do: [:i | self assert: ( result at:i ) = ( self nonEmpty at:(i-2) ) ]. "verify size of 'result' :" self assert: result size = (self nonEmpty size + 2).! ! !ArrayTest methodsFor: 'tests - copying with or without'! testForceToPaddingWith | result element | element := self nonEmpty at: self indexInNonEmpty . result := self nonEmpty forceTo: (self nonEmpty size+2) paddingWith: ( element ). "verify content of 'result' : " 1 to: self nonEmpty size do: [:i | self assert: ( self nonEmpty at: i ) = ( result at:(i) ). ]. (result size - 1) to: result size do: [:i | self assert: ( result at:i ) = ( element ) ]. "verify size of 'result' :" self assert: result size = (self nonEmpty size + 2).! ! !ArrayTest methodsFor: 'tests - copying with replacement'! firstIndexesOf: subCollection in: collection " return an OrderedCollection with the first indexes of the occurrences of subCollection in collection " | tmp result currentIndex | tmp:= collection. result:= OrderedCollection new. currentIndex := 1. [tmp isEmpty ]whileFalse: [ (tmp beginsWith: subCollection) ifTrue: [ result add: currentIndex. 1 to: subCollection size do: [:i | tmp := tmp copyWithoutFirst. currentIndex := currentIndex + 1] ] ifFalse: [ tmp := tmp copyWithoutFirst. currentIndex := currentIndex +1. ] ]. ^ result. ! ! !ArrayTest methodsFor: 'tests - copying with replacement'! testCopyReplaceAllWith1Occurence | result firstIndexesOfOccurrence index endPartIndexResult endPartIndexCollection | result := self collectionWith1TimeSubcollection copyReplaceAll: self oldSubCollection with: self replacementCollection . "detecting indexes of olSubCollection" firstIndexesOfOccurrence := self firstIndexesOf: self oldSubCollection in: self collectionWith1TimeSubcollection . index:= firstIndexesOfOccurrence at: 1. "verify content of 'result' : " "first part of 'result'' : '" 1 to: (index -1) do: [ :i | self assert: (self collectionWith1TimeSubcollection at:i)=(result at: i) ]. " middle part containing replacementCollection : " index to: (index + self replacementCollection size-1) do: [ :i | self assert: ( result at: i )=(self replacementCollection at: ( i - index + 1 )) ]. " end part :" endPartIndexResult := index + self replacementCollection size . endPartIndexCollection := index + self oldSubCollection size . 1 to: (result size - endPartIndexResult - 1 ) do: [ :i | self assert: (result at: ( endPartIndexResult + i - 1 ) ) = (self collectionWith1TimeSubcollection at: ( endPartIndexCollection + i - 1 ) ). ]. ! ! !ArrayTest methodsFor: 'tests - copying with replacement'! testCopyReplaceAllWithManyOccurence | result firstIndexesOfOccurrence resultBetweenPartIndex collectionBetweenPartIndex diff | " testing fixture here as this method may be not used for collection that can't contain equals element :" self shouldnt: [self collectionWith2TimeSubcollection ]raise: Error. self assert: (self howMany: self oldSubCollection in: self collectionWith2TimeSubcollection ) = 2. " test :" diff := self replacementCollection size - self oldSubCollection size. result := self collectionWith2TimeSubcollection copyReplaceAll: self oldSubCollection with: self replacementCollection . "detecting indexes of olSubCollection" firstIndexesOfOccurrence := self firstIndexesOf: self oldSubCollection in: self collectionWith2TimeSubcollection . " verifying that replacementCollection has been put in places of oldSubCollections " firstIndexesOfOccurrence do: [ :each | (firstIndexesOfOccurrence indexOf: each) = 1 ifTrue: [ each to: self replacementCollection size do: [ :i | self assert: (result at: i) = ( self replacementCollection at: ( i - each + 1 ) ) ]. ] ifFalse:[ (each + diff) to: self replacementCollection size do: [ :i | self assert: (result at: i) = ( self replacementCollection at: ( i - each + 1 ) ) ]. ]. ]. " verifying that the 'between' parts correspond to the initial collection : " 1 to: firstIndexesOfOccurrence size do: [ :i | i = 1 " specific comportement for the begining of the collection :" ifTrue: [ 1 to: ((firstIndexesOfOccurrence at: i) - 1 ) do: [ :j | self assert: (result at: i) = (self collectionWith2TimeSubcollection at: i) ] ] " between parts till the end : " ifFalse: [ resultBetweenPartIndex := (firstIndexesOfOccurrence at: (i -1)) + self replacementCollection size. collectionBetweenPartIndex := (firstIndexesOfOccurrence at: (i -1)) + self oldSubCollection size. 1 to: ( firstIndexesOfOccurrence at: i) - collectionBetweenPartIndex - 1 do: [ :j | self assert: (result at: (resultBetweenPartIndex + i - 1)) = (self collectionWith2TimeSubcollection at: (collectionBetweenPartIndex +i - 1)) ] ] ]. "final part :" 1 to: (self collectionWith2TimeSubcollection size - (firstIndexesOfOccurrence last + self oldSubCollection size ) ) do: [ :i | self assert: ( result at:(firstIndexesOfOccurrence last + self replacementCollection size -1) + i ) = ( self collectionWith2TimeSubcollection at:(firstIndexesOfOccurrence last + self oldSubCollection size -1) + i ) . ]! ! !ArrayTest methodsFor: 'tests - copying with replacement'! testCopyReplaceFromToWith | result indexOfSubcollection lastIndexOfOldSubcollection lastIndexOfReplacementCollection | indexOfSubcollection := (self firstIndexesOf: self oldSubCollection in: self collectionWith1TimeSubcollection) at: 1. lastIndexOfOldSubcollection := indexOfSubcollection + self oldSubCollection size -1. lastIndexOfReplacementCollection := indexOfSubcollection + self replacementCollection size -1. result := self collectionWith1TimeSubcollection copyReplaceFrom: indexOfSubcollection to: lastIndexOfOldSubcollection with: self replacementCollection . "verify content of 'result' : " "first part of 'result' " 1 to: (indexOfSubcollection - 1) do: [ :i | self assert: (self collectionWith1TimeSubcollection at:i) = (result at: i) ]. " middle part containing replacementCollection : " (indexOfSubcollection ) to: ( lastIndexOfReplacementCollection ) do: [ :i | self assert: (result at: i)=(self replacementCollection at: (i - indexOfSubcollection +1)) ]. " end part :" 1 to: (result size - lastIndexOfReplacementCollection ) do: [ :i | self assert: (result at: ( lastIndexOfReplacementCollection + i ) ) = (self collectionWith1TimeSubcollection at: ( lastIndexOfOldSubcollection + i ) ). ]. ! ! !ArrayTest methodsFor: 'tests - copying with replacement'! testCopyReplaceFromToWithInsertion | result indexOfSubcollection | indexOfSubcollection := (self firstIndexesOf: self oldSubCollection in: self collectionWith1TimeSubcollection) at: 1. result := self collectionWith1TimeSubcollection copyReplaceFrom: indexOfSubcollection to: ( indexOfSubcollection - 1 ) with: self replacementCollection . "verify content of 'result' : " "first part of 'result'' : '" 1 to: (indexOfSubcollection -1) do: [ :i | self assert: (self collectionWith1TimeSubcollection at:i)=(result at: i) ]. " middle part containing replacementCollection : " indexOfSubcollection to: (indexOfSubcollection + self replacementCollection size-1) do: [ :i | self assert: ( result at: i )=(self replacementCollection at: ( i - indexOfSubcollection +1 )) ]. " end part :" (indexOfSubcollection + self replacementCollection size) to: (result size) do: [:i| self assert: (result at: i)=(self collectionWith1TimeSubcollection at: (i-self replacementCollection size))]. " verify size: " self assert: result size=(self collectionWith1TimeSubcollection size + self replacementCollection size). ! ! !ArrayTest methodsFor: 'tests - element accessing'! testAfter "self debug: #testAfter" self assert: (self moreThan4Elements after: (self moreThan4Elements at: 1)) = (self moreThan4Elements at: 2). self should: [ self moreThan4Elements after: (self moreThan4Elements at: self moreThan4Elements size) ] raise: Error. self should: [ self moreThan4Elements after: self elementNotInForElementAccessing ] raise: Error! ! !ArrayTest methodsFor: 'tests - element accessing'! testAfterIfAbsent "self debug: #testAfterIfAbsent" self assert: (self moreThan4Elements after: (self moreThan4Elements at: 1) ifAbsent: [ 33 ]) = (self moreThan4Elements at: 2). self assert: (self moreThan4Elements after: (self moreThan4Elements at: self moreThan4Elements size) ifAbsent: [ 33 ]) == 33. self assert: (self moreThan4Elements after: self elementNotInForElementAccessing ifAbsent: [ 33 ]) = 33! ! !ArrayTest methodsFor: 'tests - element accessing'! testAt "self debug: #testAt" " self assert: (self accessCollection at: 1) = 1. self assert: (self accessCollection at: 2) = 2. " | index | index := self moreThan4Elements indexOf: self elementInForElementAccessing. self assert: (self moreThan4Elements at: index) = self elementInForElementAccessing! ! !ArrayTest methodsFor: 'tests - element accessing'! testAtAll "self debug: #testAtAll" " self flag: #theCollectionshouldbe102030intheFixture. self assert: (self accessCollection atAll: #(2 1)) first = self accessCollection second. self assert: (self accessCollection atAll: #(2)) first = self accessCollection second." | result | result := self moreThan4Elements atAll: #(2 1 2 ). self assert: (result at: 1) = (self moreThan4Elements at: 2). self assert: (result at: 2) = (self moreThan4Elements at: 1). self assert: (result at: 3) = (self moreThan4Elements at: 2). self assert: (self moreThan4Elements atAll: #()) = self moreThan4Elements species new! ! !ArrayTest methodsFor: 'tests - element accessing'! testAtIfAbsent "self debug: #testAt" | absent | absent := false. self moreThan4Elements at: self moreThan4Elements size + 1 ifAbsent: [ absent := true ]. self assert: absent = true. absent := false. self moreThan4Elements at: self moreThan4Elements size ifAbsent: [ absent := true ]. self assert: absent = false! ! !ArrayTest methodsFor: 'tests - element accessing'! testAtLast "self debug: #testAtLast" | index | self assert: (self moreThan4Elements atLast: 1) = self moreThan4Elements last. "tmp:=1. self do: [:each | each =self elementInForIndexAccessing ifTrue:[index:=tmp]. tmp:=tmp+1]." index := self moreThan4Elements indexOf: self elementInForElementAccessing. self assert: (self moreThan4Elements atLast: index) = (self moreThan4Elements at: self moreThan4Elements size - index + 1)! ! !ArrayTest methodsFor: 'tests - element accessing'! testAtLastError "self debug: #testAtLast" self should: [ self moreThan4Elements atLast: self moreThan4Elements size + 1 ] raise: Error! ! !ArrayTest methodsFor: 'tests - element accessing'! testAtLastIfAbsent "self debug: #testAtLastIfAbsent" self assert: (self moreThan4Elements atLast: 1 ifAbsent: [ nil ]) = self moreThan4Elements last. self assert: (self moreThan4Elements atLast: self moreThan4Elements size + 1 ifAbsent: [ 222 ]) = 222! ! !ArrayTest methodsFor: 'tests - element accessing'! testAtOutOfBounds "self debug: #testAtOutOfBounds" self should: [ self moreThan4Elements at: self moreThan4Elements size + 1 ] raise: Error. self should: [ self moreThan4Elements at: -1 ] raise: Error! ! !ArrayTest methodsFor: 'tests - element accessing'! testAtPin "self debug: #testAtPin" self assert: (self moreThan4Elements atPin: 2) = self moreThan4Elements second. self assert: (self moreThan4Elements atPin: 99) = self moreThan4Elements last. self assert: (self moreThan4Elements atPin: -99) = self moreThan4Elements first! ! !ArrayTest methodsFor: 'tests - element accessing'! testAtRandom | result | result := self nonEmpty atRandom . self assert: (self nonEmpty includes: result).! ! !ArrayTest methodsFor: 'tests - element accessing'! testAtWrap "self debug: #testAt" " self assert: (self accessCollection at: 1) = 1. self assert: (self accessCollection at: 2) = 2. " | index | index := self moreThan4Elements indexOf: self elementInForElementAccessing. self assert: (self moreThan4Elements atWrap: index) = self elementInForElementAccessing. self assert: (self moreThan4Elements atWrap: index + self moreThan4Elements size) = self elementInForElementAccessing. self assert: (self moreThan4Elements atWrap: index - self moreThan4Elements size) = self elementInForElementAccessing. self assert: (self moreThan4Elements atWrap: 1 + self moreThan4Elements size) = (self moreThan4Elements at: 1)! ! !ArrayTest methodsFor: 'tests - element accessing'! testBefore "self debug: #testBefore" self assert: (self moreThan4Elements before: (self moreThan4Elements at: 2)) = (self moreThan4Elements at: 1). self should: [ self moreThan4Elements before: (self moreThan4Elements at: 1) ] raise: Error. self should: [ self moreThan4Elements before: 66 ] raise: Error! ! !ArrayTest methodsFor: 'tests - element accessing'! testBeforeIfAbsent "self debug: #testBefore" self assert: (self moreThan4Elements before: (self moreThan4Elements at: 1) ifAbsent: [ 99 ]) = 99. self assert: (self moreThan4Elements before: (self moreThan4Elements at: 2) ifAbsent: [ 99 ]) = (self moreThan4Elements at: 1)! ! !ArrayTest methodsFor: 'tests - element accessing'! testFirstSecondThird "self debug: #testFirstSecondThird" self assert: self moreThan4Elements first = (self moreThan4Elements at: 1). self assert: self moreThan4Elements second = (self moreThan4Elements at: 2). self assert: self moreThan4Elements third = (self moreThan4Elements at: 3). self assert: self moreThan4Elements fourth = (self moreThan4Elements at: 4)! ! !ArrayTest methodsFor: 'tests - element accessing'! testLast "self debug: #testLast" self assert: self moreThan4Elements last = (self moreThan4Elements at: self moreThan4Elements size)! ! !ArrayTest methodsFor: 'tests - element accessing'! testMiddle "self debug: #testMiddle" self assert: self moreThan4Elements middle = (self moreThan4Elements at: self moreThan4Elements size // 2 + 1)! ! !ArrayTest methodsFor: 'tests - equality'! testEqualSignForSequenceableCollections "self debug: #testEqualSign" self deny: (self nonEmpty = self nonEmpty asSet). self deny: (self nonEmpty reversed = self nonEmpty). self deny: (self nonEmpty = self nonEmpty reversed).! ! !ArrayTest methodsFor: 'tests - equality'! testHasEqualElements "self debug: #testHasEqualElements" self deny: (self empty hasEqualElements: self nonEmpty). self deny: (self nonEmpty hasEqualElements: self nonEmpty asSet). self deny: (self nonEmpty reversed hasEqualElements: self nonEmpty). self deny: (self nonEmpty hasEqualElements: self nonEmpty reversed).! ! !ArrayTest methodsFor: 'tests - equality'! testHasEqualElementsIsTrueForNonIdenticalButEqualCollections "self debug: #testHasEqualElementsIsTrueForNonIdenticalButEqualCollections" self assert: (self empty hasEqualElements: self empty copy). self assert: (self empty copy hasEqualElements: self empty). self assert: (self empty copy hasEqualElements: self empty copy). self assert: (self nonEmpty hasEqualElements: self nonEmpty copy). self assert: (self nonEmpty copy hasEqualElements: self nonEmpty). self assert: (self nonEmpty copy hasEqualElements: self nonEmpty copy).! ! !ArrayTest methodsFor: 'tests - equality'! testHasEqualElementsOfIdenticalCollectionObjects "self debug: #testHasEqualElementsOfIdenticalCollectionObjects" self assert: (self empty hasEqualElements: self empty). self assert: (self nonEmpty hasEqualElements: self nonEmpty). ! ! !ArrayTest methodsFor: 'tests - fixture'! howMany: subCollection in: collection " return an integer representing how many time 'subCollection' appears in 'collection' " | tmp nTime | tmp:= collection. nTime:= 0. [tmp isEmpty ]whileFalse: [ (tmp beginsWith: subCollection) ifTrue: [ nTime := nTime + 1. 1 to: subCollection size do: [:i | tmp := tmp copyWithoutFirst.] ] ifFalse: [tmp := tmp copyWithoutFirst.] ]. ^ nTime. ! ! !ArrayTest methodsFor: 'tests - fixture' stamp: 'delaunay 4/17/2009 15:26'! test0CopyTest self shouldnt: self empty raise: Error. self assert: self empty size = 0. self shouldnt: self nonEmpty raise: Error. self assert: (self nonEmpty size = 0) not. self shouldnt: self collectionWithElementsToRemove raise: Error. self assert: (self collectionWithElementsToRemove size = 0) not. self shouldnt: self elementToAdd raise: Error! ! !ArrayTest methodsFor: 'tests - fixture'! test0FixtureAsSetForIdentityMultiplinessTest "a collection (of elements for which copy is not identical ) without equal elements:" | element res | self shouldnt: [ self elementsCopyNonIdenticalWithoutEqualElements ]raise: Error. element := self elementsCopyNonIdenticalWithoutEqualElements anyOne. self deny: element copy == element . res := true. self elementsCopyNonIdenticalWithoutEqualElements detect: [ :each | (self elementsCopyNonIdenticalWithoutEqualElements occurrencesOf: each) > 1 ] ifNone: [ res := false ]. self assert: res = false ! ! !ArrayTest methodsFor: 'tests - fixture'! test0FixtureAsStringCommaAndDelimiterTest self shouldnt: [self nonEmpty] raise:Error . self deny: self nonEmpty isEmpty. self shouldnt: [self empty] raise:Error . self assert: self empty isEmpty. self shouldnt: [self nonEmpty1Element ] raise:Error . self assert: self nonEmpty1Element size=1.! ! !ArrayTest methodsFor: 'tests - fixture'! test0FixtureBeginsEndsWithTest self shouldnt: [self nonEmpty ] raise: Error. self deny: self nonEmpty isEmpty. self assert: self nonEmpty size>1. self shouldnt: [self empty ] raise: Error. self assert: self empty isEmpty.! ! !ArrayTest methodsFor: 'tests - fixture'! test0FixtureCloneTest self shouldnt: [ self nonEmpty ] raise: Error. self deny: self nonEmpty isEmpty. self shouldnt: [ self empty ] raise: Error. self assert: self empty isEmpty. ! ! !ArrayTest methodsFor: 'tests - fixture'! test0FixtureConverAsSortedTest self shouldnt: [self collectionWithSortableElements ] raise: Error. self deny: self collectionWithSortableElements isEmpty .! ! !ArrayTest methodsFor: 'tests - fixture'! test0FixtureCopyPartOfForMultipliness self shouldnt: [self collectionWithSameAtEndAndBegining ] raise: Error. self assert: self collectionWithSameAtEndAndBegining first = self collectionWithSameAtEndAndBegining last. self assert: self collectionWithSameAtEndAndBegining size > 1. 1 to: self collectionWithSameAtEndAndBegining size do: [:i | (i > 1 ) & (i < self collectionWithSameAtEndAndBegining size) ifTrue: [ self deny: (self collectionWithSameAtEndAndBegining at:i) = (self collectionWithSameAtEndAndBegining first)]. ]! ! !ArrayTest methodsFor: 'tests - fixture'! test0FixtureCopyPartOfSequenceableTest self shouldnt: [self collectionWithoutEqualsElements ] raise: Error. self collectionWithoutEqualsElements do: [:each | self assert: (self collectionWithoutEqualsElements occurrencesOf: each)=1]. self shouldnt: [self indexInForCollectionWithoutDuplicates ] raise: Error. self assert: self indexInForCollectionWithoutDuplicates >0 & self indexInForCollectionWithoutDuplicates < self collectionWithoutEqualsElements size. self shouldnt: [self empty] raise: Error. self assert: self empty isEmpty .! ! !ArrayTest methodsFor: 'tests - fixture'! test0FixtureCopySameContentsTest self shouldnt: [self nonEmpty ] raise: Error. self deny: self nonEmpty isEmpty. self shouldnt: [self empty ] raise: Error. self assert: self empty isEmpty. ! ! !ArrayTest methodsFor: 'tests - fixture'! test0FixtureCopyWithOrWithoutSpecificElementsTest self shouldnt: [self nonEmpty ] raise: Error. self deny: self nonEmpty isEmpty . self shouldnt: [self indexInNonEmpty ] raise: Error. self assert: self indexInNonEmpty > 0. self assert: self indexInNonEmpty <= self nonEmpty size.! ! !ArrayTest methodsFor: 'tests - fixture'! test0FixtureCopyWithReplacementTest self shouldnt: [self replacementCollection ]raise: Error. self shouldnt: [self oldSubCollection] raise: Error. self shouldnt: [self collectionWith1TimeSubcollection ]raise: Error. self assert: (self howMany: self oldSubCollection in: self collectionWith1TimeSubcollection ) = 1. ! ! !ArrayTest methodsFor: 'tests - fixture'! test0FixtureCreationWithTest self shouldnt: [ self collectionMoreThan5Elements ] raise: Error. self assert: self collectionMoreThan5Elements size >= 5.! ! !ArrayTest methodsFor: 'tests - fixture'! test0FixtureEmptySequenceableTest self shouldnt: [ self nonEmpty ] raise: Error. self deny: self nonEmpty isEmpty . self shouldnt: [ self empty ] raise: Error. self assert: self empty isEmpty.! ! !ArrayTest methodsFor: 'tests - fixture' stamp: 'delaunay 4/15/2009 14:37'! test0FixtureIncludeTest | elementIn | self shouldnt: [ self nonEmpty ] raise: Error. self deny: self nonEmpty isEmpty. self shouldnt: [ self elementNotIn ] raise: Error. elementIn := true. self nonEmpty detect: [ :each | each = self elementNotIn ] ifNone: [ elementIn := false ]. self assert: elementIn = false. self shouldnt: [ self anotherElementNotIn ] raise: Error. elementIn := true. self nonEmpty detect: [ :each | each = self anotherElementNotIn ] ifNone: [ elementIn := false ]. self assert: elementIn = false. self shouldnt: [ self collection ] raise: Error. "self shouldnt: [self collectionInForIncluding ] raise: Error." "collectionIn:=false. index:=1. 1 to: self nonEmpty size do: [:i| collectionIn = false ifTrue:[(self nonEmpty at:i)=(self collectionInForIncluding at:index) ifTrue:[ index=self collectionInForIncluding ifTrue:[collectionIn := true]. index:=index+1.] ifFalse:[index:=1]. ] ]. self assert: collectionIn=true." self shouldnt: [ self empty ] raise: Error. self assert: self empty isEmpty. self shouldnt: [ self collectionOfFloat ] raise: Error. self collectionOfFloat do: [ :each | self assert: each class = Float ]. self shouldnt: [ self elementInForIncludesTest ] raise: Error. elementIn := true. self nonEmpty detect: [ :each | each = self elementInForIncludesTest ] ifNone: [ elementIn := false ]. self assert: elementIn = true! ! !ArrayTest methodsFor: 'tests - fixture'! test0FixtureIncludeWithIdentityTest | element | self shouldnt: [ self collectionWithCopyNonIdentical ]raise: Error. element := self collectionWithCopyNonIdentical anyOne. self deny: element == element copy. ! ! !ArrayTest methodsFor: 'tests - fixture'! test0FixtureIndexAccessFotMultipliness self shouldnt: [ self collectionWithSameAtEndAndBegining ] raise: Error. self assert: self collectionWithSameAtEndAndBegining first = self collectionWithSameAtEndAndBegining last. self assert: self collectionWithSameAtEndAndBegining size > 1. 1 to: self collectionWithSameAtEndAndBegining size do: [ :i | i > 1 & (i < self collectionWithSameAtEndAndBegining size) ifTrue: [ self deny: (self collectionWithSameAtEndAndBegining at: i) = self collectionWithSameAtEndAndBegining first ] ]! ! !ArrayTest methodsFor: 'tests - fixture'! test0FixtureIndexAccessTest | res collection element | self shouldnt: [ self collectionMoreThan1NoDuplicates ] raise: Error. self assert: self collectionMoreThan1NoDuplicates size >1. res := true. self collectionMoreThan1NoDuplicates detect: [ :each | (self collectionMoreThan1NoDuplicates occurrencesOf: each) > 1 ] ifNone: [ res := false ]. self assert: res = false. self shouldnt: [ self elementInForIndexAccessing ] raise: Error. self assert: ( (collection := self collectionMoreThan1NoDuplicates )includes: (element:= self elementInForIndexAccessing)). self shouldnt: [ self elementNotInForIndexAccessing ] raise: Error. self deny: (self collectionMoreThan1NoDuplicates includes: self elementNotInForIndexAccessing)! ! !ArrayTest methodsFor: 'tests - fixture'! test0FixtureIterateSequencedReadableTest | res | self shouldnt: self nonEmptyMoreThan1Element raise: Error. self assert: self nonEmptyMoreThan1Element size > 1. self shouldnt: self empty raise: Error. self assert: self empty isEmpty . res := true. self nonEmptyMoreThan1Element detect: [ :each | (self nonEmptyMoreThan1Element occurrencesOf: each) > 1 ] ifNone: [ res := false ]. self assert: res = false.! ! !ArrayTest methodsFor: 'tests - fixture'! test0FixtureOccurrencesForMultiplinessTest | cpt element collection | self shouldnt: [self collectionWithEqualElements ]raise: Error. self shouldnt: [self collectionWithEqualElements ]raise: Error. self shouldnt: [ self elementTwiceInForOccurrences ] raise: Error. element := self elementTwiceInForOccurrences . collection := self collectionWithEqualElements . cpt := 0 . " testing with identity check ( == ) so that identy collections can use this trait : " self collectionWithEqualElements do: [ :each | each == self elementTwiceInForOccurrences ifTrue: [ cpt := cpt + 1 ] ]. self assert: cpt = 2.! ! !ArrayTest methodsFor: 'tests - fixture' stamp: 'delaunay 4/2/2009 11:53'! test0FixtureOccurrencesTest self shouldnt: self empty raise: Error. self assert: self empty isEmpty. self shouldnt: self nonEmpty raise: Error. self deny: self nonEmpty isEmpty. self shouldnt: self elementInForOccurrences raise: Error. self assert: (self nonEmpty includes: self elementInForOccurrences). self shouldnt: self elementNotInForOccurrences raise: Error. self deny: (self nonEmpty includes: self elementNotInForOccurrences)! ! !ArrayTest methodsFor: 'tests - fixture'! test0FixturePrintTest self shouldnt: [self nonEmpty ] raise: Error.! ! !ArrayTest methodsFor: 'tests - fixture'! test0FixturePutOneOrMoreElementsTest self shouldnt: self aValue raise: Error. self shouldnt: self indexArray raise: Error. self indexArray do: [ :each| self assert: each class = SmallInteger. self assert: (each>=1 & each<= self nonEmpty size). ]. self assert: self indexArray size = self valueArray size. self shouldnt: self empty raise: Error. self assert: self empty isEmpty . self shouldnt: self nonEmpty raise: Error. self deny: self nonEmpty isEmpty.! ! !ArrayTest methodsFor: 'tests - fixture'! test0FixturePutTest self shouldnt: self aValue raise: Error. self shouldnt: self anotherValue raise: Error. self shouldnt: self anIndex raise: Error. self nonEmpty isDictionary ifFalse:[self assert: (self anIndex >=1 & self anIndex <= self nonEmpty size).]. self shouldnt: self empty raise: Error. self assert: self empty isEmpty . self shouldnt: self nonEmpty raise: Error. self deny: self nonEmpty isEmpty.! ! !ArrayTest methodsFor: 'tests - fixture' stamp: 'delaunay 4/14/2009 11:50'! test0FixtureSequencedConcatenationTest self shouldnt: self empty raise: Exception. self assert: self empty isEmpty. self shouldnt: self firstCollection raise: Exception. self shouldnt: self secondCollection raise: Exception! ! !ArrayTest methodsFor: 'tests - fixture'! test0FixtureSequencedElementAccessTest self shouldnt: [ self moreThan4Elements ] raise: Error. self assert: self moreThan4Elements size >= 4. self shouldnt: [ self subCollectionNotIn ] raise: Error. self subCollectionNotIn detect: [ :each | (self moreThan4Elements includes: each) not ] ifNone: [ self assert: false ]. self shouldnt: [ self elementNotInForElementAccessing ] raise: Error. self deny: (self moreThan4Elements includes: self elementNotInForElementAccessing). self shouldnt: [ self elementInForElementAccessing ] raise: Error. self assert: (self moreThan4Elements includes: self elementInForElementAccessing)! ! !ArrayTest methodsFor: 'tests - fixture'! test0FixtureSetAritmeticTest self shouldnt: [ self collection ] raise: Error. self deny: self collection isEmpty. self shouldnt: [ self nonEmpty ] raise: Error. self deny: self nonEmpty isEmpty. self shouldnt: [ self anotherElementOrAssociationNotIn ] raise: Error. self collection isDictionary ifTrue: [ self deny: (self collection associations includes: self anotherElementOrAssociationNotIn key) ] ifFalse: [ self deny: (self collection includes: self anotherElementOrAssociationNotIn) ]. self shouldnt: [ self collectionClass ] raise: Error! ! !ArrayTest methodsFor: 'tests - fixture'! test0FixtureSubcollectionAccessTest self shouldnt: [ self moreThan3Elements ] raise: Error. self assert: self moreThan3Elements size > 2! ! !ArrayTest methodsFor: 'tests - fixture' stamp: 'delaunay 4/28/2009 14:11'! test0FixtureTConvertAsSetForMultiplinessTest "a collection ofFloat with equal elements:" | res | self shouldnt: [ self withEqualElements ] raise: Error. self shouldnt: [ self withEqualElements do: [ :each | self assert: each class = Float ] ] raise: Error. res := true. self withEqualElements detect: [ :each | (self withEqualElements occurrencesOf: each) > 1 ] ifNone: [ res := false ]. self assert: res = true. "a collection of Float without equal elements:" self shouldnt: [ self elementsCopyNonIdenticalWithoutEqualElements ] raise: Error. self shouldnt: [ self elementsCopyNonIdenticalWithoutEqualElements do: [ :each | self assert: each class = Float ] ] raise: Error. res := true. self elementsCopyNonIdenticalWithoutEqualElements detect: [ :each | (self elementsCopyNonIdenticalWithoutEqualElements occurrencesOf: each) > 1 ] ifNone: [ res := false ]. self assert: res = false! ! !ArrayTest methodsFor: 'tests - fixture'! test0FixtureTConvertTest "a collection of number without equal elements:" | res | self shouldnt: [ self collectionWithoutEqualElements ]raise: Error. res := true. self collectionWithoutEqualElements detect: [ :each | (self collectionWithoutEqualElements occurrencesOf: each) > 1 ] ifNone: [ res := false ]. self assert: res = false. ! ! !ArrayTest methodsFor: 'tests - fixture'! test0SortingArrayedTest | tmp sorted | " an unsorted collection of number " self shouldnt: [ self unsortedCollection ]raise: Error. self unsortedCollection do:[:each | each isNumber]. sorted := true. self unsortedCollection pairsDo: [ :each1 :each2 | each2 < each1 ifTrue: [ sorted := false]. ]. self assert: sorted = false. " a collection of number sorted in an ascending order" self shouldnt: [ self sortedInAscendingOrderCollection ]raise: Error. self sortedInAscendingOrderCollection do:[:each | each isNumber]. tmp:= self sortedInAscendingOrderCollection at:1. self sortedInAscendingOrderCollection do: [: each | self assert: (each>= tmp). tmp:=each] ! ! !ArrayTest methodsFor: 'tests - fixture'! test0TSequencedStructuralEqualityTest self shouldnt: [self nonEmpty at: 1] raise: Error. "Ensures #nonEmpty is sequenceable"! ! !ArrayTest methodsFor: 'tests - fixture'! test0TStructuralEqualityTest self shouldnt: [self empty] raise: Error. self shouldnt: [self nonEmpty] raise: Error. self assert: self empty isEmpty. self deny: self nonEmpty isEmpty.! ! !ArrayTest methodsFor: 'tests - fixture'! testOFixtureReplacementSequencedTest self shouldnt: self nonEmpty raise: Error. self deny: self nonEmpty isEmpty. self shouldnt: self elementInForReplacement raise: Error. self assert: (self nonEmpty includes: self elementInForReplacement ) . self shouldnt: self newElement raise: Error. self shouldnt: self firstIndex raise: Error. self assert: (self firstIndex >= 1 & self firstIndex <= self nonEmpty size). self shouldnt: self secondIndex raise: Error. self assert: (self secondIndex >= 1 & self secondIndex <= self nonEmpty size). self assert: self firstIndex <=self secondIndex . self shouldnt: self replacementCollection raise: Error. self shouldnt: self replacementCollectionSameSize raise: Error. self assert: (self secondIndex - self firstIndex +1)= self replacementCollectionSameSize size ! ! !ArrayTest methodsFor: 'tests - includes' stamp: 'delaunay 4/28/2009 10:22'! testIdentityIncludes " test the comportement in presence of elements 'includes' but not 'identityIncludes' " " can not be used by collections that can't include elements for wich copy doesn't return another instance " | collection element | self shouldnt: [ self collectionWithCopyNonIdentical ] raise: Error. collection := self collectionWithCopyNonIdentical. element := collection anyOne copy. "self assert: (collection includes: element)." self deny: (collection identityIncludes: element)! ! !ArrayTest methodsFor: 'tests - includes'! testIdentityIncludesNonSpecificComportement " test the same comportement than 'includes: ' " | collection | collection := self nonEmpty . self deny: (collection identityIncludes: self elementNotIn ). self assert:(collection identityIncludes: collection anyOne) ! ! !ArrayTest methodsFor: 'tests - includes'! testIncludesAllOfAllThere "self debug: #testIncludesAllOfAllThere'" self assert: (self empty includesAllOf: self empty). self assert: (self nonEmpty includesAllOf: { self nonEmpty anyOne }). self assert: (self nonEmpty includesAllOf: self nonEmpty).! ! !ArrayTest methodsFor: 'tests - includes'! testIncludesAllOfNoneThere "self debug: #testIncludesAllOfNoneThere'" self deny: (self empty includesAllOf: self nonEmpty ). self deny: (self nonEmpty includesAllOf: { self elementNotIn. self anotherElementNotIn })! ! !ArrayTest methodsFor: 'tests - includes'! testIncludesAnyOfAllThere "self debug: #testIncludesAnyOfAllThere'" self deny: (self nonEmpty includesAnyOf: self empty). self assert: (self nonEmpty includesAnyOf: { self nonEmpty anyOne }). self assert: (self nonEmpty includesAnyOf: self nonEmpty).! ! !ArrayTest methodsFor: 'tests - includes'! testIncludesAnyOfNoneThere "self debug: #testIncludesAnyOfNoneThere'" self deny: (self nonEmpty includesAnyOf: self empty). self deny: (self nonEmpty includesAnyOf: { self elementNotIn. self anotherElementNotIn })! ! !ArrayTest methodsFor: 'tests - includes'! testIncludesElementIsNotThere "self debug: #testIncludesElementIsNotThere" self deny: (self nonEmpty includes: self elementNotIn). self assert: (self nonEmpty includes: self nonEmpty anyOne). self deny: (self empty includes: self elementNotIn)! ! !ArrayTest methodsFor: 'tests - includes'! testIncludesElementIsThere "self debug: #testIncludesElementIsThere" self assert: (self nonEmpty includes: self nonEmpty anyOne).! ! !ArrayTest methodsFor: 'tests - index access' stamp: 'delaunay 4/15/2009 14:22'! testIdentityIndexOf "self debug: #testIdentityIndexOf" | collection element | element := self elementInCollectionOfFloat copy. self deny: self elementInCollectionOfFloat == element. collection := self collectionOfFloat copyWith: element. self assert: (collection identityIndexOf: element) = collection size! ! !ArrayTest methodsFor: 'tests - index access' stamp: 'delaunay 4/15/2009 14:22'! testIdentityIndexOfIAbsent "self debug: #testIdentityIndexOfIfAbsent" | collection element | element := self elementInCollectionOfFloat copy. self deny: self elementInCollectionOfFloat == element. collection := self collectionOfFloat copyWith: element. self assert: (collection identityIndexOf: element ifAbsent: [ 0 ]) = collection size. self assert: (self collectionOfFloat identityIndexOf: element ifAbsent: [ 55 ]) = 55! ! !ArrayTest methodsFor: 'tests - index access' stamp: 'delaunay 4/23/2009 15:14'! testIndexOf "self debug: #testIndexOf" | tmp index collection | collection := self collectionMoreThan1NoDuplicates. tmp := collection size. collection reverseDo: [ :each | each = self elementInForIndexAccessing ifTrue: [ index := tmp ]. tmp := tmp - 1 ]. self assert: (collection indexOf: self elementInForIndexAccessing) = index! ! !ArrayTest methodsFor: 'tests - index access' stamp: 'delaunay 4/23/2009 15:14'! testIndexOfIfAbsent "self debug: #testIndexOfIfAbsent" | collection | collection := self collectionMoreThan1NoDuplicates. self assert: (collection indexOf: collection first ifAbsent: [ 33 ]) = 1. self assert: (collection indexOf: self elementNotInForIndexAccessing ifAbsent: [ 33 ]) = 33! ! !ArrayTest methodsFor: 'tests - index access' stamp: 'delaunay 4/23/2009 15:14'! testIndexOfStartingAt "self debug: #testLastIndexOf" | element collection | collection := self collectionMoreThan1NoDuplicates. element := collection first. self assert: (collection indexOf: element startingAt: 2 ifAbsent: [ 99 ]) = 99. self assert: (collection indexOf: element startingAt: 1 ifAbsent: [ 99 ]) = 1. self assert: (collection indexOf: self elementNotInForIndexAccessing startingAt: 1 ifAbsent: [ 99 ]) = 99! ! !ArrayTest methodsFor: 'tests - index access'! testIndexOfStartingAtIfAbsent "self debug: #testLastIndexOf" | element collection | collection := self collectionMoreThan1NoDuplicates. element := collection first. self assert: (collection indexOf: element startingAt: 2 ifAbsent: [ 99 ]) = 99. self assert: (collection indexOf: element startingAt: 1 ifAbsent: [ 99 ]) = 1. self assert: (collection indexOf: self elementNotInForIndexAccessing startingAt: 1 ifAbsent: [ 99 ]) = 99! ! !ArrayTest methodsFor: 'tests - index access' stamp: 'delaunay 4/23/2009 15:14'! testIndexOfSubCollectionStartingAt "self debug: #testIndexOfIfAbsent" | subcollection index collection | collection := self collectionMoreThan1NoDuplicates. subcollection := self collectionMoreThan1NoDuplicates. index := collection indexOfSubCollection: subcollection startingAt: 1. self assert: index = 1. index := collection indexOfSubCollection: subcollection startingAt: 2. self assert: index = 0! ! !ArrayTest methodsFor: 'tests - index access' stamp: 'delaunay 4/23/2009 15:14'! testIndexOfSubCollectionStartingAtIfAbsent "self debug: #testIndexOfIfAbsent" | index absent subcollection collection | collection := self collectionMoreThan1NoDuplicates. subcollection := self collectionMoreThan1NoDuplicates. absent := false. index := collection indexOfSubCollection: subcollection startingAt: 1 ifAbsent: [ absent := true ]. self assert: absent = false. absent := false. index := collection indexOfSubCollection: subcollection startingAt: 2 ifAbsent: [ absent := true ]. self assert: absent = true! ! !ArrayTest methodsFor: 'tests - index access' stamp: 'delaunay 4/23/2009 15:14'! testLastIndexOf "self debug: #testLastIndexOf" | element collection | collection := self collectionMoreThan1NoDuplicates. element := collection first. self assert: (collection lastIndexOf: element) = 1. self assert: (collection lastIndexOf: self elementNotInForIndexAccessing) = 0! ! !ArrayTest methodsFor: 'tests - index access' stamp: 'delaunay 4/23/2009 15:14'! testLastIndexOfIfAbsent "self debug: #testIndexOfIfAbsent" | element collection | collection := self collectionMoreThan1NoDuplicates. element := collection first. self assert: (collection lastIndexOf: element ifAbsent: [ 99 ]) = 1. self assert: (collection lastIndexOf: self elementNotInForIndexAccessing ifAbsent: [ 99 ]) = 99! ! !ArrayTest methodsFor: 'tests - index access' stamp: 'delaunay 4/23/2009 15:14'! testLastIndexOfStartingAt "self debug: #testLastIndexOf" | element collection | collection := self collectionMoreThan1NoDuplicates. element := collection last. self assert: (collection lastIndexOf: element startingAt: collection size ifAbsent: [ 99 ]) = collection size. self assert: (collection lastIndexOf: element startingAt: collection size - 1 ifAbsent: [ 99 ]) = 99. self assert: (collection lastIndexOf: self elementNotInForIndexAccessing startingAt: collection size ifAbsent: [ 99 ]) = 99! ! !ArrayTest methodsFor: 'tests - index accessing for multipliness'! testIdentityIndexOfDuplicate "self debug: #testIdentityIndexOf" | collection element | "testing fixture here as this method may not be used by some collections testClass" self shouldnt: [self collectionWithNonIdentitySameAtEndAndBegining ] raise: Error. collection := self collectionWithNonIdentitySameAtEndAndBegining . self assert: collection first = collection last. self deny: collection first == collection last. 1 to: collection size do: [ :i | i > 1 & (i < collection size) ifTrue: [ self deny: (collection at: i) = collection first ] ]. element := collection last. " floatCollectionWithSameAtEndAndBegining first and last elements are equals but are not the same object" self assert: (collection identityIndexOf: element) = collection size! ! !ArrayTest methodsFor: 'tests - index accessing for multipliness'! testIdentityIndexOfIAbsentDuplicate "self debug: #testIdentityIndexOfIfAbsent" | collection element elementCopy | collection := self collectionWithNonIdentitySameAtEndAndBegining . element := collection last. elementCopy := element copy. self deny: element == elementCopy . self assert: (collection identityIndexOf: element ifAbsent: [ 0 ]) = collection size. self assert: (collection identityIndexOf: elementCopy ifAbsent: [ 55 ]) = 55! ! !ArrayTest methodsFor: 'tests - index accessing for multipliness'! testIndexOfDuplicate "self debug: #testIndexOf" | collection element | collection := self collectionWithSameAtEndAndBegining. element := collection last. " floatCollectionWithSameAtEndAndBegining first and last elements are equals 'indexOf: should return the position of the first occurrence :'" self assert: (collection indexOf: element) = 1! ! !ArrayTest methodsFor: 'tests - index accessing for multipliness'! testIndexOfIfAbsentDuplicate "self debug: #testIndexOfIfAbsent" | collection element | collection := self collectionWithSameAtEndAndBegining. element := collection last. " floatCollectionWithSameAtEndAndBegining first and last elements are equals 'indexOf:ifAbsent: should return the position of the first occurrence :'" self assert: (collection indexOf: element ifAbsent: [ 55 ]) = 1! ! !ArrayTest methodsFor: 'tests - index accessing for multipliness'! testIndexOfStartingAtDuplicate "self debug: #testLastIndexOf" | collection element | collection := self collectionWithSameAtEndAndBegining. element := collection last. " floatCollectionWithSameAtEndAndBegining first and last elements are equals 'indexOf:ifAbsent:startingAt: should return the position of the first occurrence :'" self assert: (collection indexOf: element startingAt: 1 ifAbsent: [ 55 ]) = 1. self assert: (collection indexOf: element startingAt: 2 ifAbsent: [ 55 ]) = collection size! ! !ArrayTest methodsFor: 'tests - index accessing for multipliness'! testLastIndexOfDuplicate "self debug: #testLastIndexOf" | collection element | collection := self collectionWithSameAtEndAndBegining. element := collection first. " floatCollectionWithSameAtEndAndBegining first and last elements are equals 'lastIndexOf: should return the position of the last occurrence :'" self assert: (collection lastIndexOf: element) = collection size! ! !ArrayTest methodsFor: 'tests - index accessing for multipliness'! testLastIndexOfIfAbsentDuplicate "self debug: #testIndexOfIfAbsent" "self debug: #testLastIndexOf" | collection element | collection := self collectionWithSameAtEndAndBegining. element := collection first. " floatCollectionWithSameAtEndAndBegining first and last elements are equals 'lastIndexOf: should return the position of the last occurrence :'" self assert: (collection lastIndexOf: element ifAbsent: [ 55 ]) = collection size! ! !ArrayTest methodsFor: 'tests - index accessing for multipliness'! testLastIndexOfStartingAtDuplicate "self debug: #testLastIndexOf" | collection element | collection := self collectionWithSameAtEndAndBegining. element := collection last. " floatCollectionWithSameAtEndAndBegining first and last elements are equals 'lastIndexOf:ifAbsent:startingAt: should return the position of the last occurrence :'" self assert: (collection lastIndexOf: element startingAt: collection size ifAbsent: [ 55 ]) = collection size. self assert: (collection lastIndexOf: element startingAt: collection size - 1 ifAbsent: [ 55 ]) = 1! ! !ArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! testAllButFirstDo | result | result:= OrderedCollection new. self nonEmptyMoreThan1Element allButFirstDo: [:each | result add: each]. 1 to: (result size) do: [:i| self assert: (self nonEmptyMoreThan1Element at:(i +1))=(result at:i)]. self assert: result size=(self nonEmptyMoreThan1Element size-1).! ! !ArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! testAllButLastDo | result | result:= OrderedCollection new. self nonEmptyMoreThan1Element allButLastDo: [:each | result add: each]. 1 to: (result size) do: [:i| self assert: (self nonEmptyMoreThan1Element at:(i ))=(result at:i)]. self assert: result size=(self nonEmptyMoreThan1Element size-1).! ! !ArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! testCollectFromTo | result | result:=self nonEmptyMoreThan1Element collect: [ :each | each ] from: 1 to: (self nonEmptyMoreThan1Element size - 1). 1 to: result size do: [ :i | self assert: (self nonEmptyMoreThan1Element at: i) = (result at: i) ]. self assert: result size = (self nonEmptyMoreThan1Element size - 1)! ! !ArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! testDetectSequenced " testing that detect keep the first element returning true for sequenceable collections " | element result | element := self nonEmptyMoreThan1Element at:1. result:=self nonEmptyMoreThan1Element detect: [:each | each notNil ]. self assert: result = element. ! ! !ArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! testFindFirst | element result | element := self nonEmptyMoreThan1Element at:1. result:=self nonEmptyMoreThan1Element findFirst: [:each | each =element]. self assert: result=1. ! ! !ArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! testFindFirstNotIn | result | result:=self empty findFirst: [:each | true]. self assert: result=0. ! ! !ArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! testFindLast | element result | element := self nonEmptyMoreThan1Element at:self nonEmptyMoreThan1Element size. result:=self nonEmptyMoreThan1Element findLast: [:each | each =element]. self assert: result=self nonEmptyMoreThan1Element size. ! ! !ArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! testFindLastNotIn | result | result:=self empty findFirst: [:each | true]. self assert: result=0. ! ! !ArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! testFromToDo | result | result:= OrderedCollection new. self nonEmptyMoreThan1Element from: 1 to: (self nonEmptyMoreThan1Element size -1) do: [:each | result add: each]. 1 to: (self nonEmptyMoreThan1Element size -1) do: [:i| self assert: (self nonEmptyMoreThan1Element at:i )=(result at:i)]. self assert: result size=(self nonEmptyMoreThan1Element size-1).! ! !ArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! testKeysAndValuesDo "| result | result:= OrderedCollection new. self nonEmptyMoreThan1Element keysAndValuesDo: [:i :value| result add: (value+i)]. 1 to: result size do: [:i| self assert: (result at:i)=((self nonEmptyMoreThan1Element at:i)+i)]" | indexes elements | indexes:= OrderedCollection new. elements := OrderedCollection new. self nonEmptyMoreThan1Element keysAndValuesDo: [:i :value| indexes add: (i). elements add: value]. (1 to: self nonEmptyMoreThan1Element size )do: [ :i | self assert: (indexes at: i) = i. self assert: (elements at: i) = (self nonEmptyMoreThan1Element at: i). ]. self assert: indexes size = elements size. self assert: indexes size = self nonEmptyMoreThan1Element size . ! ! !ArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! testKeysAndValuesDoEmpty | result | result:= OrderedCollection new. self empty keysAndValuesDo: [:i :value| result add: (value+i)]. self assert: result isEmpty .! ! !ArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! testPairsCollect | index result | index:=0. result:=self nonEmptyMoreThan1Element pairsCollect: [:each1 :each2 | self assert: ( self nonEmptyMoreThan1Element indexOf: each2 ) = (index := index + 2). (self nonEmptyMoreThan1Element indexOf: each2) = ((self nonEmptyMoreThan1Element indexOf: each1) + 1). ]. result do: [:each | self assert: each = true]. ! ! !ArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! testPairsDo | index | index:=1. self nonEmptyMoreThan1Element pairsDo: [:each1 :each2 | self assert:(self nonEmptyMoreThan1Element at:index)=each1. self assert:(self nonEmptyMoreThan1Element at:(index+1))=each2. index:=index+2]. self nonEmptyMoreThan1Element size odd ifTrue:[self assert: index=self nonEmptyMoreThan1Element size] ifFalse:[self assert: index=(self nonEmptyMoreThan1Element size+1)].! ! !ArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! testReverseDo | result | result:= OrderedCollection new. self nonEmpty reverseDo: [: each | result add: each]. 1 to: result size do: [:i| self assert: (result at: i)=(self nonEmpty at:(self nonEmpty size-i+1))].! ! !ArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! testReverseDoEmpty | result | result:= OrderedCollection new. self empty reverseDo: [: each | result add: each]. self assert: result isEmpty .! ! !ArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! testReverseWithDo | secondCollection result index | result:= OrderedCollection new. index := self nonEmptyMoreThan1Element size + 1. secondCollection:= self nonEmptyMoreThan1Element copy. self nonEmptyMoreThan1Element reverseWith: secondCollection do: [:a :b | self assert: (self nonEmptyMoreThan1Element indexOf: a ) = (index := index - 1 ). result add: (a = b)]. 1 to: result size do: [:i| self assert: (result at:i)=(true)]. self assert: result size = self nonEmptyMoreThan1Element size.! ! !ArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! testWithCollect | result newCollection index collection | index := 0. collection := self nonEmptyMoreThan1Element . newCollection := collection copy. result:=collection with: newCollection collect: [:a :b | self assert: (collection indexOf: a ) = ( index := index + 1). self assert: (a = b). b]. 1 to: result size do:[: i | self assert: (result at:i)= (collection at: i)]. self assert: result size = collection size.! ! !ArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! testWithCollectError self should: [self nonEmptyMoreThan1Element with: self empty collect:[:a :b | ]] raise: Error.! ! !ArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! testWithDo | secondCollection result index | result:= OrderedCollection new. secondCollection:= self nonEmptyMoreThan1Element copy. index := 0. self nonEmptyMoreThan1Element with: secondCollection do: [:a :b | self assert: (self nonEmptyMoreThan1Element indexOf: a) = ( index := index + 1). result add: (a =b)]. 1 to: result size do: [:i| self assert: (result at:i)=(true)]. self assert: result size = self nonEmptyMoreThan1Element size.! ! !ArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! testWithDoError self should: [self nonEmptyMoreThan1Element with: self empty do:[:a :b | ]] raise: Error.! ! !ArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! testWithIndexCollect | result index collection | index := 0. collection := self nonEmptyMoreThan1Element . result := collection withIndexCollect: [:each :i | self assert: i = (index := index + 1). self assert: i = (collection indexOf: each) . each] . 1 to: result size do:[: i | self assert: (result at:i)= (collection at: i)]. self assert: result size = collection size.! ! !ArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! testWithIndexDo "| result | result:=Array new: self nonEmptyMoreThan1Element size. self nonEmptyMoreThan1Element withIndexDo: [:each :i | result at:i put:(each+i)]. 1 to: result size do:[: i | self assert: (result at:i)= ((self nonEmptyMoreThan1Element at: i) + i)]" | indexes elements | indexes:= OrderedCollection new. elements := OrderedCollection new. self nonEmptyMoreThan1Element withIndexDo: [:value :i | indexes add: (i). elements add: value]. (1 to: self nonEmptyMoreThan1Element size )do: [ :i | self assert: (indexes at: i) = i. self assert: (elements at: i) = (self nonEmptyMoreThan1Element at: i). ]. self assert: indexes size = elements size. self assert: indexes size = self nonEmptyMoreThan1Element size . ! ! !ArrayTest methodsFor: 'tests - occurrencesOf' stamp: 'delaunay 4/2/2009 11:52'! testOccurrencesOf | result expected | result := self nonEmpty occurrencesOf: self elementInForOccurrences. expected := 0. self nonEmpty do: [ :each | self elementInForOccurrences = each ifTrue: [ expected := expected + 1 ] ]. self assert: result = expected! ! !ArrayTest methodsFor: 'tests - occurrencesOf' stamp: 'delaunay 4/2/2009 11:52'! testOccurrencesOfEmpty | result | result := self empty occurrencesOf: self elementInForOccurrences. self assert: result = 0! ! !ArrayTest methodsFor: 'tests - occurrencesOf' stamp: 'delaunay 4/2/2009 11:53'! testOccurrencesOfNotIn | result | result := self empty occurrencesOf: self elementNotInForOccurrences. self assert: result = 0! ! !ArrayTest methodsFor: 'tests - occurrencesOf for multipliness'! testOccurrencesOfForMultipliness | collection element | collection := self collectionWithEqualElements . element := self elementTwiceInForOccurrences . self assert: (collection occurrencesOf: element ) = 2. ! ! !ArrayTest methodsFor: 'tests - printing'! testPrintElementsOn | aStream result allElementsAsString | result:=''. aStream:= ReadWriteStream on: result. self nonEmpty printElementsOn: aStream . allElementsAsString:=(result findBetweenSubStrs: ' ' ). 1 to: allElementsAsString size do: [:i | self assert: (allElementsAsString at:i)=((self nonEmpty at:i)asString). ].! ! !ArrayTest methodsFor: 'tests - printing'! testPrintNameOn | aStream result | result:=''. aStream:= ReadWriteStream on: result. self nonEmpty printNameOn: aStream . Transcript show: result asString. self nonEmpty class name first isVowel ifTrue:[ self assert: aStream contents =('an ',self nonEmpty class name ) ] ifFalse:[self assert: aStream contents =('a ',self nonEmpty class name)].! ! !ArrayTest methodsFor: 'tests - printing'! testPrintOn | aStream result allElementsAsString | result:=''. aStream:= ReadWriteStream on: result. self nonEmpty printOn: aStream . allElementsAsString:=(result findBetweenSubStrs: ' ' ). 1 to: allElementsAsString size do: [:i | i=1 ifTrue:[ self accessCollection class name first isVowel ifTrue:[self assert: (allElementsAsString at:i)='an' ] ifFalse:[self assert: (allElementsAsString at:i)='a'].]. i=2 ifTrue:[self assert: (allElementsAsString at:i)=self accessCollection class name]. i>2 ifTrue:[self assert: (allElementsAsString at:i)=((self nonEmpty at:i)asString).]. ].! ! !ArrayTest methodsFor: 'tests - printing'! testPrintOnDelimiter | aStream result allElementsAsString | result:=''. aStream:= ReadWriteStream on: result. self nonEmpty printOn: aStream delimiter: ', ' . allElementsAsString:=(result findBetweenSubStrs: ', ' ). 1 to: allElementsAsString size do: [:i | self assert: (allElementsAsString at:i)=((self nonEmpty at:i)asString). ].! ! !ArrayTest methodsFor: 'tests - printing'! testPrintOnDelimiterLast | aStream result allElementsAsString | result:=''. aStream:= ReadWriteStream on: result. self nonEmpty printOn: aStream delimiter: ', ' last: 'and'. allElementsAsString:=(result findBetweenSubStrs: ', ' ). 1 to: allElementsAsString size do: [:i | i<(allElementsAsString size-1 ) ifTrue: [self assert: (allElementsAsString at:i)=((self nonEmpty at:i)asString)]. i=(allElementsAsString size-1) ifTrue:[ self deny: (allElementsAsString at:i)=('and')asString]. i=(allElementsAsString size) ifTrue: [self assert: (allElementsAsString at:i)=((self nonEmpty at:(i-1))asString)]. ].! ! !ArrayTest methodsFor: 'tests - printing'! testStoreOn " for the moment work only for collection that include simple elements such that Integer" "| string str result cuttedResult index elementsAsStringExpected elementsAsStringObtained tmp | string := ''. str := ReadWriteStream on: string. elementsAsStringExpected := OrderedCollection new. elementsAsStringObtained := OrderedCollection new. self nonEmpty do: [ :each | elementsAsStringExpected add: each asString]. self nonEmpty storeOn: str. result := str contents . cuttedResult := ( result findBetweenSubStrs: ';' ). index := 1. cuttedResult do: [ :each | index = 1 ifTrue: [ self assert: (each beginsWith: ( tmp := '((' , self nonEmpty class asString , ' new) add: ' )). tmp := each copyFrom: ( tmp size + 1) to: ( each size ). elementsAsStringObtained add: tmp. index := index + 1. ] ifFalse: [ index < cuttedResult size ifTrue:[self assert: (each beginsWith: ( tmp:= ' add: ' )). tmp := each copyFrom: ( tmp size + 1) to: ( each size ). elementsAsStringObtained add: tmp. index := index + 1.] ifFalse: [self assert: ( each = ' yourself)' ) ]. ] ]. elementsAsStringExpected do: [ :each | self assert: (elementsAsStringExpected occurrencesOf: each ) = ( elementsAsStringObtained occurrencesOf: each) ]" ! ! !ArrayTest methodsFor: 'tests - puting with indexes'! testAtAllIndexesPut self nonEmpty atAllPut: self aValue. self nonEmpty do:[ :each| self assert: each = self aValue]. ! ! !ArrayTest methodsFor: 'tests - puting with indexes'! testAtAllPut | | self nonEmpty atAll: self indexArray put: self aValue.. self indexArray do: [:i | self assert: (self nonEmpty at: i)=self aValue ]. ! ! !ArrayTest methodsFor: 'tests - puting with indexes'! testAtAllPutAll | valueArray | valueArray := self valueArray . self nonEmpty atAll: self indexArray putAll: valueArray . 1 to: self indexArray size do: [:i | self assert: (self nonEmpty at:(self indexArray at: i))= (valueArray at:i) ]! ! !ArrayTest methodsFor: 'tests - puting with indexes'! testAtLastPut | result index | index := self indexArray anyOne. result := self nonEmpty atLast: index put: self aValue. self assert: (self nonEmpty at: (self nonEmpty size +1 - index)) = self aValue .! ! !ArrayTest methodsFor: 'tests - puting with indexes'! testAtWrapPut "self debug: #testAtWrapPut" | index | index := self indexArray anyOne. self nonEmpty atWrap: 0 put: self aValue. self assert: (self nonEmpty at:(self nonEmpty size))=self aValue. self nonEmpty atWrap: (self nonEmpty size+1) put: self aValue. self assert: (self nonEmpty at:(1))=self aValue. self nonEmpty atWrap: (index ) put: self aValue. self assert: (self nonEmpty at: index ) = self aValue. self nonEmpty atWrap: (self nonEmpty size+index ) put: self aValue . self assert: (self nonEmpty at:(index ))=self aValue .! ! !ArrayTest methodsFor: 'tests - puting with indexes'! testFromToPut | collection index | index := self indexArray anyOne. collection := self nonEmpty copy. collection from: 1 to: index put: self aValue.. 1 to: index do: [:i | self assert: (collection at: i)= self aValue]. (index +1) to: collection size do: [:i | self assert: (collection at:i)= (self nonEmpty at:i)].! ! !ArrayTest methodsFor: 'tests - puting with indexes'! testSwapWith "self debug: #testSwapWith" | result index | index := self indexArray anyOne. result:= self nonEmpty copy . result swap: index with: 1. self assert: (result at: index) = (self nonEmpty at:1). self assert: (result at: 1) = (self nonEmpty at: index). ! ! !ArrayTest methodsFor: 'tests - replacing'! testReplaceAllWith | result collection oldElement newElement | collection := self nonEmpty . result := collection copy. oldElement := self elementInForReplacement . newElement := self newElement . result replaceAll: oldElement with: newElement . 1 to: collection size do: [: each | ( collection at: each ) = oldElement ifTrue: [ self assert: ( result at: each ) = newElement ]. ].! ! !ArrayTest methodsFor: 'tests - replacing'! testReplaceFromToWith | result collection replacementCollection firstIndex secondIndex | collection := self nonEmpty . replacementCollection := self replacementCollectionSameSize . firstIndex := self firstIndex . secondIndex := self secondIndex . result := collection copy. result replaceFrom: firstIndex to: secondIndex with: replacementCollection . "verify content of 'result' : " "first part of 'result'' : '" 1 to: ( firstIndex - 1 ) do: [ :i | self assert: (collection at:i ) = ( result at: i ) ]. " middle part containing replacementCollection : " ( firstIndex ) to: ( firstIndex + replacementCollection size - 1 ) do: [ :i | self assert: ( result at: i ) = ( replacementCollection at: ( i - firstIndex +1 ) ) ]. " end part :" ( firstIndex + replacementCollection size) to: (result size) do: [:i| self assert: ( result at: i ) = ( collection at: ( secondIndex + 1 - ( firstIndex + replacementCollection size ) + i ) ) ]. ! ! !ArrayTest methodsFor: 'tests - replacing'! testReplaceFromToWithStartingAt | result repStart collection replacementCollection firstIndex secondIndex | collection := self nonEmpty . result := collection copy. replacementCollection := self replacementCollectionSameSize . firstIndex := self firstIndex . secondIndex := self secondIndex . repStart := replacementCollection size - ( secondIndex - firstIndex + 1 ) + 1. result replaceFrom: firstIndex to: secondIndex with: replacementCollection startingAt: repStart . "verify content of 'result' : " "first part of 'result'' : '" 1 to: ( firstIndex - 1 ) do: [ :i | self assert: ( collection at:i ) = ( result at: i ) ]. " middle part containing replacementCollection : " ( firstIndex ) to: ( replacementCollection size - repStart +1 ) do: [:i| self assert: (result at: i)=( replacementCollection at: ( repStart + ( i -firstIndex ) ) ) ]. " end part :" ( firstIndex + replacementCollection size ) to: ( result size ) do: [ :i | self assert: ( result at: i ) = ( collection at: ( secondIndex + 1 - ( firstIndex + replacementCollection size ) + i ) ) ].! ! !ArrayTest methodsFor: 'tests - sequence isempty'! testSequenceAbleIfEmptyifNotEmptyDo "self debug: #testSequenceAbleIfEmptyifNotEmptyDo" self assert: (self nonEmpty ifEmpty: [false] ifNotEmptyDo: [:s | (self accessValuePutInOn: s) = self valuePutIn]).! ! !ArrayTest methodsFor: 'tests - sequence isempty'! testSequenceIfEmptyifNotEmptyDo "self debug #testSequenceIfEmptyifNotEmptyDo" self assert: (self nonEmpty ifEmpty: [false] ifNotEmptyDo: [:s | (self accessValuePutInOn: s) = self valuePutIn]).! ! !ArrayTest methodsFor: 'tests - sequence isempty'! testSequenceIfNotEmpty self assert: (self nonEmpty ifNotEmpty: [:s | self accessValuePutInOn: s]) = self valuePutIn! ! !ArrayTest methodsFor: 'tests - sequence isempty'! testSequenceIfNotEmptyDo self empty ifNotEmptyDo: [:s | self assert: false]. self assert: (self nonEmpty ifNotEmptyDo: [:s | self accessValuePutInOn: s]) = self valuePutIn ! ! !ArrayTest methodsFor: 'tests - sequence isempty'! testSequenceIfNotEmptyDoifNotEmpty self assert: (self nonEmpty ifNotEmptyDo: [:s | (self accessValuePutInOn: s) = self valuePutIn] ifEmpty: [false])! ! !ArrayTest methodsFor: 'tests - sequence isempty'! testSequenceIfNotEmptyifEmpty self assert: (self nonEmpty ifEmpty: [false] ifNotEmpty: [:s | (self accessValuePutInOn: s) = self valuePutIn])! ! !ArrayTest methodsFor: 'tests - set arithmetic'! containsAll: union of: one andOf: another self assert: (one allSatisfy: [:each | union includes: each]). self assert: (another allSatisfy: [:each | union includes: each])! ! !ArrayTest methodsFor: 'tests - set arithmetic'! numberOfSimilarElementsInIntersection ^ self collection occurrencesOf: self anotherElementOrAssociationIn! ! !ArrayTest methodsFor: 'tests - set arithmetic'! testDifference "Answer the set theoretic difference of two collections." "self debug: #testDifference" self assert: (self collection difference: self collection) isEmpty. self assert: (self empty difference: self collection) isEmpty. self assert: (self collection difference: self empty) = self collection ! ! !ArrayTest methodsFor: 'tests - set arithmetic'! testDifferenceWithNonNullIntersection "Answer the set theoretic difference of two collections." "self debug: #testDifferenceWithNonNullIntersection" " #(1 2 3) difference: #(2 4) -> #(1 3)" | res overlapping | overlapping := self collectionClass with: self anotherElementOrAssociationNotIn with: self anotherElementOrAssociationIn. res := self collection difference: overlapping. self deny: (res includes: self anotherElementOrAssociationIn). overlapping do: [ :each | self deny: (res includes: each) ]! ! !ArrayTest methodsFor: 'tests - set arithmetic'! testDifferenceWithSeparateCollection "Answer the set theoretic difference of two collections." "self debug: #testDifferenceWithSeparateCollection" | res separateCol | separateCol := self collectionClass with: self anotherElementOrAssociationNotIn. res := self collection difference: separateCol. self deny: (res includes: self anotherElementOrAssociationNotIn). self assert: res = self collection. res := separateCol difference: self collection. self deny: (res includes: self collection anyOne). self assert: res = separateCol! ! !ArrayTest methodsFor: 'tests - set arithmetic'! testIntersectionBasic "self debug: #testIntersectionBasic" | inter | inter := self collection intersection: (self collectionClass with: self anotherElementOrAssociationIn). self deny: inter isEmpty. self assert: (inter includes: self anotherElementOrAssociationIn value)! ! !ArrayTest methodsFor: 'tests - set arithmetic'! testIntersectionEmpty "self debug: #testIntersectionEmpty" | inter | inter := self empty intersection: self empty. self assert: inter isEmpty. inter := self empty intersection: self collection . self assert: inter = self empty. ! ! !ArrayTest methodsFor: 'tests - set arithmetic'! testIntersectionItself "self debug: #testIntersectionItself" self assert: (self collection intersection: self collection) = self collection. ! ! !ArrayTest methodsFor: 'tests - set arithmetic'! testIntersectionTwoSimilarElementsInIntersection "self debug: #testIntersectionBasic" | inter | inter := self collection intersection: (self collectionClass with: self anotherElementOrAssociationIn). self assert: (self collection occurrencesOf: self anotherElementOrAssociationIn) = self numberOfSimilarElementsInIntersection. self assert: (inter includes: self anotherElementOrAssociationIn value)! ! !ArrayTest methodsFor: 'tests - set arithmetic'! testUnion "self debug: #testUnionOfEmpties" | union | union := self empty union: self nonEmpty. self containsAll: union of: self empty andOf: self nonEmpty. union := self nonEmpty union: self empty. self containsAll: union of: self empty andOf: self nonEmpty. union := self collection union: self nonEmpty. self containsAll: union of: self collection andOf: self nonEmpty.! ! !ArrayTest methodsFor: 'tests - set arithmetic'! testUnionOfEmpties "self debug: #testUnionOfEmpties" self assert: (self empty union: self empty) isEmpty. ! ! !ArrayTest methodsFor: 'tests - sorting'! testIsSorted self assert: [ self sortedInAscendingOrderCollection isSorted ]. self deny: [ self unsortedCollection isSorted ]! ! !ArrayTest methodsFor: 'tests - sorting'! testIsSortedBy self assert: (self sortedInAscendingOrderCollection isSortedBy: [:a :b | ab]). ! ! !ArrayTest methodsFor: 'tests - sorting'! testSort | result tmp | result := self unsortedCollection sort. tmp := result at: 1. result do: [:each | self assert: each>=tmp. tmp:= each. ].! ! !ArrayTest methodsFor: 'tests - sorting'! testSortUsingSortBlock | result tmp | result := self unsortedCollection sort: [:a :b | a>b]. tmp := result at: 1. result do: [:each | self assert: each<=tmp. tmp:= each. ].! ! !ArrayTest methodsFor: 'tests - subcollections access'! testAllButFirst "self debug: #testAllButFirst" | abf col | col := self moreThan3Elements. abf := col allButFirst. self deny: abf first = col first. self assert: abf size + 1 = col size! ! !ArrayTest methodsFor: 'tests - subcollections access'! testAllButFirstNElements "self debug: #testAllButFirst" | abf col | col := self moreThan3Elements. abf := col allButFirst: 2. 1 to: abf size do: [ :i | self assert: (abf at: i) = (col at: i + 2) ]. self assert: abf size + 2 = col size! ! !ArrayTest methodsFor: 'tests - subcollections access'! testAllButLast "self debug: #testAllButLast" | abf col | col := self moreThan3Elements. abf := col allButLast. self deny: abf last = col last. self assert: abf size + 1 = col size! ! !ArrayTest methodsFor: 'tests - subcollections access'! testAllButLastNElements "self debug: #testAllButFirst" | abf col | col := self moreThan3Elements. abf := col allButLast: 2. 1 to: abf size do: [ :i | self assert: (abf at: i) = (col at: i) ]. self assert: abf size + 2 = col size! ! !ArrayTest methodsFor: 'tests - subcollections access'! testFirstNElements "self debug: #testFirstNElements" | result | result := self moreThan3Elements first: self moreThan3Elements size - 1. 1 to: result size do: [ :i | self assert: (result at: i) = (self moreThan3Elements at: i) ]. self assert: result size = (self moreThan3Elements size - 1). self should: [ self moreThan3Elements first: self moreThan3Elements size + 1 ] raise: Error! ! !ArrayTest methodsFor: 'tests - subcollections access'! testLastNElements "self debug: #testLastNElements" | result | result := self moreThan3Elements last: self moreThan3Elements size - 1. 1 to: result size do: [ :i | self assert: (result at: i) = (self moreThan3Elements at: i + 1) ]. self assert: result size = (self moreThan3Elements size - 1). self should: [ self moreThan3Elements last: self moreThan3Elements size + 1 ] raise: Error! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ArrayTest class uses: TEmptySequenceableTest classTrait + TSequencedElementAccessTest classTrait + TCloneTest classTrait + TCopyTest classTrait + TSetArithmetic classTrait + TCreationWithTest classTrait + TPutBasicTest classTrait + TConvertTest classTrait + TSortTest classTrait + TIterateSequencedReadableTest classTrait + TSequencedConcatenationTest classTrait + TReplacementSequencedTest classTrait + TAsStringCommaAndDelimiterSequenceableTest classTrait + TBeginsEndsWith classTrait + TPrintOnSequencedTest classTrait + TIndexAccess classTrait + TSubCollectionAccess classTrait + TCopyPartOfSequenceable classTrait + TCopySequenceableSameContents classTrait + TCopySequenceableWithOrWithoutSpecificElements classTrait + TCopySequenceableWithReplacement classTrait + TIndexAccessForMultipliness classTrait + TCopyPartOfSequenceableForMultipliness classTrait + TConvertAsSortedTest classTrait + TPutTest classTrait + TIncludesWithIdentityCheckTest classTrait + TConvertAsSetForMultiplinessIdentityTest classTrait + TSequencedStructuralEqualityTest classTrait + TOccurrencesForMultiplinessTest classTrait instanceVariableNames: ''! SequenceableCollection subclass: #ArrayedCollection instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Collections-Abstract'! !ArrayedCollection commentStamp: '' prior: 0! I am an abstract collection of elements with a fixed range of integers (from 1 to n>=0) as external keys.! !ArrayedCollection methodsFor: 'accessing' stamp: 'sma 5/12/2000 11:36'! size "Answer how many elements the receiver contains." ^ self basicSize! ! !ArrayedCollection methodsFor: 'adding' stamp: 'sma 5/12/2000 14:09'! add: newObject self shouldNotImplement! ! !ArrayedCollection methodsFor: 'filter streaming' stamp: 'sma 5/12/2000 14:20'! flattenOnStream: aStream aStream writeArrayedCollection: self! ! !ArrayedCollection methodsFor: 'objects from disk' stamp: 'nk 3/17/2004 15:22'! byteSize ^self basicSize * self bytesPerBasicElement ! ! !ArrayedCollection methodsFor: 'objects from disk' stamp: 'nk 3/17/2004 16:28'! bytesPerBasicElement "Answer the number of bytes that each of my basic elements requires. In other words: self basicSize * self bytesPerBasicElement should equal the space required on disk by my variable sized representation." ^self class isBytes ifTrue: [ 1 ] ifFalse: [ 4 ]! ! !ArrayedCollection methodsFor: 'objects from disk' stamp: 'nk 3/17/2004 18:51'! bytesPerElement ^self class isBytes ifTrue: [ 1 ] ifFalse: [ 4 ]. ! ! !ArrayedCollection methodsFor: 'objects from disk' stamp: 'nk 7/30/2004 17:50'! restoreEndianness "This word object was just read in from a stream. It was stored in Big Endian (Mac) format. Reverse the byte order if the current machine is Little Endian. We only intend this for non-pointer arrays. Do nothing if I contain pointers." self class isPointers | self class isWords not ifTrue: [^self]. SmalltalkImage current isLittleEndian ifTrue: [Bitmap swapBytesIn: self from: 1 to: self basicSize]! ! !ArrayedCollection methodsFor: 'objects from disk' stamp: 'tk 3/7/2001 17:36'! swapHalves "A normal switch in endianness (byte order in words) reverses the order of 4 bytes. That is not correct for SoundBuffers, which use 2-bytes units. If a normal switch has be done, this method corrects it further by swapping the two halves of the long word. This method is only used for 16-bit quanities in SoundBuffer, ShortIntegerArray, etc." | hack blt | "The implementation is a hack, but fast for large ranges" hack := Form new hackBits: self. blt := (BitBlt toForm: hack) sourceForm: hack. blt combinationRule: Form reverse. "XOR" blt sourceY: 0; destY: 0; height: self size; width: 2. blt sourceX: 0; destX: 2; copyBits. "Exchange bytes 0&1 with 2&3" blt sourceX: 2; destX: 0; copyBits. blt sourceX: 0; destX: 2; copyBits.! ! !ArrayedCollection methodsFor: 'objects from disk' stamp: 'ar 5/17/2001 19:50'! writeOn: aStream "Store the array of bits onto the argument, aStream. (leading byte ~= 16r80) identifies this as raw bits (uncompressed). Always store in Big Endian (Mac) byte order. Do the writing at BitBlt speeds. We only intend this for non-pointer arrays. Do nothing if I contain pointers." self class isPointers | self class isWords not ifTrue: [^ super writeOn: aStream]. "super may cause an error, but will not be called." aStream nextInt32Put: self basicSize. aStream nextWordsPutAll: self.! ! !ArrayedCollection methodsFor: 'objects from disk' stamp: 'tk 3/7/2001 18:07'! writeOnGZIPByteStream: aStream "We only intend this for non-pointer arrays. Do nothing if I contain pointers." self class isPointers | self class isWords not ifTrue: [^ super writeOnGZIPByteStream: aStream]. "super may cause an error, but will not be called." aStream nextPutAllWordArray: self! ! !ArrayedCollection methodsFor: 'printing'! storeOn: aStream aStream nextPutAll: '(('. aStream nextPutAll: self class name. aStream nextPutAll: ' new: '. aStream store: self size. aStream nextPut: $). (self storeElementsFrom: 1 to: self size on: aStream) ifFalse: [aStream nextPutAll: '; yourself']. aStream nextPut: $)! ! !ArrayedCollection methodsFor: 'sorting' stamp: 'sma 5/12/2000 18:18'! asSortedArray self isSorted ifTrue: [^ self asArray]. ^ super asSortedArray! ! !ArrayedCollection methodsFor: 'sorting' stamp: 'sma 6/1/2000 11:57'! isSorted "Return true if the receiver is sorted by the given criterion. Optimization for isSortedBy: [:a :b | a <= b]." | lastElm elm | self isEmpty ifTrue: [^ true]. lastElm := self first. 2 to: self size do: [:index | elm := self at: index. lastElm <= elm ifFalse: [^ false]. lastElm := elm]. ^ true! ! !ArrayedCollection methodsFor: 'sorting' stamp: 'sma 6/1/2000 11:58'! isSortedBy: aBlock "Return true if the receiver is sorted by the given criterion." | lastElm elm | self isEmpty ifTrue: [^ true]. lastElm := self first. 2 to: self size do: [:index | elm := self at: index. (aBlock value: lastElm value: elm) ifFalse: [^ false]. lastElm := elm]. ^ true! ! !ArrayedCollection methodsFor: 'sorting' stamp: 'sma 5/12/2000 14:28'! mergeFirst: first middle: middle last: last into: dst by: aBlock "Private. Merge the sorted ranges [first..middle] and [middle+1..last] of the receiver into the range [first..last] of dst." | i1 i2 val1 val2 out | i1 := first. i2 := middle + 1. val1 := self at: i1. val2 := self at: i2. out := first - 1. "will be pre-incremented" "select 'lower' half of the elements based on comparator" [(i1 <= middle) and: [i2 <= last]] whileTrue: [(aBlock value: val1 value: val2) ifTrue: [dst at: (out := out + 1) put: val1. val1 := self at: (i1 := i1 + 1)] ifFalse: [dst at: (out := out + 1) put: val2. i2 := i2 + 1. i2 <= last ifTrue: [val2 := self at: i2]]]. "copy the remaining elements" i1 <= middle ifTrue: [dst replaceFrom: out + 1 to: last with: self startingAt: i1] ifFalse: [dst replaceFrom: out + 1 to: last with: self startingAt: i2]! ! !ArrayedCollection methodsFor: 'sorting' stamp: 'sma 5/12/2000 14:25'! mergeSortFrom: startIndex to: stopIndex by: aBlock "Sort the given range of indices using the mergesort algorithm. Mergesort is a worst-case O(N log N) sorting algorithm that usually does only half as many comparisons as heapsort or quicksort." "Details: recursively split the range to be sorted into two halves, mergesort each half, then merge the two halves together. An extra copy of the data is used as temporary storage and successive merge phases copy data back and forth between the receiver and this copy. The recursion is set up so that the final merge is performed into the receiver, resulting in the receiver being completely sorted." self size <= 1 ifTrue: [^ self]. "nothing to do" startIndex = stopIndex ifTrue: [^ self]. self assert: [startIndex >= 1 and: [startIndex < stopIndex]]. "bad start index" self assert: [stopIndex <= self size]. "bad stop index" self mergeSortFrom: startIndex to: stopIndex src: self clone dst: self by: aBlock! ! !ArrayedCollection methodsFor: 'sorting' stamp: 'sma 5/12/2000 14:26'! mergeSortFrom: first to: last src: src dst: dst by: aBlock "Private. Split the range to be sorted in half, sort each half, and merge the two half-ranges into dst." | middle | first = last ifTrue: [^ self]. middle := (first + last) // 2. self mergeSortFrom: first to: middle src: dst dst: src by: aBlock. self mergeSortFrom: middle + 1 to: last src: dst dst: src by: aBlock. src mergeFirst: first middle: middle last: last into: dst by: aBlock! ! !ArrayedCollection methodsFor: 'sorting' stamp: 'sma 5/12/2000 14:22'! sort "Sort this array into ascending order using the '<=' operator." self sort: [:a :b | a <= b]! ! !ArrayedCollection methodsFor: 'sorting' stamp: 'sma 5/12/2000 14:21'! sort: aSortBlock "Sort this array using aSortBlock. The block should take two arguments and return true if the first element should preceed the second one." self mergeSortFrom: 1 to: self size by: aSortBlock! ! !ArrayedCollection methodsFor: 'private'! defaultElement ^nil! ! !ArrayedCollection methodsFor: 'private'! storeElementsFrom: firstIndex to: lastIndex on: aStream | noneYet defaultElement arrayElement | noneYet := true. defaultElement := self defaultElement. firstIndex to: lastIndex do: [:index | arrayElement := self at: index. arrayElement = defaultElement ifFalse: [noneYet ifTrue: [noneYet := false] ifFalse: [aStream nextPut: $;]. aStream nextPutAll: ' at: '. aStream store: index. aStream nextPutAll: ' put: '. aStream store: arrayElement]]. ^noneYet! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ArrayedCollection class instanceVariableNames: ''! !ArrayedCollection class methodsFor: 'instance creation'! new "Answer a new instance of me, with size = 0." ^self new: 0! ! !ArrayedCollection class methodsFor: 'instance creation'! new: size withAll: value "Answer an instance of me, with number of elements equal to size, each of which refers to the argument, value." ^(self new: size) atAllPut: value! ! !ArrayedCollection class methodsFor: 'instance creation'! newFrom: aCollection "Answer an instance of me containing the same elements as aCollection." | newArray | newArray := self new: aCollection size. 1 to: aCollection size do: [:i | newArray at: i put: (aCollection at: i)]. ^ newArray " Array newFrom: {1. 2. 3} {1. 2. 3} as: Array {1. 2. 3} as: ByteArray {$c. $h. $r} as: String {$c. $h. $r} as: Text "! ! !ArrayedCollection class methodsFor: 'instance creation' stamp: 'ar 5/17/2001 19:50'! newFromStream: s "Only meant for my subclasses that are raw bits and word-like. For quick unpack form the disk." | len | self isPointers | self isWords not ifTrue: [^ super newFromStream: s]. "super may cause an error, but will not be called." s next = 16r80 ifTrue: ["A compressed format. Could copy what BitMap does, or use a special sound compression format. Callers normally compress their own way." ^ self error: 'not implemented']. s skip: -1. len := s nextInt32. ^ s nextWordsInto: (self basicNew: len)! ! !ArrayedCollection class methodsFor: 'instance creation'! with: anObject "Answer a new instance of me, containing only anObject." | newCollection | newCollection := self new: 1. newCollection at: 1 put: anObject. ^newCollection! ! !ArrayedCollection class methodsFor: 'instance creation'! with: firstObject with: secondObject "Answer a new instance of me, containing firstObject and secondObject." | newCollection | newCollection := self new: 2. newCollection at: 1 put: firstObject. newCollection at: 2 put: secondObject. ^newCollection! ! !ArrayedCollection class methodsFor: 'instance creation'! with: firstObject with: secondObject with: thirdObject "Answer a new instance of me, containing only the three arguments as elements." | newCollection | newCollection := self new: 3. newCollection at: 1 put: firstObject. newCollection at: 2 put: secondObject. newCollection at: 3 put: thirdObject. ^newCollection! ! !ArrayedCollection class methodsFor: 'instance creation'! with: firstObject with: secondObject with: thirdObject with: fourthObject "Answer a new instance of me, containing only the three arguments as elements." | newCollection | newCollection := self new: 4. newCollection at: 1 put: firstObject. newCollection at: 2 put: secondObject. newCollection at: 3 put: thirdObject. newCollection at: 4 put: fourthObject. ^newCollection! ! !ArrayedCollection class methodsFor: 'instance creation'! with: firstObject with: secondObject with: thirdObject with: fourthObject with: fifthObject "Answer a new instance of me, containing only the five arguments as elements." | newCollection | newCollection := self new: 5. newCollection at: 1 put: firstObject. newCollection at: 2 put: secondObject. newCollection at: 3 put: thirdObject. newCollection at: 4 put: fourthObject. newCollection at: 5 put: fifthObject. ^newCollection! ! !ArrayedCollection class methodsFor: 'instance creation' stamp: 'sw 10/24/1998 22:22'! with: firstObject with: secondObject with: thirdObject with: fourthObject with: fifthObject with: sixthObject "Answer a new instance of me, containing only the 6 arguments as elements." | newCollection | newCollection := self new: 6. newCollection at: 1 put: firstObject. newCollection at: 2 put: secondObject. newCollection at: 3 put: thirdObject. newCollection at: 4 put: fourthObject. newCollection at: 5 put: fifthObject. newCollection at: 6 put: sixthObject. ^ newCollection! ! !ArrayedCollection class methodsFor: 'instance creation' stamp: 'sma 5/12/2000 17:37'! withAll: aCollection "Create a new collection containing all the elements from aCollection." ^ (self new: aCollection size) replaceFrom: 1 to: aCollection size with: aCollection! ! Halt subclass: #AssertionFailure instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Exceptions-Extensions'! !AssertionFailure commentStamp: 'gh 5/2/2002 20:29' prior: 0! AsssertionFailure is the exception signaled from Object>>assert: when the assertion block evaluates to false.! ParseNode subclass: #AssignmentNode instanceVariableNames: 'variable value' classVariableNames: '' poolDictionaries: '' category: 'Compiler-ParseNodes'! !AssignmentNode commentStamp: '' prior: 0! AssignmentNode comment: 'I represent a (var_expr) construct.'! !AssignmentNode methodsFor: 'code generation' stamp: 'eem 6/4/2008 11:26'! emitForEffect: stack on: aStream variable emitLoad: stack on: aStream. value emitForValue: stack on: aStream. pc := aStream position + 1. "debug pc is first byte of the store". variable emitStorePop: stack on: aStream! ! !AssignmentNode methodsFor: 'code generation' stamp: 'eem 6/4/2008 11:26'! emitForValue: stack on: aStream variable emitLoad: stack on: aStream. value emitForValue: stack on: aStream. pc := aStream position + 1. "debug pc is first byte of the store" variable emitStore: stack on: aStream! ! !AssignmentNode methodsFor: 'code generation'! sizeForEffect: encoder ^(value sizeForValue: encoder) + (variable sizeForStorePop: encoder)! ! !AssignmentNode methodsFor: 'code generation'! sizeForValue: encoder ^(value sizeForValue: encoder) + (variable sizeForStore: encoder)! ! !AssignmentNode methodsFor: 'code generation (closures)' stamp: 'eem 5/30/2008 09:37'! analyseTempsWithin: scopeBlock "" rootNode: rootNode "" assignmentPools: assignmentPools "" "N.B. since assigment happens _after_ the value is evaluated the value is sent the message _first_." value analyseTempsWithin: scopeBlock rootNode: rootNode assignmentPools: assignmentPools. variable beingAssignedToAnalyseTempsWithin: scopeBlock rootNode: rootNode assignmentPools: assignmentPools! ! !AssignmentNode methodsFor: 'code generation (new scheme)' stamp: 'eem 6/4/2008 11:27'! emitCodeForEffect: stack encoder: encoder variable emitCodeForLoad: stack encoder: encoder. value emitCodeForValue: stack encoder: encoder. pc := encoder methodStreamPosition + 1. "debug pc is first byte of the store, i.e. the next byte". variable emitCodeForStorePop: stack encoder: encoder! ! !AssignmentNode methodsFor: 'code generation (new scheme)' stamp: 'eem 6/4/2008 11:27'! emitCodeForValue: stack encoder: encoder variable emitCodeForLoad: stack encoder: encoder. value emitCodeForValue: stack encoder: encoder. pc := encoder methodStreamPosition + 1. "debug pc is first byte of the store, i.e. the next byte". variable emitCodeForStore: stack encoder: encoder! ! !AssignmentNode methodsFor: 'code generation (new scheme)' stamp: 'eem 5/20/2008 15:16'! sizeCodeForEffect: encoder ^(variable sizeCodeForLoad: encoder) + (value sizeCodeForValue: encoder) + (variable sizeCodeForStorePop: encoder)! ! !AssignmentNode methodsFor: 'code generation (new scheme)' stamp: 'eem 5/20/2008 15:16'! sizeCodeForValue: encoder ^(variable sizeCodeForLoad: encoder) + (value sizeCodeForValue: encoder) + (variable sizeCodeForStore: encoder)! ! !AssignmentNode methodsFor: 'equation translation'! variable ^variable! ! !AssignmentNode methodsFor: 'initialize-release'! toDoIncrement: var var = variable ifFalse: [^ nil]. (value isMemberOf: MessageNode) ifTrue: [^ value toDoIncrement: var] ifFalse: [^ nil]! ! !AssignmentNode methodsFor: 'initialize-release'! value ^ value! ! !AssignmentNode methodsFor: 'initialize-release'! variable: aVariable value: expression variable := aVariable. value := expression! ! !AssignmentNode methodsFor: 'initialize-release' stamp: 'di 3/22/1999 12:00'! variable: aVariable value: expression from: encoder (aVariable isMemberOf: MessageAsTempNode) ifTrue: ["Case of remote temp vars" ^ aVariable store: expression from: encoder]. variable := aVariable. value := expression! ! !AssignmentNode methodsFor: 'initialize-release' stamp: 'hmm 7/15/2001 21:17'! variable: aVariable value: expression from: encoder sourceRange: range encoder noteSourceRange: range forNode: self. ^self variable: aVariable value: expression from: encoder! ! !AssignmentNode methodsFor: 'printing' stamp: 'eem 5/6/2008 13:48'! printOn: aStream indent: level variable printOn: aStream indent: level. aStream nextPutAll: ' := '. value printOn: aStream indent: level + 2! ! !AssignmentNode methodsFor: 'printing' stamp: 'eem 5/9/2008 18:44'! printOn: aStream indent: level precedence: p aStream nextPut: $(. self printOn: aStream indent: level. aStream nextPut: $)! ! !AssignmentNode methodsFor: 'printing' stamp: 'eem 6/2/2008 11:47'! printWithClosureAnalysisOn: aStream indent: level variable printWithClosureAnalysisOn: aStream indent: level. aStream nextPutAll: ' := '. value printWithClosureAnalysisOn: aStream indent: level + 2! ! !AssignmentNode methodsFor: 'printing' stamp: 'eem 6/2/2008 11:47'! printWithClosureAnalysisOn: aStream indent: level precedence: p aStream nextPut: $(. self printWithClosureAnalysisOn: aStream indent: level. aStream nextPut: $)! ! !AssignmentNode methodsFor: 'testing' stamp: 'eem 6/16/2008 09:37'! isAssignmentNode ^true! ! !AssignmentNode methodsFor: 'visiting' stamp: 'eem 9/10/2008 15:12'! accept: aVisitor aVisitor visitAssignmentNode: self! ! LookupKey subclass: #Association instanceVariableNames: 'value' classVariableNames: '' poolDictionaries: '' category: 'Collections-Support'! !Association commentStamp: '' prior: 0! I represent a pair of associated objects--a key and a value. My instances can serve as entries in a dictionary.! !Association methodsFor: '*services-base-preferences' stamp: 'rr 3/21/2006 11:58'! serviceUpdate self key service perform: self value! ! !Association methodsFor: 'accessing' stamp: 'John M McIntosh 3/2/2009 21:15'! isSpecialWriteBinding "Return true if this variable binding is write protected, e.g., should not be accessed primitively but rather by sending #value: messages" ^false! ! !Association methodsFor: 'accessing'! key: aKey value: anObject "Store the arguments as the variables of the receiver." key := aKey. value := anObject! ! !Association methodsFor: 'accessing'! value "Answer the value of the receiver." ^value! ! !Association methodsFor: 'accessing'! value: anObject "Store the argument, anObject, as the value of the receiver." value := anObject! ! !Association methodsFor: 'comparing' stamp: 'md 1/27/2004 17:27'! = anAssociation ^ super = anAssociation and: [value = anAssociation value]! ! !Association methodsFor: 'filter streaming' stamp: 'MPW 1/1/1901 20:53'! byteEncode: aStream aStream writeAssocation:self.! ! !Association methodsFor: 'objects from disk' stamp: 'tk 10/3/2000 13:03'! objectForDataStream: refStrm | dp | "I am about to be written on an object file. If I am a known global, write a proxy that will hook up with the same resource in the destination system." ^ (Smalltalk associationAt: key ifAbsent: [nil]) == self ifTrue: [dp := DiskProxy global: #Smalltalk selector: #associationOrUndeclaredAt: args: (Array with: key). refStrm replace: self with: dp. dp] ifFalse: [self]! ! !Association methodsFor: 'printing'! printOn: aStream super printOn: aStream. aStream nextPutAll: '->'. value printOn: aStream! ! !Association methodsFor: 'printing' stamp: 'MPW 1/4/1901 08:31'! propertyListOn: aStream aStream write:key; print:'='; write:value. ! ! !Association methodsFor: 'printing'! storeOn: aStream "Store in the format (key->value)" aStream nextPut: $(. key storeOn: aStream. aStream nextPutAll: '->'. value storeOn: aStream. aStream nextPut: $)! ! !Association methodsFor: 'self evaluating' stamp: 'sd 7/31/2005 21:44'! isSelfEvaluating ^ self class == Association! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Association class instanceVariableNames: ''! !Association class methodsFor: 'instance creation'! key: newKey value: newValue "Answer an instance of me with the arguments as the key and value of the association." ^(super key: newKey) value: newValue! ! ClassTestCase subclass: #AssociationTest instanceVariableNames: 'a b' classVariableNames: '' poolDictionaries: '' category: 'CollectionsTests-Support'! !AssociationTest methodsFor: 'setup' stamp: 'zz 12/5/2005 18:33'! setUp a := 1 -> 'one'. b := 1 -> 'een'.! ! !AssociationTest methodsFor: 'tests' stamp: 'ab 12/29/2008 07:59'! testComparison self assert: ((#a -> 'foo') < (#b -> 'zork'))! ! !AssociationTest methodsFor: 'tests' stamp: 'md 3/8/2004 16:37'! testEquality self assert: (a key = b key); deny: (a value = b value); deny: (a = b) ! ! !AssociationTest methodsFor: 'tests' stamp: 'al 10/13/2008 20:32'! testHash self assert: (a hash = a copy hash); assert: (a hash = b hash)! ! !AssociationTest methodsFor: 'tests' stamp: 'ab 12/29/2008 08:01'! testIsSelfEvaluating self assert: (a isSelfEvaluating). self assert: (a printString = '1->''one''') ! ! Object subclass: #AsyncFile instanceVariableNames: 'name writeable semaphore fileHandle' classVariableNames: 'Busy ErrorCode' poolDictionaries: '' category: 'Files-Kernel'! !AsyncFile commentStamp: '' prior: 0! An asynchronous file allows simple file read and write operations to be performed in parallel with other processing. This is useful in multimedia applications that need to stream large amounts of sound or image data from or to a file while doing other work. ! !AsyncFile methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:31'! close fileHandle ifNil: [^ self]. "already closed" self primClose: fileHandle. Smalltalk unregisterExternalObject: semaphore. semaphore := nil. fileHandle := nil. ! ! !AsyncFile methodsFor: 'as yet unclassified' stamp: 'di 7/6/1998 10:58'! fileHandle ^ fileHandle! ! !AsyncFile methodsFor: 'as yet unclassified' stamp: 'ar 6/3/2007 22:13'! open: fullFileName forWrite: aBoolean "Open a file of the given name, and return a handle for that file. Answer the receiver if the primitive succeeds, nil otherwise. If openForWrite is true, then: if there is no existing file with this name, then create one else open the existing file in read-write mode otherwise: if there is an existing file with this name, then open it read-only else answer nil." "Note: if an exisiting file is opened for writing, it is NOT truncated. If truncation is desired, the file should be deleted before being opened as an asynchronous file." "Note: On some platforms (e.g., Mac), a file can only have one writer at a time." | semaIndex | name := fullFileName. writeable := aBoolean. semaphore := Semaphore new. semaIndex := Smalltalk registerExternalObject: semaphore. fileHandle := self primOpen: name asVmPathName forWrite: writeable semaIndex: semaIndex. fileHandle ifNil: [ Smalltalk unregisterExternalObject: semaphore. semaphore := nil. ^ nil]. ! ! !AsyncFile methodsFor: 'as yet unclassified' stamp: 'nice 4/16/2009 10:02'! readByteCount: byteCount fromFilePosition: fPosition onCompletionDo: aBlock "Start a read operation to read byteCount's from the given position in this file. and fork a process to await its completion. When the operation completes, evaluate the given block. Note that, since the completion block may run asynchronous, the client may need to use a SharedQueue or a semaphore for synchronization." | buffer | buffer := String new: byteCount. self primReadStart: fileHandle fPosition: fPosition count: byteCount. "here's the process that awaits the results:" [| n | [ semaphore wait. n := self primReadResult: fileHandle intoBuffer: buffer at: 1 count: byteCount. n = Busy. ] whileTrue. "loop while busy in case the semaphore had excess signals" n = ErrorCode ifTrue: [^ self error: 'asynchronous read operation failed']. aBlock value: buffer. ] forkAt: Processor userInterruptPriority. ! ! !AsyncFile methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:31'! test: byteCount fileName: fileName "AsyncFile new test: 10000 fileName: 'testData'" | buf1 buf2 bytesWritten bytesRead | buf1 := String new: byteCount withAll: $x. buf2 := String new: byteCount. self open: ( FileDirectory default fullNameFor: fileName) forWrite: true. self primWriteStart: fileHandle fPosition: 0 fromBuffer: buf1 at: 1 count: byteCount. semaphore wait. bytesWritten := self primWriteResult: fileHandle. self close. self open: ( FileDirectory default fullNameFor: fileName) forWrite: false. self primReadStart: fileHandle fPosition: 0 count: byteCount. semaphore wait. bytesRead := self primReadResult: fileHandle intoBuffer: buf2 at: 1 count: byteCount. self close. buf1 = buf2 ifFalse: [self error: 'buffers do not match']. ^ 'wrote ', bytesWritten printString, ' bytes; ', 'read ', bytesRead printString, ' bytes' ! ! !AsyncFile methodsFor: 'as yet unclassified' stamp: 'di 7/6/1998 10:58'! waitForCompletion semaphore wait! ! !AsyncFile methodsFor: 'as yet unclassified' stamp: 'nice 4/16/2009 10:02'! writeBuffer: buffer atFilePosition: fPosition onCompletionDo: aBlock "Start an operation to write the contents of the buffer at given position in this file, and fork a process to await its completion. When the write completes, evaluate the given block. Note that, since the completion block runs asynchronously, the client may need to use a SharedQueue or a semaphore for synchronization." self primWriteStart: fileHandle fPosition: fPosition fromBuffer: buffer at: 1 count: buffer size. "here's the process that awaits the results:" [| n | [ semaphore wait. n := self primWriteResult: fileHandle. n = Busy. ] whileTrue. "loop while busy in case the semaphore had excess signals" n = ErrorCode ifTrue: [^ self error: 'asynchronous write operation failed']. n = buffer size ifFalse: [^ self error: 'did not write the entire buffer']. aBlock value. ] forkAt: Processor userInterruptPriority. ! ! !AsyncFile methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'! primClose: fHandle "Close this file. Do nothing if primitive fails." ! ! !AsyncFile methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'! primOpen: fileName forWrite: openForWrite semaIndex: semaIndex "Open a file of the given name, and return a handle for that file. Answer the receiver if the primitive succeeds, nil otherwise." ^ nil ! ! !AsyncFile methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'! primReadResult: fHandle intoBuffer: buffer at: startIndex count: count "Copy the result of the last read operation into the given buffer starting at the given index. The buffer may be any sort of bytes or words object, excluding CompiledMethods. Answer the number of bytes read. A negative result means: -1 the last operation is still in progress -2 the last operation encountered an error" self primitiveFailed ! ! !AsyncFile methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'! primReadStart: fHandle fPosition: fPosition count: count "Start a read operation of count bytes starting at the given offset in the given file." self error: 'READ THE COMMENT FOR THIS METHOD.' "NOTE: This method will fail if there is insufficient C heap to allocate an internal buffer of the required size (the value of count). If you are trying to read a movie file, then the buffer size will be height*width*2 bytes. Each Squeak image retains a value to be used for this allocation, and it it initially set to 0. If you are wish to play a 640x480 movie, you need room for a buffer of 640*480*2 = 614400 bytes. You should execute the following... Smalltalk extraVMMemory 2555000. Then save-and-quit, restart, and try to open the movie file again. If you are using Async files in another way, find out the value of count when this failure occurs (call it NNNN), and instead of the above, execute... Smalltalk extraVMMemory: Smalltalk extraVMMemory + NNNN then save-and-quit, restart, and try again. " ! ! !AsyncFile methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'! primWriteResult: fHandle "Answer the number of bytes written. A negative result means: -1 the last operation is still in progress -2 the last operation encountered an error" self primitiveFailed ! ! !AsyncFile methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'! primWriteStart: fHandle fPosition: fPosition fromBuffer: buffer at: startIndex count: count "Start a write operation of count bytes starting at the given index in the given buffer. The buffer may be any sort of bytes or words object, excluding CompiledMethods. The contents of the buffer are copied into an internal buffer immediately, so the buffer can be reused after the write operation has been started. Fail if there is insufficient C heap to allocate an internal buffer of the requested size." writeable ifFalse: [^ self error: 'attempt to write a file opened read-only']. self primitiveFailed ! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AsyncFile class instanceVariableNames: ''! !AsyncFile class methodsFor: 'initialization' stamp: 'bootstrap 5/31/2006 20:45'! initialize "AsyncFile initialize" "Possible abnormal I/O completion results." Busy := -1. ErrorCode := -2. ! ! Object subclass: #Author instanceVariableNames: 'fullName' classVariableNames: '' poolDictionaries: '' category: 'System-Support'! !Author commentStamp: 'MiguelCoba 7/25/2009 01:09' prior: 0! I am responsible for the full name used to identify the current code author.! !Author methodsFor: 'accessing' stamp: 'MiguelCoba 7/25/2009 02:41'! fullName "Answer the full name to be used to identify the current code author." [fullName isEmptyOrNil ] whileTrue: [self requestFullName]. ^ fullName! ! !Author methodsFor: 'accessing' stamp: 'MiguelCoba 7/25/2009 00:55'! fullName: aString fullName := aString.! ! !Author methodsFor: 'accessing' stamp: 'MiguelCoba 7/25/2009 00:58'! fullNamePerSe "Answer the currently-prevailing author full name, such as it is, empty or not" ^ fullName! ! !Author methodsFor: 'initialization' stamp: 'MiguelCoba 7/25/2009 03:07'! initialize super initialize. fullName := ''.! ! !Author methodsFor: 'ui-requests' stamp: 'MiguelCoba 9/16/2009 12:10'! messagePrompt ^ 'Please type your full name. It will be used to sign the changes you make to the image. Avoid spaces, accents, dashes, underscore and similar characters. Vincent van Gogh -> VincentVanGogh Miguel Cobá -> MiguelCoba Göran Krampe -> GoranKrampe Göran Krampe -> GoeranKrampe Stéphane DUCASSE -> StephaneDucasse Yoshiki Oshima -> YoshikiOshima '! ! !Author methodsFor: 'ui-requests' stamp: 'MiguelCoba 7/25/2009 01:54'! requestFullName | initialAnswer | initialAnswer := fullName isEmptyOrNil ifTrue: ['FirstnameLastname' translated] ifFalse: [fullName]. fullName := UIManager default request: self messagePrompt initialAnswer: initialAnswer! ! !Author methodsFor: 'testing-support' stamp: 'oscar.nierstrasz 10/18/2009 18:27'! useAuthor: aString during: aBlock | previous | previous := fullName. fullName := aString. ^ aBlock ensure: [ fullName := previous ]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Author class instanceVariableNames: 'uniqueInstance'! !Author class methodsFor: 'convenience' stamp: 'MiguelCoba 7/25/2009 01:58'! fullName ^ Author uniqueInstance fullName! ! !Author class methodsFor: 'convenience' stamp: 'MiguelCoba 7/25/2009 01:58'! fullName: aString ^ Author uniqueInstance fullName: aString! ! !Author class methodsFor: 'convenience' stamp: 'MiguelCoba 7/25/2009 01:58'! fullNamePerSe ^ Author uniqueInstance fullNamePerSe! ! !Author class methodsFor: 'convenience' stamp: 'MiguelCoba 7/25/2009 01:10'! requestFullName ^ Author uniqueInstance requestFullName! ! !Author class methodsFor: 'deprecated' stamp: 'AndrewBlack 9/1/2009 06:24'! initials self deprecated: 'Use ''Author fullName'' instead.'. ^ Author uniqueInstance fullName! ! !Author class methodsFor: 'deprecated' stamp: 'AndrewBlack 9/1/2009 06:25'! initials: aString self deprecated: 'Use ''Author fullName:'' instead.'. ^ Author uniqueInstance fullName: aString! ! !Author class methodsFor: 'deprecated' stamp: 'AndrewBlack 9/1/2009 06:25'! initialsPerSe self deprecated: 'Use ''Author fullNamePerSe'' instead.'. ^ Author uniqueInstance fullNamePerSe! ! !Author class methodsFor: 'deprecated' stamp: 'AndrewBlack 9/1/2009 06:26'! requestInitials self deprecated: 'Use ''Author requestFullName'' instead.'. ^ Author uniqueInstance requestFullName! ! !Author class methodsFor: 'deprecated' stamp: 'AndrewBlack 9/1/2009 06:27'! requestName self deprecated: 'Use ''Author requestFullName'' instead.'. ^ Author uniqueInstance requestFullName! ! !Author class methodsFor: 'instance creation' stamp: 'on 5/10/2008 13:05'! new self error: 'Author is a singleton -- send uniqueInstance instead'! ! !Author class methodsFor: 'instance creation' stamp: 'on 5/10/2008 13:10'! reset ^ uniqueInstance := nil! ! !Author class methodsFor: 'instance creation' stamp: 'on 5/10/2008 13:09'! uniqueInstance ^ uniqueInstance ifNil: [ uniqueInstance := super new ]! ! !Author class methodsFor: 'instance creation' stamp: 'on 5/10/2008 13:27'! uniqueInstance: anInstance "Needed by AuthorTest to restore saved instance" ^ uniqueInstance := anInstance! ! !Author class methodsFor: 'testing-support' stamp: 'oscar.nierstrasz 10/18/2009 18:31'! useAuthor: aString during: aBlock ^ self uniqueInstance useAuthor: aString during: aBlock! ! TestCase subclass: #AuthorTest instanceVariableNames: 'author' classVariableNames: '' poolDictionaries: '' category: 'Tests-System'! !AuthorTest methodsFor: 'running' stamp: 'on 5/10/2008 13:31'! setUp author := Author uniqueInstance. Author reset.! ! !AuthorTest methodsFor: 'running' stamp: 'on 5/10/2008 13:21'! tearDown Author uniqueInstance: author! ! !AuthorTest methodsFor: 'running' stamp: 'on 5/10/2008 14:48'! testDeprecation | savedPref | savedPref := Preferences showDeprecationWarnings. Preferences setPreference: #showDeprecationWarnings toValue: true. self should: [ Utilities authorInitials ] raise: Warning. self should: [ Utilities authorInitialsPerSe ] raise: Warning. self should: [ Utilities setAuthorInitials ] raise: Warning. self should: [ Utilities setAuthorInitials: 'ak' ] raise: Warning. self should: [ Utilities authorName ] raise: Warning. self should: [ Utilities authorName: 'alan' ] raise: Warning. self should: [ Utilities authorNamePerSe ] raise: Warning. self should: [ Utilities setAuthorName ] raise: Warning. Preferences setPreference: #showDeprecationWarnings toValue: savedPref. ! ! !AuthorTest methodsFor: 'running' stamp: 'MiguelCoba 7/25/2009 02:45'! testInitiallyEmpty self assert: (Author uniqueInstance fullNamePerSe isEmpty). ! ! !AuthorTest methodsFor: 'running' stamp: 'on 5/10/2008 13:35'! testUniqueness self should: [ Author new ] raise: Error.! ! Object subclass: #Authorizer instanceVariableNames: 'users realm' classVariableNames: '' poolDictionaries: '' category: 'Network-Url'! !Authorizer commentStamp: '' prior: 0! The Authorizer does user authorization checking. Each instance of authorizer keeps track of the realm that it is authorizing for, and the table of authorized users. An authorizer can be asked to return the user name/symbol associated with a userID (which concatenates the username and password from the HTTP request) with the user: method. ! !Authorizer methodsFor: 'authentication' stamp: 'PeterHugossonMiller 9/3/2009 00:12'! encode: nameString password: pwdString "Encode per RFC1421 of the username:password combination." | clear code clearSize idx map | clear := (nameString, ':', pwdString) asByteArray. clearSize := clear size. [ clear size \\ 3 ~= 0 ] whileTrue: [ clear := clear, #(0) ]. idx := 1. map := 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/'. code := String new writeStream. [ idx < clear size ] whileTrue: [ code nextPut: (map at: (clear at: idx) // 4 + 1); nextPut: (map at: (clear at: idx) \\ 4 * 16 + ((clear at: idx + 1) // 16) + 1); nextPut: (map at: (clear at: idx + 1) \\ 16 * 4 + ((clear at: idx + 2) // 64) + 1); nextPut: (map at: (clear at: idx + 2) \\ 64 + 1). idx := idx + 3 ]. code := code contents. idx := code size. clear size - clearSize timesRepeat: [ code at: idx put: $=. idx := idx - 1]. ^code! ! !Authorizer methodsFor: 'authentication' stamp: 'mjg 11/3/97 12:31'! mapFrom: aKey to: aPerson "Establish a mapping from a RFC 1421 key to a user." users isNil ifTrue: [ users := Dictionary new ]. aPerson isNil ifTrue: [ users removeKey: aKey ] ifFalse: [ users removeKey: (users keyAtValue: aPerson ifAbsent: []) ifAbsent: []. users at: aKey put: aPerson ] ! ! !Authorizer methodsFor: 'authentication' stamp: 'tk 5/21/1998 16:32'! mapName: nameString password: pwdString to: aPerson "Insert/remove the encoding per RFC1421 of the username:password combination into/from the UserMap. DO NOT call this directly, use mapName:password:to: in your ServerAction class. Only it knows how to record the change on the disk!!" self mapFrom: (self encode: nameString password: pwdString) to: aPerson ! ! !Authorizer methodsFor: 'authentication' stamp: 'ar 8/17/2001 18:19'! user: userId "Return the requesting user." ^users at: userId ifAbsent: [ self error: (self class unauthorizedFor: realm) ]! ! !Authorizer methodsFor: 'realms' stamp: 'mjg 11/3/97 12:33'! realm ^realm! ! !Authorizer methodsFor: 'realms' stamp: 'mjg 11/3/97 12:33'! realm: aString realm := aString ! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Authorizer class instanceVariableNames: ''! !Authorizer class methodsFor: 'as yet unclassified' stamp: 'adrian_lienhard 7/18/2009 15:52'! unauthorizedFor: realm ^'HTTP/1.0 401 Unauthorized', self crlf, 'WWW-Authenticate: Basic realm="Pharo/',realm,'"', String crlfcrlf, 'Unauthorized

Unauthorized for ',realm, '

' ! ! Object subclass: #AutoStart instanceVariableNames: 'parameters' classVariableNames: 'Active InstalledLaunchers' poolDictionaries: '' category: 'System-Support'! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AutoStart class instanceVariableNames: ''! !AutoStart class methodsFor: 'accessing' stamp: 'mir 7/28/1999 17:47'! addLauncher: launcher self installedLaunchers add: launcher! ! !AutoStart class methodsFor: 'accessing'! addLauncherFirst: launcher self installedLaunchers addFirst: launcher! ! !AutoStart class methodsFor: 'accessing' stamp: 'mir 7/28/1999 17:47'! removeLauncher: launcher self installedLaunchers remove: launcher ifAbsent: []! ! !AutoStart class methodsFor: 'initialization' stamp: 'mir 7/28/1999 17:44'! deinstall "AutoStart deinstall" Smalltalk removeFromStartUpList: AutoStart. InstalledLaunchers := nil! ! !AutoStart class methodsFor: 'initialization' stamp: 'mir 9/30/2004 15:05'! initialize "AutoStart initialize" "Order: ExternalSettings, SecurityManager, AutoStart" Smalltalk addToStartUpList: AutoStart after: SecurityManager. Smalltalk addToShutDownList: AutoStart after: SecurityManager.! ! !AutoStart class methodsFor: 'initialization' stamp: 'mir 9/30/2004 15:06'! shutDown: quitting self active: false! ! !AutoStart class methodsFor: 'initialization' stamp: 'stephane.ducasse 4/13/2009 21:14'! startUp: resuming "The image is either being newly started (resuming is true), or it's just been snapshotted. If this has just been a snapshot, skip all the startup stuff." | startupParameters launchers | self active ifTrue: [^self]. self active: true. resuming ifFalse: [^self]. HTTPClient determineIfRunningInBrowser. startupParameters := AbstractLauncher extractParameters. (startupParameters includesKey: 'apiSupported' asUppercase ) ifTrue: [ HTTPClient browserSupportsAPI: ((startupParameters at: 'apiSupported' asUppercase) asUppercase = 'TRUE'). HTTPClient isRunningInBrowser ifFalse: [HTTPClient isRunningInBrowser: true]]. self checkForUpdates ifTrue: [^self]. self checkForPluginUpdate. launchers := self installedLaunchers collect: [:launcher | launcher new]. launchers do: [:launcher | launcher parameters: startupParameters]. launchers do: [:launcher | Smalltalk at: #WorldState ifPresent: [ :ws | ws addDeferredUIMessage: [launcher startUp]]]! ! !AutoStart class methodsFor: 'updating' stamp: 'sd 3/20/2008 22:26'! checkForPluginUpdate | pluginVersion updateURL | World ifNotNil: [ World install. ActiveHand position: 100@100]. HTTPClient isRunningInBrowser ifFalse: [^false]. pluginVersion := AbstractLauncher extractParameters at: (SmalltalkImage current platformName copyWithout: Character space) asUppercase ifAbsent: [^false]. updateURL := AbstractLauncher extractParameters at: 'UPDATE_URL' ifAbsent: [^false]. ^SystemVersion check: pluginVersion andRequestPluginUpdate: updateURL! ! !AutoStart class methodsFor: 'updating' stamp: 'sd 3/20/2008 22:26'! checkForUpdates | availableUpdate updateServer | World ifNotNil: [ World install. ActiveHand position: 100@100]. HTTPClient isRunningInBrowser ifFalse: [^self processUpdates]. availableUpdate := (AbstractLauncher extractParameters at: 'UPDATE' ifAbsent: [''] ) asInteger. availableUpdate ifNil: [^false]. updateServer := AbstractLauncher extractParameters at: 'UPDATESERVER' ifAbsent: [AbstractLauncher extractParameters at: 'UPDATE_SERVER' ifAbsent: ['Squeakland']]. Utilities setUpdateServer: updateServer. ^SystemVersion checkAndApplyUpdates: availableUpdate! ! !AutoStart class methodsFor: 'updating' stamp: 'CdG 10/17/2005 19:34'! processUpdates "Process update files from a well-known update server. This method is called at system startup time, Only if the preference #updateFromServerAtStartup is true is the actual update processing undertaken automatically" | choice | (Preferences valueOfFlag: #updateFromServerAtStartup) ifTrue: [choice := UIManager default chooseFrom: #('Yes, Update' 'No, Not now' 'Don''t ask again') title: 'Shall I look for new code\updates on the server?' withCRs. choice = 1 ifTrue: [ Utilities updateFromServer]. choice = 3 ifTrue: [ Preferences setPreference: #updateFromServerAtStartup toValue: false. self inform: 'Remember to save you image to make this setting permant.']]. ^false! ! !AutoStart class methodsFor: 'private' stamp: 'mir 9/7/2004 13:34'! active ^ Active == true! ! !AutoStart class methodsFor: 'private' stamp: 'mir 9/7/2004 13:36'! active: aBoolean Active := aBoolean! ! !AutoStart class methodsFor: 'private' stamp: 'mir 7/28/1999 17:43'! installedLaunchers InstalledLaunchers ifNil: [ InstalledLaunchers := OrderedCollection new]. ^InstalledLaunchers! ! Object subclass: #BDFFontReader instanceVariableNames: 'file properties' classVariableNames: '' poolDictionaries: '' category: 'Graphics-Fonts'! !BDFFontReader commentStamp: '' prior: 0! I am a conversion utility for reading X11 Bitmap Distribution Format fonts. My code is derived from the multilingual Squeak changeset written by OHSHIMA Yoshiki (ohshima@is.titech.ac.jp), although all support for fonts with more than 256 glyphs has been ripped out. See http://www.is.titech.ac.jp/~ohshima/squeak/squeak-multilingual-e.html . My class methods contain tools for fetching BDF source files from a well-known archive site, batch conversion to Squeak's .sf2 format, and installation of these fonts as TextStyles. Also, the legal notices for the standard 75dpi fonts I process this way are included as "x11FontLegalNotices'.! !BDFFontReader methodsFor: 'initialize' stamp: 'alain.plantec 5/28/2009 09:41'! initialize super initialize. properties := Dictionary new.! ! !BDFFontReader methodsFor: 'initialize' stamp: 'pmm 7/4/2009 12:05'! openFileNamed: fileName file := (MultiByteFileStream readOnlyFileNamed: fileName) ascii; wantsLineEndConversion: true; yourself! ! !BDFFontReader methodsFor: 'reading' stamp: 'nop 1/18/2000 19:45'! errorFileFormat self error: 'malformed bdf format'! ! !BDFFontReader methodsFor: 'reading' stamp: 'nop 1/18/2000 19:46'! errorUnsupported self error: 'unsupported bdf'! ! !BDFFontReader methodsFor: 'reading' stamp: 'ar 10/25/2005 00:35'! getLine ^file upTo: Character cr.! ! !BDFFontReader methodsFor: 'reading' stamp: 'damiencassou 5/30/2008 14:51'! read | xTable strikeWidth glyphs ascent descent minAscii maxAscii maxWidth chars charsNum height form encoding bbx array width blt lastAscii pointSize ret stream | form := encoding := bbx := nil. self readAttributes. height := Integer readFromString: ((properties at: #FONTBOUNDINGBOX) at: 2). ascent := Integer readFromString: (properties at: 'FONT_ASCENT' asSymbol) first. descent := Integer readFromString: (properties at: 'FONT_DESCENT' asSymbol) first. pointSize := (Integer readFromString: (properties at: 'POINT_SIZE' asSymbol) first) // 10. maxWidth := 0. minAscii := 9999. strikeWidth := 0. maxAscii := 0. charsNum := Integer readFromString: (properties at: #CHARS) first. chars := Set new: charsNum. 1 to: charsNum do: [ :i | array := self readOneCharacter. stream := array readStream. form := stream next. encoding := stream next. bbx := stream next. form ifNotNil: [ width := bbx at: 1. maxWidth := maxWidth max: width. minAscii := minAscii min: encoding. maxAscii := maxAscii max: encoding. strikeWidth := strikeWidth + width. chars add: array ] ]. chars := chars asSortedCollection: [ :x :y | (x at: 2) <= (y at: 2) ]. charsNum := chars size. "undefined encodings make this different" charsNum > 256 ifTrue: [ "it should be 94x94 charset, and should be fixed width font" strikeWidth := 94 * 94 * maxWidth. maxAscii := 94 * 94. minAscii := 0. xTable := XTableForFixedFont new. xTable maxAscii: 94 * 94. xTable width: maxWidth ] ifFalse: [ xTable := (Array new: 258) atAllPut: 0 ]. glyphs := Form extent: strikeWidth @ height. blt := BitBlt toForm: glyphs. lastAscii := 0. charsNum > 256 ifTrue: [ 1 to: charsNum do: [ :i | stream := (chars at: i) readStream. form := stream next. encoding := stream next. bbx := stream next. encoding := (encoding // 256 - 33) * 94 + (encoding \\ 256 - 33). blt copy: ((encoding * maxWidth) @ 0 extent: maxWidth @ height) from: 0 @ 0 in: form ] ] ifFalse: [ 1 to: charsNum do: [ :i | stream := (chars at: i) readStream. form := stream next. encoding := stream next. bbx := stream next. lastAscii + 1 to: encoding - 1 do: [ :a | xTable at: a + 2 put: (xTable at: a + 1) ]. blt copy: ((xTable at: encoding + 1) @ (ascent - (bbx at: 2) - (bbx at: 4)) extent: (bbx at: 1) @ (bbx at: 2)) from: 0 @ 0 in: form. xTable at: encoding + 2 put: (xTable at: encoding + 1) + (bbx at: 1). lastAscii := encoding ] ]. ret := Array new: 8. ret at: 1 put: xTable. ret at: 2 put: glyphs. ret at: 3 put: minAscii. ret at: 4 put: maxAscii. ret at: 5 put: maxWidth. ret at: 6 put: ascent. ret at: 7 put: descent. ret at: 8 put: pointSize. ^ ret " ^{xTable. glyphs. minAscii. maxAscii. maxWidth. ascent. descent. pointSize}"! ! !BDFFontReader methodsFor: 'reading' stamp: 'lr 7/4/2009 10:42'! readAttributes "I don't handle double-quotes correctly, but it works" | str a | file reset. [ file atEnd ] whileFalse: [ str := self getLine. (str beginsWith: 'STARTCHAR') ifTrue: [ file skip: 0 - str size - 1. ^ self ]. a := str substrings. properties at: a first asSymbol put: a allButFirst ]. self error: 'file seems corrupted'! ! !BDFFontReader methodsFor: 'reading' stamp: 'damiencassou 5/30/2008 14:51'! readChars | strikeWidth ascent descent minAscii maxAscii maxWidth chars charsNum height form encoding bbx array width pointSize stream | form := encoding := bbx := nil. self readAttributes. height := Integer readFromString: ((properties at: #FONTBOUNDINGBOX) at: 2). ascent := Integer readFromString: (properties at: 'FONT_ASCENT' asSymbol) first. descent := Integer readFromString: (properties at: 'FONT_DESCENT' asSymbol) first. pointSize := (Integer readFromString: (properties at: 'POINT_SIZE' asSymbol) first) // 10. maxWidth := 0. minAscii := 9999. strikeWidth := 0. maxAscii := 0. charsNum := Integer readFromString: (properties at: #CHARS) first. chars := Set new: charsNum. 1 to: charsNum do: [ :i | array := self readOneCharacter. stream := array readStream. form := stream next. encoding := stream next. bbx := stream next. form ifNotNil: [ width := bbx at: 1. maxWidth := maxWidth max: width. minAscii := minAscii min: encoding. maxAscii := maxAscii max: encoding. strikeWidth := strikeWidth + width. chars add: array ] ]. chars := chars asSortedCollection: [ :x :y | (x at: 2) <= (y at: 2) ]. ^ chars! ! !BDFFontReader methodsFor: 'reading' stamp: 'lr 7/4/2009 10:42'! readOneCharacter | str a encoding bbx form bits hi low pos | ((str := self getLine) beginsWith: 'ENDFONT') ifTrue: [ ^ { nil. nil. nil } ]. (str beginsWith: 'STARTCHAR') ifFalse: [ self errorFileFormat ]. ((str := self getLine) beginsWith: 'ENCODING') ifFalse: [ self errorFileFormat ]. encoding := Integer readFromString: str substrings second. (self getLine beginsWith: 'SWIDTH') ifFalse: [ self errorFileFormat ]. (self getLine beginsWith: 'DWIDTH') ifFalse: [ self errorFileFormat ]. ((str := self getLine) beginsWith: 'BBX') ifFalse: [ self errorFileFormat ]. a := str substrings. bbx := (2 to: 5) collect: [ :i | Integer readFromString: (a at: i) ]. ((str := self getLine) beginsWith: 'ATTRIBUTES') ifTrue: [ str := self getLine ]. (str beginsWith: 'BITMAP') ifFalse: [ self errorFileFormat ]. form := Form extent: (bbx at: 1) @ (bbx at: 2). bits := form bits. pos := 0. 1 to: (bbx at: 2) do: [ :t | 1 to: ((bbx at: 1) - 1) // 8 + 1 do: [ :i | hi := ('0123456789ABCDEF' indexOf: file next asUppercase) - 1 bitShift: 4. low := ('0123456789ABCDEF' indexOf: file next asUppercase) - 1. bits byteAt: pos + i put: hi + low ]. file next ~= Character cr ifTrue: [ self errorFileFormat ]. pos := pos + (((bbx at: 1) // 32 + 1) * 4) ]. (self getLine beginsWith: 'ENDCHAR') ifFalse: [ self errorFileFormat ]. encoding < 0 ifTrue: [ ^ { nil. nil. nil } ]. ^ { form. encoding. bbx }! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! BDFFontReader class instanceVariableNames: ''! !BDFFontReader class methodsFor: 'documentation' stamp: 'nop 2/11/2001 00:22'! gettingAndInstallingTheFonts "Download the 1.3M of BDF font source files from x.org: BDFFontReader downloadFonts. Convert them to .sf2 StrikeFont files: BDFFontReader convertX11FontsToStrike2. Install them into the system as TextStyles: BDFFontReader installX11Fonts. Read the legal notices in 'BDFFontReader x11FontLegalNotices' before redistributing images containing these fonts."! ! !BDFFontReader class methodsFor: 'documentation' stamp: 'nop 1/23/2000 18:30'! x11FontLegalNotices ^ 'The X11 BDF fonts contain copyright and license information as comments in the font source code. For the font family files "cour" (Courier), "helv" (Helvetica), "ncen" (New Century Schoolbook), and "tim" (Times Roman) the notice reads: COMMENT Copyright 1984-1989, 1994 Adobe Systems Incorporated. COMMENT Copyright 1988, 1994 Digital Equipment Corporation. COMMENT COMMENT Adobe is a trademark of Adobe Systems Incorporated which may be COMMENT registered in certain jurisdictions. COMMENT Permission to use these trademarks is hereby granted only in COMMENT association with the images described in this file. COMMENT COMMENT Permission to use, copy, modify, distribute and sell this software COMMENT and its documentation for any purpose and without fee is hereby COMMENT granted, provided that the above copyright notices appear in all COMMENT copies and that both those copyright notices and this permission COMMENT notice appear in supporting documentation, and that the names of COMMENT Adobe Systems and Digital Equipment Corporation not be used in COMMENT advertising or publicity pertaining to distribution of the software COMMENT without specific, written prior permission. Adobe Systems and COMMENT Digital Equipment Corporation make no representations about the COMMENT suitability of this software for any purpose. It is provided "as COMMENT is" without express or implied warranty. For the font family files "char" (Charter), the notice reads: COMMENT Copyright 1988 Bitstream, Inc., Cambridge, Massachusetts, USA COMMENT Bitstream and Charter are registered trademarks of Bitstream, Inc. COMMENT COMMENT The names "Bitstream" and "Charter" are registered trademarks of COMMENT Bitstream, Inc. Permission to use these trademarks is hereby COMMENT granted only in association with the images described in this file. COMMENT COMMENT Permission to use, copy, modify, and distribute this software and COMMENT its documentation for any purpose and without fee is hereby COMMENT granted, provided that the above copyright notice appear in all COMMENT copies and that both that copyright notice and this permission COMMENT notice appear in supporting documentation, and that the name of COMMENT Bitstream not be used in advertising or publicity pertaining to COMMENT distribution of the software without specific, written prior COMMENT permission. Bitstream makes no representations about the COMMENT suitability of this software for any purpose. It is provided "as COMMENT is" without express or implied warranty. COMMENT COMMENT BITSTREAM DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, COMMENT INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN COMMENT NO EVENT SHALL BITSTREAM BE LIABLE FOR ANY SPECIAL, INDIRECT OR COMMENT CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS COMMENT OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, COMMENT NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN COMMENT CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. For the font family files "lu" (Lucida), "lub" (Lucida Bright), and "lut" (Lucida Typewriter), the notice reads: COMMENT (c) Copyright Bigelow & Holmes 1986, 1985. Lucida is a registered COMMENT trademark of Bigelow & Holmes. See LEGAL NOTICE file for terms COMMENT of the license. The LEGAL NOTICE contains: This is the LEGAL NOTICE pertaining to the Lucida fonts from Bigelow & Holmes: NOTICE TO USER: The source code, including the glyphs or icons forming a par of the OPEN LOOK TM Graphic User Interface, on this tape and in these files is copyrighted under U.S. and international laws. Sun Microsystems, Inc. of Mountain View, California owns the copyright and has design patents pending on many of the icons. AT&T is the owner of the OPEN LOOK trademark associated with the materials on this tape. Users and possessors of this source code are hereby granted a nonexclusive, royalty-free copyright and design patent license to use this code in individual and commercial software. A royalty-free, nonexclusive trademark license to refer to the code and output as "OPEN LOOK" compatible is available from AT&T if, and only if, the appearance of the icons or glyphs is not changed in any manner except as absolutely necessary to accommodate the standard resolution of the screen or other output device, the code and output is not changed except as authorized herein, and the code and output is validated by AT&T. Bigelow & Holmes is the owner of the Lucida (R) trademark for the fonts and bit-mapped images associated with the materials on this tape. Users are granted a royalty-free, nonexclusive license to use the trademark only to identify the fonts and bit-mapped images if, and only if, the fonts and bit-mapped images are not modified in any way by the user. Any use of this source code must include, in the user documentation and internal comments to the code, notices to the end user as follows: (c) Copyright 1989 Sun Microsystems, Inc. Sun design patents pending in the U.S. and foreign countries. OPEN LOOK is a trademark of AT&T. Used by written permission of the owners. (c) Copyright Bigelow & Holmes 1986, 1985. Lucida is a registered trademark of Bigelow & Holmes. Permission to use the Lucida trademark is hereby granted only in association with the images and fonts described in this file. SUN MICROSYSTEMS, INC., AT&T, AND BIGELOW & HOLMES MAKE NO REPRESENTATIONS ABOUT THE SUITABILITY OF THIS SOURCE CODE FOR ANY PURPOSE. IT IS PROVIDED "AS IS" WITHOUT EXPRESS OR IMPLIED WARRANTY OF ANY KIND. SUN MICROSYSTEMS, INC., AT&T AND BIGELOW & HOLMES, SEVERALLY AND INDIVIDUALLY, DISCLAIM ALL WARRANTIES WITH REGARD TO THIS SOURCE CODE, INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. IN NO EVENT SHALL SUN MICROSYSTEMS, INC., AT&T OR BIGELOW & HOLMES BE LIABLE FOR ANY SPECIAL, INDIRECT, INCIDENTAL, OR CONSEQUENTIAL DAMAGES, OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOURCE CODE. '. ! ! !BDFFontReader class methodsFor: 'file creation' stamp: 'nice 4/16/2009 10:04'! convertFilesNamed: fileName toFamilyNamed: familyName inDirectoryNamed: dirName "BDFFontReader convertFilesNamed: 'helvR' toFamilyNamed: 'Helvetica' inDirectoryNamed: '' " "This utility converts X11 BDF font files to Squeak .sf2 StrikeFont files." "For this utility to work as is, the BDF files must be named 'familyNN.bdf', and must reside in the directory named by dirName (use '' for the current directory). The output StrikeFont files will be named familyNN.sf2, and will be placed in the current directory." "Check for matching file names." | allFontNames dir | dir := dirName isEmpty ifTrue: [ FileDirectory default ] ifFalse: [ FileDirectory default directoryNamed: dirName ]. allFontNames := dir fileNamesMatching: fileName , '##.bdf'. allFontNames isEmpty ifTrue: [ ^ self error: 'No files found like ' , fileName , 'NN.bdf' ]. UIManager default informUserDuring: [ :info | allFontNames do: [ :fname | | sizeChars f | info value: 'Converting ' , familyName , ' BDF file ' , fname , ' to SF2 format'. sizeChars := (fname copyFrom: fileName size + 1 to: fname size) copyUpTo: $.. f := StrikeFont new readBDFFromFile: (dir fullNameFor: fname) name: familyName , sizeChars. f writeAsStrike2named: familyName , sizeChars , '.sf2' ] ]! ! !BDFFontReader class methodsFor: 'file creation' stamp: 'yo 5/25/2004 10:52'! new ^ self basicNew. ! ! !BDFFontReader class methodsFor: 'file creation' stamp: 'ar 10/25/2005 00:21'! openFileNamed: fileName ^self new openFileNamed: fileName! ! !BDFFontReader class methodsFor: 'resource download' stamp: 'nop 1/23/2000 18:43'! convertX11FontsToStrike2 "BDFFontReader convertX11FontsToStrike2" "Given a set of standard X11 BDF font files (probably downloaded via BDFFontReader downloadFonts), produce .sf2 format fonts. The source and destination directory is the current directory." "Charter currently tickles a bug in the BDF parser. Skip it for now." "self convertFilesNamed: 'charR' toFamilyNamed: 'Charter' inDirectoryNamed: ''." self convertFilesNamed: 'courR' toFamilyNamed: 'Courier' inDirectoryNamed: ''. self convertFilesNamed: 'helvR' toFamilyNamed: 'Helvetica' inDirectoryNamed: ''. self convertFilesNamed: 'lubR' toFamilyNamed: 'LucidaBright' inDirectoryNamed: ''. self convertFilesNamed: 'luRS' toFamilyNamed: 'Lucida' inDirectoryNamed: ''. self convertFilesNamed: 'lutRS' toFamilyNamed: 'LucidaTypewriter' inDirectoryNamed: ''. self convertFilesNamed: 'ncenR' toFamilyNamed: 'NewCenturySchoolbook' inDirectoryNamed: ''. self convertFilesNamed: 'timR' toFamilyNamed: 'TimesRoman' inDirectoryNamed: ''.! ! !BDFFontReader class methodsFor: 'resource download' stamp: 'pmm 7/4/2009 12:07'! downloadFonts "BDFFontReader downloadFonts" "Download a standard set of BDF sources from x.org. The combined size of these source files is around 1.2M; after conversion to .sf2 format they may be deleted." | heads tails filenames baseUrl basePath | heads := #( 'charR' 'courR' 'helvR' 'lubR' 'luRS' 'lutRS' 'ncenR' 'timR' ). tails := #('08' '10' '12' '14' '18' '24' ). filenames := OrderedCollection new. heads do: [ :head | filenames addAll: (tails collect: [ :tail | head , tail , '.bdf' ]) ]. baseUrl := Url absoluteFromText: 'http://ftp.x.org/pub/R6.4/xc/fonts/bdf/75dpi/'. basePath := baseUrl path. filenames do: [ :filename | | newUrl newPath document f | newUrl := baseUrl clone. newPath := OrderedCollection newFrom: basePath. newPath addLast: filename. newUrl path: newPath. UIManager default informUser: 'Fetching ' translated, filename during: [ document := newUrl retrieveContents ]. f := (MultiByteFileStream newFileNamed: filename) ascii; wantsLineEndConversion: true; yourself. f nextPutAll: document content. f close ]! ! !BDFFontReader class methodsFor: 'resource download' stamp: 'eem 6/11/2008 13:33'! installX11Fonts "BDFFontReader installX11Fonts" "Installs previously-converted .sf2 fonts into the TextConstants dictionary. This makes them available as TextStyles everywhere in the image." | families | families := #( 'Courier' 'Helvetica' 'LucidaBright' 'Lucida' 'LucidaTypewriter' 'NewCenturySchoolbook' 'TimesRoman' ). families do: [:family | | fontArray textStyle | fontArray := StrikeFont readStrikeFont2Family: family. textStyle := TextStyle fontArray: fontArray. TextConstants at: family asSymbol put: textStyle. ]. ! ! ImageReadWriter subclass: #BMPReadWriter instanceVariableNames: 'bfType bfSize bfOffBits biSize biWidth biHeight biPlanes biBitCount biCompression biSizeImage biXPelsPerMeter biYPelsPerMeter biClrUsed biClrImportant' classVariableNames: '' poolDictionaries: '' category: 'Graphics-Files'! !BMPReadWriter methodsFor: 'reading' stamp: 'ar 6/16/2002 15:36'! nextImage | colors | stream binary. self readHeader. biBitCount = 24 ifTrue:[^self read24BmpFile]. "read the color map" colors := self readColorMap. ^self readIndexedBmpFile: colors! ! !BMPReadWriter methodsFor: 'reading' stamp: 'lr 7/4/2009 10:42'! read24BmpFile "Read 24-bit pixel data from the given a BMP stream." | form formBits pixelLine bitsIndex bitBlt | form := Form extent: biWidth @ biHeight depth: 32. pixelLine := ByteArray new: (24 * biWidth + 31) // 32 * 4. bitsIndex := (form height - 1) * biWidth + 1. formBits := form bits. 1 to: biHeight do: [ :i | pixelLine := stream nextInto: pixelLine. self read24BmpLine: pixelLine into: formBits startingAt: bitsIndex width: biWidth. bitsIndex := bitsIndex - biWidth ]. bitBlt := BitBlt toForm: form. bitBlt combinationRule: 7. "bitOr:with:" bitBlt halftoneForm: (Bitmap with: 4278190080). bitBlt copyBits. ^ form! ! !BMPReadWriter methodsFor: 'reading' stamp: 'lr 7/4/2009 10:42'! read24BmpLine: pixelLine into: formBits startingAt: formBitsIndex width: width | pixIndex rgb bitsIndex | pixIndex := 0. "pre-increment" bitsIndex := formBitsIndex - 1. "pre-increment" 1 to: width do: [ :j | rgb := (pixelLine at: (pixIndex := pixIndex + 1)) + ((pixelLine at: (pixIndex := pixIndex + 1)) bitShift: 8) + ((pixelLine at: (pixIndex := pixIndex + 1)) bitShift: 16). formBits at: (bitsIndex := bitsIndex + 1) put: rgb ]! ! !BMPReadWriter methodsFor: 'reading' stamp: 'damiencassou 5/30/2008 14:51'! readColorMap "Read colorCount BMP color map entries from the given binary stream. Answer an array of Colors." | colorCount colors maxLevel b g r ccStream | colorCount := (bfOffBits - 54) // 4. "Note: some programs (e.g. Photoshop 4.0) apparently do not set colorCount; assume that any data between the end of the header and the start of the pixel data is the color map" biBitCount >= 16 ifTrue: [ ^ nil ]. colorCount = 0 ifTrue: [ "this BMP file does not have a color map" "default monochrome color map" biBitCount = 1 ifTrue: [ ^ Array with: Color white with: Color black ]. "default gray-scale color map" maxLevel := (2 raisedTo: biBitCount) - 1. ^ (0 to: maxLevel) collect: [ :level | Color gray: level asFloat / maxLevel ] ]. ccStream := (stream next: colorCount * 4) readStream. colors := Array new: colorCount. 1 to: colorCount do: [ :i | b := ccStream next. g := ccStream next. r := ccStream next. ccStream next. "skip reserved" colors at: i put: (Color r: r g: g b: b range: 255) ]. ^ colors! ! !BMPReadWriter methodsFor: 'reading' stamp: 'lr 7/4/2009 10:42'! readHeader | reserved | bfType := stream nextLittleEndianNumber: 2. bfSize := stream nextLittleEndianNumber: 4. reserved := stream nextLittleEndianNumber: 4. bfOffBits := stream nextLittleEndianNumber: 4. biSize := stream nextLittleEndianNumber: 4. biWidth := stream nextLittleEndianNumber: 4. biHeight := stream nextLittleEndianNumber: 4. biPlanes := stream nextLittleEndianNumber: 2. biBitCount := stream nextLittleEndianNumber: 2. biCompression := stream nextLittleEndianNumber: 4. biSizeImage := stream nextLittleEndianNumber: 4. biXPelsPerMeter := stream nextLittleEndianNumber: 4. biYPelsPerMeter := stream nextLittleEndianNumber: 4. biClrUsed := stream nextLittleEndianNumber: 4. biClrImportant := stream nextLittleEndianNumber: 4! ! !BMPReadWriter methodsFor: 'reading' stamp: 'lr 7/4/2009 10:42'! readIndexedBmpFile: colors "Read uncompressed pixel data of depth d from the given BMP stream, where d is 1, 4, 8, or 16" | form bytesPerRow pixelData pixelLine startIndex map bitBlt mask | colors ifNil: [ form := Form extent: biWidth @ biHeight depth: biBitCount ] ifNotNil: [ form := ColorForm extent: biWidth @ biHeight depth: biBitCount. form colors: colors ]. bytesPerRow := (biBitCount * biWidth + 31) // 32 * 4. pixelData := ByteArray new: bytesPerRow * biHeight. biHeight to: 1 by: -1 do: [ :y | pixelLine := stream next: bytesPerRow. startIndex := (y - 1) * bytesPerRow + 1. pixelData replaceFrom: startIndex to: startIndex + bytesPerRow - 1 with: pixelLine startingAt: 1 ]. form bits copyFromByteArray: pixelData. biBitCount = 16 ifTrue: [ map := ColorMap shifts: #(8 -8 0 0 ) masks: #(255 65280 0 0 ). mask := 2147516416 ]. biBitCount = 32 ifTrue: [ map := ColorMap shifts: #(24 8 -8 -24 ) masks: #(255 65280 16711680 4278190080 ). mask := 4278190080 ]. map ifNotNil: [ bitBlt := BitBlt toForm: form. bitBlt sourceForm: form. bitBlt colorMap: map. bitBlt combinationRule: Form over. bitBlt copyBits ]. mask ifNotNil: [ bitBlt := BitBlt toForm: form. bitBlt combinationRule: 7. "bitOr:with:" bitBlt halftoneForm: (Bitmap with: mask). bitBlt copyBits ]. ^ form! ! !BMPReadWriter methodsFor: 'testing' stamp: 'ar 6/16/2002 15:27'! understandsImageFormat stream size < 54 ifTrue:[^false]. "min size = BITMAPFILEHEADER+BITMAPINFOHEADER" self readHeader. bfType = 19778 "BM" ifFalse:[^false]. biSize = 40 ifFalse:[^false]. biPlanes = 1 ifFalse:[^false]. bfSize <= stream size ifFalse:[^false]. biCompression = 0 ifFalse:[^false]. ^true! ! !BMPReadWriter methodsFor: 'writing' stamp: 'lr 7/4/2009 10:42'! nextPutImage: aForm | bhSize rowBytes rgb data colorValues depth image ppw scanLineLen | depth := aForm depth. [ #(1 4 8 32 ) includes: depth ] whileFalse: [ depth := depth + 1 asLargerPowerOfTwo ]. image := aForm asFormOfDepth: depth. image unhibernate. bhSize := 14. "# bytes in file header" biSize := 40. "info header size in bytes" biWidth := image width. biHeight := image height. biClrUsed := depth = 32 ifTrue: [ 0 ] ifFalse: [ 1 << depth ]. "No. color table entries" bfOffBits := biSize + bhSize + (4 * biClrUsed). rowBytes := ((depth min: 24) * biWidth + 31) // 32 * 4. biSizeImage := biHeight * rowBytes. "Write the file header" stream position: 0. stream nextLittleEndianNumber: 2 put: 19778. "bfType = BM" stream nextLittleEndianNumber: 4 put: bfOffBits + biSizeImage. "Entire file size in bytes" stream nextLittleEndianNumber: 4 put: 0. "bfReserved" stream nextLittleEndianNumber: 4 put: bfOffBits. "Offset of bitmap data from start of hdr (and file)" "Write the bitmap info header" stream position: bhSize. stream nextLittleEndianNumber: 4 put: biSize. "info header size in bytes" stream nextLittleEndianNumber: 4 put: image width. "biWidth" stream nextLittleEndianNumber: 4 put: image height. "biHeight" stream nextLittleEndianNumber: 2 put: 1. "biPlanes" stream nextLittleEndianNumber: 2 put: (depth min: 24). "biBitCount" stream nextLittleEndianNumber: 4 put: 0. "biCompression" stream nextLittleEndianNumber: 4 put: biSizeImage. "size of image section in bytes" stream nextLittleEndianNumber: 4 put: 2800. "biXPelsPerMeter" stream nextLittleEndianNumber: 4 put: 2800. "biYPelsPerMeter" stream nextLittleEndianNumber: 4 put: biClrUsed. stream nextLittleEndianNumber: 4 put: 0. "biClrImportant" biClrUsed > 0 ifTrue: [ "write color map; this works for ColorForms, too" colorValues := image colormapIfNeededForDepth: 32. 1 to: biClrUsed do: [ :i | rgb := colorValues at: i. 0 to: 24 by: 8 do: [ :j | stream nextPut: (rgb >> j bitAnd: 255) ] ] ]. depth < 32 ifTrue: [ "depth = 1, 4 or 8." data := image bits asByteArray. ppw := 32 // depth. scanLineLen := (biWidth + ppw - 1) // ppw * 4. "# of bytes in line" 1 to: biHeight do: [ :i | stream next: scanLineLen putAll: data startingAt: (biHeight - i) * scanLineLen + 1 ] ] ifFalse: [ 1 to: biHeight do: [ :i | data := (image copy: (0 @ (biHeight - i) extent: biWidth @ 1)) bits. 1 to: data size do: [ :j | stream nextLittleEndianNumber: 3 put: (data at: j) ]. 1 to: (data size * 3 + 3) // 4 * 4 - (data size * 3) do: [ :j | stream nextPut: 0 "pad to 32-bits" ] ] ]. stream position = (bfOffBits + biSizeImage) ifFalse: [ self error: 'Write failure' ]. stream close! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! BMPReadWriter class instanceVariableNames: ''! !BMPReadWriter class methodsFor: 'image reading/writing' stamp: 'nk 7/16/2003 17:56'! typicalFileExtensions "Answer a collection of file extensions (lowercase) which files that I can read might commonly have" ^#('bmp')! ! !BMPReadWriter class methodsFor: 'testing' stamp: 'ar 6/16/2002 18:55'! displayAllFrom: fd "BMPReadWriter displayAllFrom: FileDirectory default" fd fileNames do:[:fName| (fName endsWith: '.bmp') ifTrue:[ [(Form fromBinaryStream: (fd readOnlyFileNamed: fName)) display. Display forceDisplayUpdate] on: Error do:[:nix|]. ]. ]. fd directoryNames do:[:fdName| self displayAllFrom: (fd directoryNamed: fdName) ].! ! !BMPReadWriter class methodsFor: 'testing' stamp: 'ar 6/16/2002 18:56'! readAllFrom: fd "MessageTally spyOn:[BMPReadWriter readAllFrom: FileDirectory default]" fd fileNames do:[:fName| (fName endsWith: '.bmp') ifTrue:[ [Form fromBinaryStream: (fd readOnlyFileNamed: fName)] on: Error do:[:nix]. ]. ]. fd directoryNames do:[:fdName| self readAllFrom: (fd directoryNamed: fdName) ].! ! TestCase subclass: #BMPReadWriterTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'GraphicsTests-Files'! !BMPReadWriterTest methodsFor: 'data' stamp: 'ar 10/25/2005 02:22'! bmpData16bit "Created via: (Base64MimeConverter mimeEncode: (FileStream readOnlyFileNamed: 'bmptest16b.bmp') binary) contents " ^(Base64MimeConverter mimeDecodeToBytes: 'Qk24AAAAAAAAADYAAAAoAAAACAAAAAgAAAABABAAAAAAAIIAAADDDgAAww4AAAAAAAAAAAAA 4APgA+AD4AMfAB8AHwAfAOAD4APgA+ADHwAfAB8AHwDgA+AD/3//f/9//38fAB8A4APgA/9/ /3//f/9/HwAfAAAAAAD/f/9//3//fwB8AHwAAAAA/3//f/9//38AfAB8AAAAAAAAAAAAfAB8 AHwAfAAAAAAAAAAAAHwAfAB8AHwAAA==' readStream) contents! ! !BMPReadWriterTest methodsFor: 'data' stamp: 'ar 10/24/2005 21:27'! bmpData24bit "Created via: (Base64MimeConverter mimeEncode: (FileStream readOnlyFileNamed: 'bmptest24.bmp') binary) contents " ^(Base64MimeConverter mimeDecodeToBytes: 'Qk32AAAAAAAAADYAAAAoAAAACAAAAAgAAAABABgAAAAAAAAAAADEDgAAxA4AAAAAAAAAAAAA AP8AAP8AAP8AAP8A/wAA/wAA/wAA/wAAAP8AAP8AAP8AAP8A/wAA/wAA/wAA/wAAAP8AAP8A /////////////////wAA/wAAAP8AAP8A/////////////////wAA/wAAAAAAAAAA//////// ////////AAD/AAD/AAAAAAAA////////////////AAD/AAD/AAAAAAAAAAAAAAAAAAD/AAD/ AAD/AAD/AAAAAAAAAAAAAAAAAAD/AAD/AAD/AAD/' readStream) contents! ! !BMPReadWriterTest methodsFor: 'data' stamp: 'ar 10/25/2005 02:22'! bmpData32bit "Created via: (Base64MimeConverter mimeEncode: (FileStream readOnlyFileNamed: 'bmptest32b.bmp') binary) contents " ^(Base64MimeConverter mimeDecodeToBytes: 'Qk04AQAAAAAAADYAAAAoAAAACAAAAAgAAAABACAAAAAAAAIBAADDDgAAww4AAAAAAAAAAAAA AP8AAAD/AAAA/wAAAP8AAP8AAAD/AAAA/wAAAP8AAAAA/wAAAP8AAAD/AAAA/wAA/wAAAP8A AAD/AAAA/wAAAAD/AAAA/wAA////AP///wD///8A////AP8AAAD/AAAAAP8AAAD/AAD///8A ////AP///wD///8A/wAAAP8AAAAAAAAAAAAAAP///wD///8A////AP///wAAAP8AAAD/AAAA AAAAAAAA////AP///wD///8A////AAAA/wAAAP8AAAAAAAAAAAAAAAAAAAAAAAAA/wAAAP8A AAD/AAAA/wAAAAAAAAAAAAAAAAAAAAAAAAD/AAAA/wAAAP8AAAD/AAAA' readStream) contents! ! !BMPReadWriterTest methodsFor: 'data' stamp: 'ar 10/24/2005 21:41'! bmpData4bit "Created via: (Base64MimeConverter mimeEncode: (FileStream readOnlyFileNamed: 'bmptest4.bmp') binary) contents " ^(Base64MimeConverter mimeDecodeToBytes: 'Qk12BAAAAAAAADYEAAAoAAAACAAAAAgAAAABAAgAAAAAAEAAAADEDgAAxA4AAAAAAAAAAAAA AAAAAAAAgAAAgAAAAICAAIAAAACAAIAAgIAAAMDAwADA3MAA8MqmAAAgQAAAIGAAACCAAAAg oAAAIMAAACDgAABAAAAAQCAAAEBAAABAYAAAQIAAAECgAABAwAAAQOAAAGAAAABgIAAAYEAA AGBgAABggAAAYKAAAGDAAABg4AAAgAAAAIAgAACAQAAAgGAAAICAAACAoAAAgMAAAIDgAACg AAAAoCAAAKBAAACgYAAAoIAAAKCgAACgwAAAoOAAAMAAAADAIAAAwEAAAMBgAADAgAAAwKAA AMDAAADA4AAA4AAAAOAgAADgQAAA4GAAAOCAAADgoAAA4MAAAODgAEAAAABAACAAQABAAEAA YABAAIAAQACgAEAAwABAAOAAQCAAAEAgIABAIEAAQCBgAEAggABAIKAAQCDAAEAg4ABAQAAA QEAgAEBAQABAQGAAQECAAEBAoABAQMAAQEDgAEBgAABAYCAAQGBAAEBgYABAYIAAQGCgAEBg wABAYOAAQIAAAECAIABAgEAAQIBgAECAgABAgKAAQIDAAECA4ABAoAAAQKAgAECgQABAoGAA QKCAAECgoABAoMAAQKDgAEDAAABAwCAAQMBAAEDAYABAwIAAQMCgAEDAwABAwOAAQOAAAEDg IABA4EAAQOBgAEDggABA4KAAQODAAEDg4ACAAAAAgAAgAIAAQACAAGAAgACAAIAAoACAAMAA gADgAIAgAACAICAAgCBAAIAgYACAIIAAgCCgAIAgwACAIOAAgEAAAIBAIACAQEAAgEBgAIBA gACAQKAAgEDAAIBA4ACAYAAAgGAgAIBgQACAYGAAgGCAAIBgoACAYMAAgGDgAICAAACAgCAA gIBAAICAYACAgIAAgICgAICAwACAgOAAgKAAAICgIACAoEAAgKBgAICggACAoKAAgKDAAICg 4ACAwAAAgMAgAIDAQACAwGAAgMCAAIDAoACAwMAAgMDgAIDgAACA4CAAgOBAAIDgYACA4IAA gOCgAIDgwACA4OAAwAAAAMAAIADAAEAAwABgAMAAgADAAKAAwADAAMAA4ADAIAAAwCAgAMAg QADAIGAAwCCAAMAgoADAIMAAwCDgAMBAAADAQCAAwEBAAMBAYADAQIAAwECgAMBAwADAQOAA wGAAAMBgIADAYEAAwGBgAMBggADAYKAAwGDAAMBg4ADAgAAAwIAgAMCAQADAgGAAwICAAMCA oADAgMAAwIDgAMCgAADAoCAAwKBAAMCgYADAoIAAwKCgAMCgwADAoOAAwMAAAMDAIADAwEAA wMBgAMDAgADAwKAA8Pv/AKSgoACAgIAAAAD/AAD/AAAA//8A/wAAAP8A/wD//wAA////APr6 +vr8/Pz8+vr6+vz8/Pz6+v/////8/Pr6//////z8AAD/////+fkAAP/////5+QAAAAD5+fn5 AAAAAPn5+fk=' readStream) contents! ! !BMPReadWriterTest methodsFor: 'data' stamp: 'ar 10/24/2005 21:27'! bmpData8bit "Created via: (Base64MimeConverter mimeEncode: (FileStream readOnlyFileNamed: 'bmptest8.bmp') binary) contents " ^(Base64MimeConverter mimeDecodeToBytes: 'Qk12BAAAAAAAADYEAAAoAAAACAAAAAgAAAABAAgAAAAAAEAAAADEDgAAxA4AAAAAAAAAAAAA AAAAAAAAgAAAgAAAAICAAIAAAACAAIAAgIAAAMDAwADA3MAA8MqmAAAgQAAAIGAAACCAAAAg oAAAIMAAACDgAABAAAAAQCAAAEBAAABAYAAAQIAAAECgAABAwAAAQOAAAGAAAABgIAAAYEAA AGBgAABggAAAYKAAAGDAAABg4AAAgAAAAIAgAACAQAAAgGAAAICAAACAoAAAgMAAAIDgAACg AAAAoCAAAKBAAACgYAAAoIAAAKCgAACgwAAAoOAAAMAAAADAIAAAwEAAAMBgAADAgAAAwKAA AMDAAADA4AAA4AAAAOAgAADgQAAA4GAAAOCAAADgoAAA4MAAAODgAEAAAABAACAAQABAAEAA YABAAIAAQACgAEAAwABAAOAAQCAAAEAgIABAIEAAQCBgAEAggABAIKAAQCDAAEAg4ABAQAAA QEAgAEBAQABAQGAAQECAAEBAoABAQMAAQEDgAEBgAABAYCAAQGBAAEBgYABAYIAAQGCgAEBg wABAYOAAQIAAAECAIABAgEAAQIBgAECAgABAgKAAQIDAAECA4ABAoAAAQKAgAECgQABAoGAA QKCAAECgoABAoMAAQKDgAEDAAABAwCAAQMBAAEDAYABAwIAAQMCgAEDAwABAwOAAQOAAAEDg IABA4EAAQOBgAEDggABA4KAAQODAAEDg4ACAAAAAgAAgAIAAQACAAGAAgACAAIAAoACAAMAA gADgAIAgAACAICAAgCBAAIAgYACAIIAAgCCgAIAgwACAIOAAgEAAAIBAIACAQEAAgEBgAIBA gACAQKAAgEDAAIBA4ACAYAAAgGAgAIBgQACAYGAAgGCAAIBgoACAYMAAgGDgAICAAACAgCAA gIBAAICAYACAgIAAgICgAICAwACAgOAAgKAAAICgIACAoEAAgKBgAICggACAoKAAgKDAAICg 4ACAwAAAgMAgAIDAQACAwGAAgMCAAIDAoACAwMAAgMDgAIDgAACA4CAAgOBAAIDgYACA4IAA gOCgAIDgwACA4OAAwAAAAMAAIADAAEAAwABgAMAAgADAAKAAwADAAMAA4ADAIAAAwCAgAMAg QADAIGAAwCCAAMAgoADAIMAAwCDgAMBAAADAQCAAwEBAAMBAYADAQIAAwECgAMBAwADAQOAA wGAAAMBgIADAYEAAwGBgAMBggADAYKAAwGDAAMBg4ADAgAAAwIAgAMCAQADAgGAAwICAAMCA oADAgMAAwIDgAMCgAADAoCAAwKBAAMCgYADAoIAAwKCgAMCgwADAoOAAwMAAAMDAIADAwEAA wMBgAMDAgADAwKAA8Pv/AKSgoACAgIAAAAD/AAD/AAAA//8A/wAAAP8A/wD//wAA////APr6 +vr8/Pz8+vr6+vz8/Pz6+v/////8/Pr6//////z8AAD/////+fkAAP/////5+QAAAAD5+fn5 AAAAAPn5+fk=' readStream) contents! ! !BMPReadWriterTest methodsFor: 'data' stamp: 'ar 10/25/2005 14:04'! bmpDataR5G6B5 "This is a BMP file based on BitmapV4Header which is currently unsupported." "Created via: (Base64MimeConverter mimeEncode: (FileStream readOnlyFileNamed: 'bmptest16-R5G6B5.bmp') binary) contents " ^(Base64MimeConverter mimeDecodeToBytes: 'Qk3IAAAAAAAAAEYAAAA4AAAACAAAAAgAAAABABAAAwAAAIIAAADDDgAAww4AAAAAAAAAAAAA APgAAOAHAAAfAAAAAAAAAOAH4AfgB+AHHwAfAB8AHwDgB+AH4AfgBx8AHwAfAB8A4AfgB/// ////////HwAfAOAH4Af//////////x8AHwAAAAAA//////////8A+AD4AAAAAP////////// APgA+AAAAAAAAAAAAPgA+AD4APgAAAAAAAAAAAD4APgA+AD4AAA=' readStream) contents! ! !BMPReadWriterTest methodsFor: 'data' stamp: 'ar 10/25/2005 14:04'! bmpDataX4R4G4B4 "This is a BMP file based on BitmapV4Header which is currently unsupported." "Created via: (Base64MimeConverter mimeEncode: (FileStream readOnlyFileNamed: 'bmptest16-X4R4G4B4.bmp') binary) contents " ^(Base64MimeConverter mimeDecodeToBytes: 'Qk3IAAAAAAAAAEYAAAA4AAAACAAAAAgAAAABABAAAwAAAIIAAADDDgAAww4AAAAAAAAAAAAA AA8AAPAAAAAPAAAAAAAAAPAA8ADwAPAADwAPAA8ADwDwAPAA8ADwAA8ADwAPAA8A8ADwAP8P /w//D/8PDwAPAPAA8AD/D/8P/w//Dw8ADwAAAAAA/w//D/8P/w8ADwAPAAAAAP8P/w//D/8P AA8ADwAAAAAAAAAAAA8ADwAPAA8AAAAAAAAAAAAPAA8ADwAPAAA=' readStream) contents! ! !BMPReadWriterTest methodsFor: 'data' stamp: 'ar 10/25/2005 14:05'! bmpDataX8R8G8B8 "This is a BMP file based on BitmapV4Header which is currently unsupported." "Created via: (Base64MimeConverter mimeEncode: (FileStream readOnlyFileNamed: 'bmptest32-X8R8G8B8.bmp') binary) contents " ^(Base64MimeConverter mimeDecodeToBytes: 'Qk1IAQAAAAAAAEYAAAA4AAAACAAAAAgAAAABACAAAwAAAAIBAADDDgAAww4AAAAAAAAAAAAA AAAA/wAA/wAA/wAAAAAAAAAA/wAAAP8AAAD/AAAA/wAA/wAAAP8AAAD/AAAA/wAAAAD/AAAA /wAAAP8AAAD/AAD/AAAA/wAAAP8AAAD/AAAAAP8AAAD/AAD///8A////AP///wD///8A/wAA AP8AAAAA/wAAAP8AAP///wD///8A////AP///wD/AAAA/wAAAAAAAAAAAAAA////AP///wD/ //8A////AAAA/wAAAP8AAAAAAAAAAAD///8A////AP///wD///8AAAD/AAAA/wAAAAAAAAAA AAAAAAAAAAAAAAD/AAAA/wAAAP8AAAD/AAAAAAAAAAAAAAAAAAAAAAAAAP8AAAD/AAAA/wAA AP8AAA==' readStream) contents! ! !BMPReadWriterTest methodsFor: 'reading' stamp: 'damiencassou 5/30/2008 14:57'! testBmp16Bit | reader form | reader := BMPReadWriter new on: self bmpData16bit readStream. form := reader nextImage. "special black here to compensate for zero-is-transparent effect" self assert: (form colorAt: 7 @ 1) = Color red. self assert: (form colorAt: 1 @ 7) = Color green. self assert: (form colorAt: 7 @ 7) = Color blue. self assert: (form colorAt: 4 @ 4) = Color white. self assert: (form pixelValueAt: 1 @ 1) = 32768! ! !BMPReadWriterTest methodsFor: 'reading' stamp: 'damiencassou 5/30/2008 14:57'! testBmp24Bit | reader form | reader := BMPReadWriter new on: self bmpData24bit readStream. form := reader nextImage. self assert: (form colorAt: 7 @ 1) = Color red. self assert: (form colorAt: 1 @ 7) = Color green. self assert: (form colorAt: 7 @ 7) = Color blue. self assert: (form colorAt: 4 @ 4) = Color white. self assert: (form pixelValueAt: 1 @ 1) = 4278190080! ! !BMPReadWriterTest methodsFor: 'reading' stamp: 'damiencassou 5/30/2008 14:57'! testBmp32Bit | reader form | reader := BMPReadWriter new on: self bmpData32bit readStream. form := reader nextImage. self assert: (form colorAt: 7 @ 1) = Color red. self assert: (form colorAt: 1 @ 7) = Color green. self assert: (form colorAt: 7 @ 7) = Color blue. self assert: (form colorAt: 4 @ 4) = Color white. self assert: (form pixelValueAt: 1 @ 1) = 4278190080! ! !BMPReadWriterTest methodsFor: 'reading' stamp: 'damiencassou 5/30/2008 14:57'! testBmp4Bit | reader form | reader := BMPReadWriter new on: self bmpData4bit readStream. form := reader nextImage. self assert: (form colorAt: 1 @ 1) = Color black. self assert: (form colorAt: 7 @ 1) = Color red. self assert: (form colorAt: 1 @ 7) = Color green. self assert: (form colorAt: 7 @ 7) = Color blue. self assert: (form colorAt: 4 @ 4) = Color white! ! !BMPReadWriterTest methodsFor: 'reading' stamp: 'damiencassou 5/30/2008 14:57'! testBmp8Bit | reader form | reader := BMPReadWriter new on: self bmpData8bit readStream. form := reader nextImage. self assert: (form colorAt: 1 @ 1) = Color black. self assert: (form colorAt: 7 @ 1) = Color red. self assert: (form colorAt: 1 @ 7) = Color green. self assert: (form colorAt: 7 @ 7) = Color blue. self assert: (form colorAt: 4 @ 4) = Color white! ! Object subclass: #BadEqualer instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'SUnit-Utilities'! !BadEqualer commentStamp: 'mjr 8/20/2003 13:28' prior: 0! I am an object that doesn't always report #= correctly. Used for testing the EqualityTester.! !BadEqualer methodsFor: 'comparing' stamp: 'mjr 8/20/2003 18:56'! = other self class = other class ifFalse: [^ false]. ^ 100 atRandom < 30 ! ! Object subclass: #BadHasher instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'SUnit-Utilities'! !BadHasher commentStamp: 'mjr 8/20/2003 13:28' prior: 0! I am an object that doesn't always hash correctly. I am used for testing the HashTester.! !BadHasher methodsFor: 'comparing' stamp: 'mjr 8/20/2003 18:56'! hash "answer with a different hash some of the time" 100 atRandom < 30 ifTrue: [^ 1]. ^ 2! ! Collection subclass: #Bag instanceVariableNames: 'contents' classVariableNames: '' poolDictionaries: '' category: 'Collections-Unordered'! !Bag commentStamp: '' prior: 0! I represent an unordered collection of possibly duplicate elements. I store these elements in a dictionary, tallying up occurrences of equal objects. Because I store an occurrence only once, my clients should beware that objects they store will not necessarily be retrieved such that == is true. If the client cares, a subclass of me should be created.! !Bag methodsFor: 'accessing' stamp: 'sma 5/12/2000 17:23'! at: index self errorNotKeyed! ! !Bag methodsFor: 'accessing' stamp: 'sma 5/12/2000 17:23'! at: index put: anObject self errorNotKeyed! ! !Bag methodsFor: 'accessing' stamp: 'tao 1/5/2000 18:25'! cumulativeCounts "Answer with a collection of cumulative percents covered by elements so far." | s n | s := self size / 100.0. n := 0. ^ self sortedCounts asArray collect: [:a | n := n + a key. (n / s roundTo: 0.1) -> a value]! ! !Bag methodsFor: 'accessing' stamp: 'sma 5/12/2000 11:35'! size "Answer how many elements the receiver contains." | tally | tally := 0. contents do: [:each | tally := tally + each]. ^ tally! ! !Bag methodsFor: 'accessing' stamp: 'sma 6/15/2000 17:00'! sortedCounts "Answer with a collection of counts with elements, sorted by decreasing count." | counts | counts := SortedCollection sortBlock: [:x :y | x >= y]. contents associationsDo: [:assn | counts add: (Association key: assn value value: assn key)]. ^ counts! ! !Bag methodsFor: 'accessing'! sortedElements "Answer with a collection of elements with counts, sorted by element." | elements | elements := SortedCollection new. contents associationsDo: [:assn | elements add: assn]. ^elements! ! !Bag methodsFor: 'accessing' stamp: 'md 1/20/2006 15:58'! valuesAndCounts ^ contents! ! !Bag methodsFor: 'adding' stamp: 'sma 5/12/2000 17:18'! add: newObject "Include newObject as one of the receiver's elements. Answer newObject." ^ self add: newObject withOccurrences: 1! ! !Bag methodsFor: 'adding' stamp: 'sma 5/12/2000 17:20'! add: newObject withOccurrences: anInteger "Add newObject anInteger times to the receiver. Answer newObject." contents at: newObject put: (contents at: newObject ifAbsent: [0]) + anInteger. ^ newObject! ! !Bag methodsFor: 'comparing' stamp: 'md 10/17/2004 16:09'! = aBag "Two bags are equal if (a) they are the same 'kind' of thing. (b) they have the same size. (c) each element occurs the same number of times in both of them" (aBag isKindOf: Bag) ifFalse: [^false]. self size = aBag size ifFalse: [^false]. contents associationsDo: [:assoc| (aBag occurrencesOf: assoc key) = assoc value ifFalse: [^false]]. ^true ! ! !Bag methodsFor: 'converting' stamp: 'sma 5/12/2000 14:34'! asBag ^ self! ! !Bag methodsFor: 'converting' stamp: 'sma 5/12/2000 14:30'! asSet "Answer a set with the elements of the receiver." ^ contents keys! ! !Bag methodsFor: 'copying' stamp: 'sma 5/12/2000 14:53'! copy ^ self shallowCopy setContents: contents copy! ! !Bag methodsFor: 'enumerating'! do: aBlock "Refer to the comment in Collection|do:." contents associationsDo: [:assoc | assoc value timesRepeat: [aBlock value: assoc key]]! ! !Bag methodsFor: 'removing' stamp: 'sma 5/12/2000 14:32'! remove: oldObject ifAbsent: exceptionBlock "Refer to the comment in Collection|remove:ifAbsent:." | count | count := contents at: oldObject ifAbsent: [^ exceptionBlock value]. count = 1 ifTrue: [contents removeKey: oldObject] ifFalse: [contents at: oldObject put: count - 1]. ^ oldObject! ! !Bag methodsFor: 'removing' stamp: 'nice 9/14/2009 20:28'! removeAll "Implementation Note: as contents will be overwritten, a shallowCopy of self would be modified. An alternative implementation preserving capacity would be to create a new contents: self setContents: (self class contentsClass new: contents size)." contents removeAll! ! !Bag methodsFor: 'testing'! includes: anObject "Refer to the comment in Collection|includes:." ^contents includesKey: anObject! ! !Bag methodsFor: 'testing'! occurrencesOf: anObject "Refer to the comment in Collection|occurrencesOf:." (self includes: anObject) ifTrue: [^contents at: anObject] ifFalse: [^0]! ! !Bag methodsFor: 'private' stamp: 'sma 5/12/2000 14:49'! setContents: aDictionary contents := aDictionary! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Bag class instanceVariableNames: ''! !Bag class methodsFor: 'instance creation' stamp: 'nk 3/17/2001 09:52'! contentsClass ^Dictionary! ! !Bag class methodsFor: 'instance creation' stamp: 'sma 5/12/2000 13:31'! new ^ self new: 4! ! !Bag class methodsFor: 'instance creation' stamp: 'nk 3/17/2001 09:52'! new: nElements ^ super new setContents: (self contentsClass new: nElements)! ! !Bag class methodsFor: 'instance creation' stamp: 'sma 5/12/2000 17:17'! newFrom: aCollection "Answer an instance of me containing the same elements as aCollection." ^ self withAll: aCollection "Examples: Bag newFrom: {1. 2. 3. 3} {1. 2. 3. 3} as: Bag "! ! CollectionRootTest subclass: #BagTest uses: TAddTest + TIncludesWithIdentityCheckTest + TCloneTest + TCopyTest + TSetArithmetic + TConvertTest + TAsStringCommaAndDelimiterTest + TRemoveForMultiplenessTest + TPrintTest + TConvertAsSortedTest + TConvertAsSetForMultiplinessTest + TConcatenationTest + TStructuralEqualityTest + TCreationWithTest - {#testOfSize} + TOccurrencesForMultiplinessTest instanceVariableNames: 'empty nonEmpty result emptyButAllocatedWith20 elementExistsTwice element collectionWithElement collectionIn collectionNotIn collectionOfString elementNotIn collectionWithCharacters otherCollectionWithoutEqualElements collectionWithoutNilMoreThan5' classVariableNames: '' poolDictionaries: '' category: 'CollectionsTests-Unordered'! !BagTest methodsFor: 'as yet unclassified' stamp: 'damienpollet 1/13/2009 15:57'! testAnySastify self assert: ( self collection anySatisfy: [:each | each = self element]). self deny: (self collection anySatisfy: [:each | each isString]).! ! !BagTest methodsFor: 'basic tests' stamp: 'sd 3/21/2006 22:28'! testAdd "self run: #testAdd" "self debug: #testAdd" | aBag | aBag := Bag new. aBag add: 'a'. aBag add: 'b'. self assert: aBag size = 2. aBag add: 'a'. self assert: aBag size = 3. self assert: (aBag occurrencesOf: 'a') = 2 ! ! !BagTest methodsFor: 'basic tests' stamp: 'sd 3/21/2006 22:28'! testAddWithOccurrences "self debug:#testAddWithOccurrences" | aBag | aBag := Bag new. aBag add: 'a' withOccurrences: 3. self assert: (aBag size = 3). ! ! !BagTest methodsFor: 'basic tests' stamp: 'TJ 3/8/2006 08:42'! testAsBag | aBag | aBag := Bag new. self assert: aBag asBag = aBag.! ! !BagTest methodsFor: 'basic tests' stamp: 'sd 3/21/2006 22:29'! testAsSet | aBag aSet | aBag := Bag new. aBag add:'a' withOccurrences: 4. aBag add:'b' withOccurrences: 2. aSet := aBag asSet. self assert: aSet size = 2. self assert: (aSet occurrencesOf: 'a') = 1 ! ! !BagTest methodsFor: 'basic tests' stamp: 'sd 3/21/2006 22:30'! testCopy "self run: #testCopy" | aBag newBag | aBag := Bag new. aBag add:'a' withOccurrences: 4. aBag add:'b' withOccurrences: 2. newBag := aBag copy. self assert: newBag = newBag. self assert: newBag asSet size = 2.! ! !BagTest methodsFor: 'basic tests' stamp: 'sd 3/21/2006 22:32'! testOccurrencesOf "self debug: #testOccurrencesOf" | aBag | aBag := Bag new. aBag add: 'a' withOccurrences: 3. aBag add: 'b'. aBag add: 'b'. aBag add: 'b'. aBag add: 'b'. self assert: (aBag occurrencesOf:'a') = 3. self assert: (aBag occurrencesOf:'b') = 4. self assert: (aBag occurrencesOf:'c') = 0. self assert: (aBag occurrencesOf: nil) =0. aBag add: nil. self assert: (aBag occurrencesOf: nil) =1. ! ! !BagTest methodsFor: 'requirements' stamp: 'delaunay 4/29/2009 12:01'! anotherElementOrAssociationIn " return an element (or an association for Dictionary ) present in 'collection' " ^ self collection anyOne! ! !BagTest methodsFor: 'requirements' stamp: 'delaunay 4/29/2009 12:01'! anotherElementOrAssociationNotIn " return an element (or an association for Dictionary )not present in 'collection' " ^ elementNotIn ! ! !BagTest methodsFor: 'requirements' stamp: 'delaunay 4/14/2009 12:07'! collectionInForIncluding ^ collectionIn ! ! !BagTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 12:16'! collectionMoreThan5Elements " return a collection including at least 5 elements" ^ collectionWithoutNilMoreThan5 ! ! !BagTest methodsFor: 'requirements' stamp: 'delaunay 4/14/2009 12:08'! collectionNotIncluded ^ collectionNotIn ! ! !BagTest methodsFor: 'requirements' stamp: 'delaunay 4/15/2009 14:07'! collectionOfFloat ^ collectionOfString! ! !BagTest methodsFor: 'requirements' stamp: 'delaunay 4/14/2009 14:22'! collectionWithCharacters ^ collectionWithCharacters .! ! !BagTest methodsFor: 'requirements' stamp: 'delaunay 4/28/2009 10:22'! collectionWithCopyNonIdentical " return a collection that include elements for which 'copy' return a different object (this is not the case of SmallInteger)" ^ collectionOfString! ! !BagTest methodsFor: 'requirements' stamp: 'sd 1/28/2009 16:32'! collectionWithElement "Returns a collection that already includes what is returned by #element." ^ collectionWithElement! ! !BagTest methodsFor: 'requirements' stamp: 'delaunay 4/17/2009 15:24'! collectionWithElementsToRemove ^ collectionIn! ! !BagTest methodsFor: 'requirements' stamp: 'delaunay 4/14/2009 14:20'! collectionWithEqualElements ^ nonEmpty ! ! !BagTest methodsFor: 'requirements' stamp: 'delaunay 4/24/2009 10:31'! collectionWithSortableElements " return a collection elements that can be sorte ( understanding message ' < ' or ' > ')" ^ nonEmpty ! ! !BagTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 11:27'! collectionWithoutEqualElements ^ otherCollectionWithoutEqualElements! ! !BagTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 12:15'! collectionWithoutNilElements " return a collection that doesn't includes a nil element and that doesn't includes equal elements'" ^ collectionWithoutNilMoreThan5! ! !BagTest methodsFor: 'requirements' stamp: 'damienpollet 1/30/2009 17:32'! element ^ super element! ! !BagTest methodsFor: 'requirements' stamp: 'delaunay 4/14/2009 14:19'! elementInForIncludesTest ^ self element ! ! !BagTest methodsFor: 'requirements' stamp: 'delaunay 5/13/2009 14:32'! elementInForOccurrences " return an element included in nonEmpty" ^self nonEmpty anyOne.! ! !BagTest methodsFor: 'requirements' stamp: 'delaunay 4/14/2009 13:40'! elementNotIn ^elementNotIn ! ! !BagTest methodsFor: 'requirements' stamp: 'delaunay 5/13/2009 15:33'! elementTwiceInForOccurrences " return an element included exactly two time in # collectionWithEqualElements" ^ self elementTwiceIn ! ! !BagTest methodsFor: 'requirements' stamp: 'delaunay 4/28/2009 14:19'! elementsCopyNonIdenticalWithoutEqualElements " return a collection that does niot incllude equal elements ( classic equality ) all elements included are elements for which copy is not identical to the element " ^ collectionOfString ! ! !BagTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 11:53'! firstCollection " return a collection that will be the first part of the concatenation" ^ nonEmpty ! ! !BagTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 11:27'! integerCollectionWithoutEqualElements ^ otherCollectionWithoutEqualElements! ! !BagTest methodsFor: 'requirements' stamp: 'delaunay 4/30/2009 10:54'! nonEmpty1Element ^ self speciesClass new add: self element ;yourself.! ! !BagTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 11:28'! nonEmptyWithoutEqualElements " return a collection without equal elements " ^ otherCollectionWithoutEqualElements ! ! !BagTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 11:27'! otherCollection ^ otherCollectionWithoutEqualElements! ! !BagTest methodsFor: 'requirements' stamp: 'delaunay 4/23/2009 11:47'! resultForCollectElementsClass " return the retsult expected by collecting the class of each element of collectionWithoutNilElements" ^ result ! ! !BagTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 11:53'! secondCollection " return a collection that will be the second part of the concatenation" ^ collectionWithCharacters ! ! !BagTest methodsFor: 'requirements' stamp: 'damienpollet 1/30/2009 17:40'! selectedNumber ^ 4! ! !BagTest methodsFor: 'requirements' stamp: 'stephane.ducasse 10/6/2008 17:39'! speciesClass ^ Bag! ! !BagTest methodsFor: 'requirements' stamp: 'delaunay 4/28/2009 14:21'! withEqualElements " return a collection including equal elements (classic equality)" ^ nonEmpty .! ! !BagTest methodsFor: 'setup' stamp: 'stephane.ducasse 10/6/2008 17:22'! collection ^ nonEmpty. ! ! !BagTest methodsFor: 'setup' stamp: 'stephane.ducasse 10/5/2008 15:13'! empty ^ empty ! ! !BagTest methodsFor: 'setup' stamp: 'stephane.ducasse 10/6/2008 17:26'! emptyButAllocatedWith20 ^ emptyButAllocatedWith20! ! !BagTest methodsFor: 'setup' stamp: 'stephane.ducasse 10/5/2008 15:14'! nonEmpty ^ nonEmpty ! ! !BagTest methodsFor: 'setup' stamp: 'stephane.ducasse 10/6/2008 17:22'! result ^ result. ! ! !BagTest methodsFor: 'setup' stamp: 'delaunay 5/14/2009 12:15'! setUp empty := self speciesClass new. nonEmpty := self speciesClass new add: 13; add: -2; add: self elementTwiceIn; add: 10; add: self elementTwiceIn; add: self element; yourself. elementNotIn := 0. collectionIn := self speciesClass new add: -2; add: self elementTwiceIn; add: 10; yourself. collectionNotIn := self speciesClass new add: self elementNotIn; add: 5; yourself. collectionOfString := self speciesClass new add: 1.5; add: 5.5; add: 7.5; yourself. otherCollectionWithoutEqualElements := self speciesClass new add: 1; add: 20; add: 30; add: 40; yourself. collectionWithoutNilMoreThan5 := self speciesClass new add: 1; add: 2; add: 3; add: 4; add: 5; add: 6; yourself. result := self speciesClass new add: SmallInteger; add: SmallInteger; add: SmallInteger; add: SmallInteger; add: SmallInteger; add: SmallInteger; yourself. emptyButAllocatedWith20 := self speciesClass new: 20. collectionWithElement := self speciesClass new add: self element; yourself. collectionWithCharacters := self speciesClass new add: $p; add: $v; add: $i; add: $y; yourself! ! !BagTest methodsFor: 'setup' stamp: 'delaunay 5/11/2009 11:27'! sizeCollection ^ otherCollectionWithoutEqualElements! ! !BagTest methodsFor: 'test - copy' stamp: 'delaunay 4/17/2009 15:26'! elementToAdd ^ 42! ! !BagTest methodsFor: 'test - creation'! testWith "self debug: #testWith" | aCol element | element := self collectionMoreThan5Elements anyOne. aCol := self collectionClass with: element. self assert: (aCol includes: element).! ! !BagTest methodsFor: 'test - creation'! testWithAll "self debug: #testWithAll" | aCol collection | collection := self collectionMoreThan5Elements asOrderedCollection . aCol := self collectionClass withAll: collection . collection do: [ :each | self assert: (aCol occurrencesOf: each ) = ( collection occurrencesOf: each ) ]. self assert: (aCol size = collection size ).! ! !BagTest methodsFor: 'test - creation'! testWithWith "self debug: #testWithWith" | aCol collection element1 element2 | collection := self collectionMoreThan5Elements asOrderedCollection copyFrom: 1 to: 2 . element1 := collection at: 1. element2 := collection at:2. aCol := self collectionClass with: element1 with: element2 . self assert: (aCol occurrencesOf: element1 ) == ( collection occurrencesOf: element1). self assert: (aCol occurrencesOf: element2 ) == ( collection occurrencesOf: element2). ! ! !BagTest methodsFor: 'test - creation'! testWithWithWith "self debug: #testWithWithWith" | aCol collection | collection := self collectionMoreThan5Elements asOrderedCollection copyFrom:1 to: 3 . aCol := self collectionClass with: (collection at:1) with: ( collection at:2 ) with: ( collection at: 3). 1 to: 3 do: [ :i | self assert: ( aCol occurrencesOf: ( collection at: i ) ) = ( collection occurrencesOf: ( collection at: i ) ) ].! ! !BagTest methodsFor: 'test - creation'! testWithWithWithWith "self debug: #testWithWithWithWith" | aCol collection | collection := self collectionMoreThan5Elements asOrderedCollection copyFrom: 1 to: 4. aCol := self collectionClass with: (collection at:1) with: ( collection at:2 ) with: ( collection at: 3) with: ( collection at: 4). 1 to: 3 do: [ :i | self assert: ( aCol occurrencesOf: ( collection at: i ) ) = ( collection occurrencesOf: ( collection at: i ) ) ].! ! !BagTest methodsFor: 'test - creation'! testWithWithWithWithWith "self debug: #testWithWithWithWithWith" | aCol collection | collection := self collectionMoreThan5Elements asOrderedCollection copyFrom: 1 to: 5 . aCol := self collectionClass with: (collection at:1) with: ( collection at:2 ) with: ( collection at: 3) with: (collection at: 4 ) with: ( collection at: 5 ). 1 to: 3 do: [ :i | self assert: ( aCol occurrencesOf: ( collection at: i ) ) = ( collection occurrencesOf: ( collection at: i ) ) ].! ! !BagTest methodsFor: 'test - equality'! testEqualSign "self debug: #testEqualSign" self deny: (self empty = self nonEmpty).! ! !BagTest methodsFor: 'test - equality'! testEqualSignIsTrueForNonIdenticalButEqualCollections "self debug: #testEqualSignIsTrueForNonIdenticalButEqualCollections" self assert: (self empty = self empty copy). self assert: (self empty copy = self empty). self assert: (self empty copy = self empty copy). self assert: (self nonEmpty = self nonEmpty copy). self assert: (self nonEmpty copy = self nonEmpty). self assert: (self nonEmpty copy = self nonEmpty copy).! ! !BagTest methodsFor: 'test - equality'! testEqualSignOfIdenticalCollectionObjects "self debug: #testEqualSignOfIdenticalCollectionObjects" self assert: (self empty = self empty). self assert: (self nonEmpty = self nonEmpty). ! ! !BagTest methodsFor: 'test - iterate' stamp: 'damienpollet 1/30/2009 17:36'! doWithoutNumber ^ 4! ! !BagTest methodsFor: 'test - iterate' stamp: 'marcus.denker 2/20/2009 16:29'! expectedElementByDetect ^ -2 ! ! !BagTest methodsFor: 'test - iterate' stamp: 'damienpollet 1/30/2009 17:37'! expectedSizeAfterReject ^ 2! ! !BagTest methodsFor: 'test - remove' stamp: 'damienpollet 1/30/2009 17:15'! elementTwiceIn ^ super elementTwiceIn! ! !BagTest methodsFor: 'test - remove' stamp: 'damienpollet 1/30/2009 17:07'! testRemoveElementThatExistsTwice "self debug: #testRemoveElementThatDoesExistsTwice" | size | size := self nonEmpty size. self assert: (self nonEmpty includes: self elementTwiceIn). self nonEmpty remove: self elementTwiceIn. self assert: size - 1 = self nonEmpty size! ! !BagTest methodsFor: 'test - set arithmetic' stamp: 'stephane.ducasse 12/20/2008 22:46'! collectionClass ^ Bag! ! !BagTest methodsFor: 'tests' stamp: 'stephane.ducasse 5/20/2009 18:02'! testCreation "self run: #testCreation" "self debug: #testCreation" | bag | bag := Bag new. self assert: (bag size) = 0. self assert: (bag isEmpty). ! ! !BagTest methodsFor: 'tests' stamp: 'stephane.ducasse 5/20/2009 18:02'! testCumulativeCounts "self run: #testCumulativeCounts" "self debug: #testCumulativeCounts" | bag cumulativeCounts | bag := Bag new. bag add: '1' withOccurrences: 50. bag add: '2' withOccurrences: 40. bag add: '3' withOccurrences: 10. cumulativeCounts := bag cumulativeCounts. self assert: cumulativeCounts size = 3. self assert: cumulativeCounts first = (50 -> '1'). self assert: cumulativeCounts second = (90 -> '2'). self assert: cumulativeCounts third = (100 -> '3'). ! ! !BagTest methodsFor: 'tests' stamp: 'stephane.ducasse 5/20/2009 18:02'! testEqual "(self run: #testEqual)" "(self debug: #testEqual)" | bag1 bag2 | bag1 := Bag new. bag2 := Bag new. self assert: bag1 = bag2. bag1 add: #a; add: #b. bag2 add: #a; add: #a. self deny: bag1 = bag2. self assert: bag1 = bag1. bag1 add: #a. bag2 add: #b. self assert: bag1 = bag2. bag1 add: #c. self deny: bag1 = bag2. bag2 add: #c. self assert: bag1 = bag2! ! !BagTest methodsFor: 'tests' stamp: 'stephane.ducasse 5/20/2009 18:03'! testRemove "self run: #testRemove" "self debug: #testRemove" | bag item | item := 'test item'. bag := Bag new. bag add: item. self assert: (bag size) = 1. bag remove: item. self assert: bag isEmpty. bag add: item withOccurrences: 2. bag remove: item. bag remove: item. self assert: (bag size) = 0. self should: [bag remove: item.] raise: Error.! ! !BagTest methodsFor: 'tests' stamp: 'nice 9/14/2009 21:05'! testRemoveAll "Allows one to remove all elements of a collection" | c1 c2 s2 | c1 := #(10 9 8 7 5 4 4 2) asBag. c2 := c1 copy. s2 := c2 size. c1 removeAll. self assert: c1 size = 0. self assert: c2 size = s2 description: 'the copy has not been modified'.! ! !BagTest methodsFor: 'tests' stamp: 'stephane.ducasse 5/20/2009 18:03'! testSortedCounts "self run: #testSortedCounts" "self debug: #testSortedCounts" | bag sortedCounts| bag := Bag new. bag add: '1' withOccurrences: 10. bag add: '2' withOccurrences: 1. bag add: '3' withOccurrences: 5. sortedCounts := bag sortedCounts. self assert: sortedCounts size = 3. self assert: sortedCounts first = (10->'1'). self assert: sortedCounts second = (5->'3'). self assert: sortedCounts third = (1->'2'). ! ! !BagTest methodsFor: 'tests' stamp: 'stephane.ducasse 5/20/2009 18:03'! testSortedElements "self run: #testSortedElements" "self debug: #testSortedElements" | bag sortedElements| bag := Bag new. bag add: '2' withOccurrences: 1. bag add: '1' withOccurrences: 10. bag add: '3' withOccurrences: 5. sortedElements := bag sortedElements. self assert: sortedElements size = 3. self assert: sortedElements first = ('1'->10). self assert: sortedElements second = ('2'->1). self assert: sortedElements third = ('3'->5). ! ! !BagTest methodsFor: 'tests - adding'! testTAdd | added collection | collection :=self otherCollection . added := collection add: self element. self assert: added == self element. "test for identiy because #add: has not reason to copy its parameter." self assert: (collection includes: self element) . self assert: (self collectionWithElement includes: self element). ! ! !BagTest methodsFor: 'tests - adding'! testTAddAll | added collection toBeAdded | collection := self collectionWithElement . toBeAdded := self otherCollection . added := collection addAll: toBeAdded . self assert: added == toBeAdded . "test for identiy because #addAll: has not reason to copy its parameter." self assert: (collection includesAllOf: toBeAdded )! ! !BagTest methodsFor: 'tests - adding'! testTAddIfNotPresentWithElementAlreadyIn | added oldSize collection element | collection := self collectionWithElement . oldSize := collection size. element := self element . self assert: (collection includes: element ). added := collection addIfNotPresent: element . self assert: added == element . "test for identiy because #add: has not reason to copy its parameter." self assert: collection size = oldSize! ! !BagTest methodsFor: 'tests - adding'! testTAddIfNotPresentWithNewElement | added oldSize collection element | collection := self otherCollection . oldSize := collection size. element := self element . self deny: (collection includes: element ). added := collection addIfNotPresent: element . self assert: added == element . "test for identiy because #add: has not reason to copy its parameter." self assert: (collection size = (oldSize + 1)). ! ! !BagTest methodsFor: 'tests - adding'! testTAddTwice | added oldSize collection element | collection := self collectionWithElement . element := self element . oldSize := collection size. added := collection add: element ; add: element . self assert: added == element . "test for identiy because #add: has not reason to copy its parameter." self assert: (collection includes: element ). self assert: collection size = (oldSize + 2)! ! !BagTest methodsFor: 'tests - adding'! testTAddWithOccurences | added oldSize collection element | collection := self collectionWithElement . element := self element . oldSize := collection size. added := collection add: element withOccurrences: 5. self assert: added == element. "test for identiy because #add: has not reason to copy its parameter." self assert: (collection includes: element). self assert: collection size = (oldSize + 5)! ! !BagTest methodsFor: 'tests - adding'! testTWrite | added collection element | collection := self otherCollection . element := self element . added := collection write: element . self assert: added == element . "test for identiy because #add: has not reason to copy its parameter." self assert: (collection includes: element ) . self assert: (collection includes: element ). ! ! !BagTest methodsFor: 'tests - adding'! testTWriteTwice | added oldSize collection element | collection := self collectionWithElement . element := self element . oldSize := collection size. added := collection write: element ; write: element . self assert: added == element . "test for identiy because #add: has not reason to copy its parameter." self assert: (collection includes: element ). self assert: collection size = (oldSize + 2)! ! !BagTest methodsFor: 'tests - as set tests'! testAsIdentitySetWithEqualsElements | result collection | collection := self withEqualElements . result := collection asIdentitySet. collection do: [ :each | self assert: (result occurrencesOf: each) = 1 ]. self assert: result class = IdentitySet.! ! !BagTest methodsFor: 'tests - as set tests'! testAsSetWithEqualsElements | result | result := self withEqualElements asSet. self withEqualElements do: [ :each | self assert: (result occurrencesOf: each) = 1 ]. self assert: result class = Set! ! !BagTest methodsFor: 'tests - as sorted collection'! testAsSortedArray | result collection | collection := self collectionWithSortableElements . result := collection asSortedArray. self assert: (result class includesBehavior: Array). self assert: result isSorted. self assert: result size = collection size! ! !BagTest methodsFor: 'tests - as sorted collection'! testAsSortedCollection | aCollection result | aCollection := self collectionWithSortableElements . result := aCollection asSortedCollection. self assert: (result class includesBehavior: SortedCollection). result do: [ :each | self assert: (aCollection occurrencesOf: each) = (result occurrencesOf: each) ]. self assert: result size = aCollection size.! ! !BagTest methodsFor: 'tests - as sorted collection'! testAsSortedCollectionWithSortBlock | result tmp | result := self collectionWithSortableElements asSortedCollection: [:a :b | a > b]. self assert: (result class includesBehavior: SortedCollection). result do: [ :each | self assert: (self collectionWithSortableElements occurrencesOf: each) = (result occurrencesOf: each) ]. self assert: result size = self collectionWithSortableElements size. tmp:=result at: 1. result do: [:each| self assert: tmp>=each. tmp:=each]. ! ! !BagTest methodsFor: 'tests - as string comma delimiter sequenceable'! testAsCommaStringEmpty self assert: self empty asCommaString = ''. self assert: self empty asCommaStringAnd = ''. ! ! !BagTest methodsFor: 'tests - as string comma delimiter sequenceable'! testAsCommaStringMore | result resultAnd index allElementsAsString tmp | result:= self nonEmpty asCommaString . resultAnd:= self nonEmpty asCommaStringAnd . tmp :=OrderedCollection new. self nonEmpty do: [ :each | tmp add: each asString]. "verifying result :" index := 1. allElementsAsString := (result findBetweenSubStrs: ', ' ). allElementsAsString do: [:each | self assert: (tmp occurrencesOf: each)=(allElementsAsString occurrencesOf: each). ]. "verifying esultAnd :" allElementsAsString:=(resultAnd findBetweenSubStrs: ', ' ). 1 to: allElementsAsString size do: [:i | i<(allElementsAsString size-1 ) | i= allElementsAsString size ifTrue: [self assert: (tmp occurrencesOf:(allElementsAsString at:i))=(allElementsAsString occurrencesOf:(allElementsAsString at:i))]. i=(allElementsAsString size-1) ifTrue:[ self assert: (allElementsAsString at:i)=('and')]. ].! ! !BagTest methodsFor: 'tests - as string comma delimiter sequenceable'! testAsCommaStringOne self nonEmpty1Element do: [:each | self assert: each asString =self nonEmpty1Element asCommaString. self assert: each asString=self nonEmpty1Element asCommaStringAnd.]. ! ! !BagTest methodsFor: 'tests - as string comma delimiter sequenceable'! testAsStringOnDelimiterEmpty | delim emptyStream | delim := ', '. emptyStream := ReadWriteStream on: ''. self empty asStringOn: emptyStream delimiter: delim. self assert: emptyStream contents = ''. ! ! !BagTest methodsFor: 'tests - as string comma delimiter sequenceable'! testAsStringOnDelimiterLastEmpty | delim emptyStream | delim := ', '. emptyStream := ReadWriteStream on: ''. self empty asStringOn: emptyStream delimiter: delim last:'and'. self assert: emptyStream contents = ''. ! ! !BagTest methodsFor: 'tests - as string comma delimiter sequenceable'! testAsStringOnDelimiterLastMore | delim multiItemStream result last allElementsAsString tmp | delim := ', '. last := 'and'. result:=''. tmp := self nonEmpty collect: [:each | each asString]. multiItemStream := ReadWriteStream on:result. self nonEmpty asStringOn: multiItemStream delimiter: ', ' last: last. allElementsAsString:=(result findBetweenSubStrs: ', ' ). 1 to: allElementsAsString size do: [:i | i<(allElementsAsString size-1 ) | i= allElementsAsString size ifTrue: [self assert: (tmp occurrencesOf:(allElementsAsString at:i))=(allElementsAsString occurrencesOf:(allElementsAsString at:i))]. i=(allElementsAsString size-1) ifTrue:[ self assert: (allElementsAsString at:i)=('and')]. ]. ! ! !BagTest methodsFor: 'tests - as string comma delimiter sequenceable'! testAsStringOnDelimiterLastOne | delim oneItemStream result | delim := ', '. result:=''. oneItemStream := ReadWriteStream on: result. self nonEmpty1Element asStringOn: oneItemStream delimiter: delim last: 'and'. oneItemStream do: [:each1 | self nonEmpty1Element do: [:each2 |self assert: each1 = (each2 asString) ] ]. ! ! !BagTest methodsFor: 'tests - as string comma delimiter sequenceable'! testAsStringOnDelimiterMore | delim multiItemStream result allElementsAsString tmp | delim := ', '. result:=''. tmp:= self nonEmpty collect:[:each | each asString]. multiItemStream := ReadWriteStream on:result. self nonEmpty asStringOn: multiItemStream delimiter: ', '. allElementsAsString := (result findBetweenSubStrs: ', ' ). allElementsAsString do: [:each | self assert: (tmp occurrencesOf: each)=(allElementsAsString occurrencesOf: each). ].! ! !BagTest methodsFor: 'tests - as string comma delimiter sequenceable'! testAsStringOnDelimiterOne | delim oneItemStream result | delim := ', '. result:=''. oneItemStream := ReadWriteStream on: result. self nonEmpty1Element asStringOn: oneItemStream delimiter: delim. oneItemStream do: [:each1 | self nonEmpty1Element do: [:each2 |self assert: each1 = (each2 asString) ] ]. ! ! !BagTest methodsFor: 'tests - concatenation'! testConcatenation "| collection1 collection2 result | collection1 := self firstCollection . collection2 := self secondCollection . result := collection1 , collection2. collection1 do:[ :each | self assert: (result includes: each)]. collection2 do:[ :each | self assert: (result includes: each)]." | collection1 collection2 result | collection1 := self firstCollection . collection2 := self secondCollection . result := collection1 , collection2. result do: [ :each | self assert: (result occurrencesOf: each) = (( collection1 occurrencesOf: each ) + ( collection2 occurrencesOf: each ) ). ]. self assert: result size = (collection1 size + collection2 size)! ! !BagTest methodsFor: 'tests - concatenation'! testConcatenationWithDuplicate | collection1 collection2 result | collection1 := self firstCollection . collection2 := self firstCollection . result := collection1 , collection2. result do: [ :each | self assert: (result occurrencesOf: each) = (( collection1 occurrencesOf: each ) + ( collection2 occurrencesOf: each ) ). ]. self assert: result size = (collection1 size * 2)! ! !BagTest methodsFor: 'tests - concatenation'! testConcatenationWithEmpty | result | result := self firstCollection , self empty. self assert: result = self firstCollection! ! !BagTest methodsFor: 'tests - converting'! assertNoDuplicates: aCollection whenConvertedTo: aClass | result | result := self collectionWithEqualElements asIdentitySet. self assert: (result class includesBehavior: IdentitySet). self collectionWithEqualElements do: [ :initial | self assert: (result occurrencesOf: initial) = 1 ]! ! !BagTest methodsFor: 'tests - converting'! assertNonDuplicatedContents: aCollection whenConvertedTo: aClass | result | result := aCollection perform: ('as' , aClass name) asSymbol. self assert: (result class includesBehavior: aClass). result do: [ :each | self assert: (aCollection occurrencesOf: each) = (result occurrencesOf: each) ]. ^ result! ! !BagTest methodsFor: 'tests - converting'! assertSameContents: aCollection whenConvertedTo: aClass | result | result := self assertNonDuplicatedContents: aCollection whenConvertedTo: aClass. self assert: result size = aCollection size! ! !BagTest methodsFor: 'tests - converting'! testAsArray "self debug: #testAsArray3" self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: Array! ! !BagTest methodsFor: 'tests - converting'! testAsByteArray | res | self shouldnt: [self integerCollectionWithoutEqualElements ] raise: Error. self integerCollectionWithoutEqualElements do: [ :each | self assert: each class = SmallInteger] . res := true. self integerCollectionWithoutEqualElements detect: [ :each | (self integerCollectionWithoutEqualElements occurrencesOf: each) > 1 ] ifNone: [ res := false ]. self assert: res = false. self assertSameContents: self integerCollectionWithoutEqualElements whenConvertedTo: ByteArray! ! !BagTest methodsFor: 'tests - converting'! testAsIdentitySet "test with a collection without equal elements :" self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: IdentitySet. ! ! !BagTest methodsFor: 'tests - converting'! testAsOrderedCollection self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: OrderedCollection! ! !BagTest methodsFor: 'tests - copy' stamp: 'delaunay 4/17/2009 15:26'! testCopyEmptyWith "self debug: #testCopyWith" | res | res := self empty copyWith: self elementToAdd. self assert: res size = (self empty size + 1). self assert: (res includes: self elementToAdd)! ! !BagTest methodsFor: 'tests - copy' stamp: 'delaunay 4/17/2009 15:26'! testCopyEmptyWithout "self debug: #testCopyEmptyWithout" | res | res := self empty copyWithout: self elementToAdd. self assert: res size = self empty size. self deny: (res includes: self elementToAdd)! ! !BagTest methodsFor: 'tests - copy' stamp: 'delaunay 4/17/2009 15:24'! testCopyEmptyWithoutAll "self debug: #testCopyEmptyWithoutAll" | res | res := self empty copyWithoutAll: self collectionWithElementsToRemove. self assert: res size = self empty size. self collectionWithElementsToRemove do: [ :each | self deny: (res includes: each) ]! ! !BagTest methodsFor: 'tests - copy' stamp: 'delaunay 4/17/2009 15:26'! testCopyNonEmptyWith "self debug: #testCopyNonEmptyWith" | res | res := self nonEmpty copyWith: self elementToAdd. "here we do not test the size since for a non empty set we would get a problem. Then in addition copy is not about duplicate management. The element should be in at the end." self assert: (res includes: self elementToAdd). self nonEmpty do: [ :each | res includes: each ]! ! !BagTest methodsFor: 'tests - copy'! testCopyNonEmptyWithout "self debug: #testCopyNonEmptyWithout" | res anElementOfTheCollection | anElementOfTheCollection := self nonEmpty anyOne. res := (self nonEmpty copyWithout: anElementOfTheCollection). "here we do not test the size since for a non empty set we would get a problem. Then in addition copy is not about duplicate management. The element should be in at the end." self deny: (res includes: anElementOfTheCollection). self nonEmpty do: [:each | (each = anElementOfTheCollection) ifFalse: [self assert: (res includes: each)]]. ! ! !BagTest methodsFor: 'tests - copy' stamp: 'delaunay 4/17/2009 15:24'! testCopyNonEmptyWithoutAll "self debug: #testCopyNonEmptyWithoutAll" | res | res := self nonEmpty copyWithoutAll: self collectionWithElementsToRemove. "here we do not test the size since for a non empty set we would get a problem. Then in addition copy is not about duplicate management. The element should be in at the end." self collectionWithElementsToRemove do: [ :each | self deny: (res includes: each) ]. self nonEmpty do: [ :each | (self collectionWithElementsToRemove includes: each) ifFalse: [ self assert: (res includes: each) ] ]! ! !BagTest methodsFor: 'tests - copy' stamp: 'delaunay 3/30/2009 10:33'! testCopyNonEmptyWithoutAllNotIncluded ! ! !BagTest methodsFor: 'tests - copy' stamp: 'delaunay 4/17/2009 15:26'! testCopyNonEmptyWithoutNotIncluded "self debug: #testCopyNonEmptyWithoutNotIncluded" | res | res := self nonEmpty copyWithout: self elementToAdd. "here we do not test the size since for a non empty set we would get a problem. Then in addition copy is not about duplicate management. The element should be in at the end." self nonEmpty do: [ :each | self assert: (res includes: each) ]! ! !BagTest methodsFor: 'tests - copy - clone'! testCopyCreatesNewObject "self debug: #testCopyCreatesNewObject" | copy | copy := self nonEmpty copy. self deny: self nonEmpty == copy. ! ! !BagTest methodsFor: 'tests - copy - clone'! testCopyEmpty "self debug: #testCopyEmpty" | copy | copy := self empty copy. self assert: copy isEmpty.! ! !BagTest methodsFor: 'tests - copy - clone'! testCopyNonEmpty "self debug: #testCopyNonEmpty" | copy | copy := self nonEmpty copy. self deny: copy isEmpty. self assert: copy size = self nonEmpty size. self nonEmpty do: [:each | copy includes: each]! ! !BagTest methodsFor: 'tests - fixture' stamp: 'delaunay 4/17/2009 15:26'! test0CopyTest self shouldnt: self empty raise: Error. self assert: self empty size = 0. self shouldnt: self nonEmpty raise: Error. self assert: (self nonEmpty size = 0) not. self shouldnt: self collectionWithElementsToRemove raise: Error. self assert: (self collectionWithElementsToRemove size = 0) not. self shouldnt: self elementToAdd raise: Error! ! !BagTest methodsFor: 'tests - fixture'! test0FixtureAsStringCommaAndDelimiterTest self shouldnt: [self nonEmpty] raise:Error . self deny: self nonEmpty isEmpty. self shouldnt: [self empty] raise:Error . self assert: self empty isEmpty. self shouldnt: [self nonEmpty1Element ] raise:Error . self assert: self nonEmpty1Element size=1.! ! !BagTest methodsFor: 'tests - fixture'! test0FixtureCloneTest self shouldnt: [ self nonEmpty ] raise: Error. self deny: self nonEmpty isEmpty. self shouldnt: [ self empty ] raise: Error. self assert: self empty isEmpty. ! ! !BagTest methodsFor: 'tests - fixture'! test0FixtureConcatenationTest self shouldnt: [ self firstCollection ]raise: Error. self deny: self firstCollection isEmpty. self shouldnt: [ self firstCollection ]raise: Error. self deny: self firstCollection isEmpty. self shouldnt: [ self empty ]raise: Error. self assert: self empty isEmpty! ! !BagTest methodsFor: 'tests - fixture'! test0FixtureConverAsSortedTest self shouldnt: [self collectionWithSortableElements ] raise: Error. self deny: self collectionWithSortableElements isEmpty .! ! !BagTest methodsFor: 'tests - fixture'! test0FixtureCreationWithTest self shouldnt: [ self collectionMoreThan5Elements ] raise: Error. self assert: self collectionMoreThan5Elements size >= 5.! ! !BagTest methodsFor: 'tests - fixture'! test0FixtureIncludeTest | elementIn | self shouldnt: [ self nonEmpty ]raise: Error. self deny: self nonEmpty isEmpty. self shouldnt: [ self elementNotIn ]raise: Error. elementIn := true. self nonEmpty detect: [ :each | each = self elementNotIn ] ifNone: [ elementIn := false ]. self assert: elementIn = false. self shouldnt: [ self anotherElementNotIn ]raise: Error. elementIn := true. self nonEmpty detect: [ :each | each = self anotherElementNotIn ] ifNone: [ elementIn := false ]. self assert: elementIn = false. self shouldnt: [ self empty ] raise: Error. self assert: self empty isEmpty. ! ! !BagTest methodsFor: 'tests - fixture'! test0FixtureIncludeWithIdentityTest | element | self shouldnt: [ self collectionWithCopyNonIdentical ]raise: Error. element := self collectionWithCopyNonIdentical anyOne. self deny: element == element copy. ! ! !BagTest methodsFor: 'tests - fixture'! test0FixtureOccurrencesForMultiplinessTest | cpt element collection | self shouldnt: [self collectionWithEqualElements ]raise: Error. self shouldnt: [self collectionWithEqualElements ]raise: Error. self shouldnt: [ self elementTwiceInForOccurrences ] raise: Error. element := self elementTwiceInForOccurrences . collection := self collectionWithEqualElements . cpt := 0 . " testing with identity check ( == ) so that identy collections can use this trait : " self collectionWithEqualElements do: [ :each | each == self elementTwiceInForOccurrences ifTrue: [ cpt := cpt + 1 ] ]. self assert: cpt = 2.! ! !BagTest methodsFor: 'tests - fixture'! test0FixtureOccurrencesTest | tmp | self shouldnt: [self empty ]raise: Error. self assert: self empty isEmpty. self shouldnt: [ self collectionWithoutEqualElements ] raise: Error. self deny: self collectionWithoutEqualElements isEmpty. tmp := OrderedCollection new. self collectionWithoutEqualElements do: [ :each | self deny: (tmp includes: each). tmp add: each. ]. self shouldnt: [ self elementNotInForOccurrences ] raise: Error. self deny: (self collectionWithoutEqualElements includes: self elementNotInForOccurrences)! ! !BagTest methodsFor: 'tests - fixture'! test0FixturePrintTest self shouldnt: [self nonEmpty ] raise: Error. self deny: self nonEmpty isEmpty.! ! !BagTest methodsFor: 'tests - fixture'! test0FixtureRequirementsOfTAddTest self shouldnt: [ self collectionWithElement ] raise: Exception. self shouldnt: [ self otherCollection ] raise: Exception. self shouldnt: [ self element ] raise: Exception. self assert: (self collectionWithElement includes: self element). self deny: (self otherCollection includes: self element)! ! !BagTest methodsFor: 'tests - fixture'! test0FixtureSetAritmeticTest self shouldnt: [ self collection ] raise: Error. self deny: self collection isEmpty. self shouldnt: [ self nonEmpty ] raise: Error. self deny: self nonEmpty isEmpty. self shouldnt: [ self anotherElementOrAssociationNotIn ] raise: Error. self collection isDictionary ifTrue: [ self deny: (self collection associations includes: self anotherElementOrAssociationNotIn key) ] ifFalse: [ self deny: (self collection includes: self anotherElementOrAssociationNotIn) ]. self shouldnt: [ self collectionClass ] raise: Error! ! !BagTest methodsFor: 'tests - fixture'! test0FixtureTConvertAsSetForMultiplinessTest "a collection with equal elements:" | res | self shouldnt: [ self withEqualElements] raise: Error. res := true. self withEqualElements detect: [ :each | (self withEqualElements occurrencesOf: each) > 1 ] ifNone: [ res := false ]. self assert: res = true. ! ! !BagTest methodsFor: 'tests - fixture'! test0FixtureTConvertTest "a collection of number without equal elements:" | res | self shouldnt: [ self collectionWithoutEqualElements ]raise: Error. res := true. self collectionWithoutEqualElements detect: [ :each | (self collectionWithoutEqualElements occurrencesOf: each) > 1 ] ifNone: [ res := false ]. self assert: res = false. ! ! !BagTest methodsFor: 'tests - fixture'! test0FixtureTRemoveTest | duplicate | self shouldnt: [ self empty ]raise: Error. self shouldnt: [ self nonEmptyWithoutEqualElements] raise:Error. self deny: self nonEmptyWithoutEqualElements isEmpty. duplicate := true. self nonEmptyWithoutEqualElements detect: [:each | (self nonEmptyWithoutEqualElements occurrencesOf: each) > 1] ifNone: [duplicate := false]. self assert: duplicate = false. self shouldnt: [ self elementNotIn ] raise: Error. self assert: self empty isEmpty. self deny: self nonEmptyWithoutEqualElements isEmpty. self deny: (self nonEmptyWithoutEqualElements includes: self elementNotIn)! ! !BagTest methodsFor: 'tests - fixture'! test0TStructuralEqualityTest self shouldnt: [self empty] raise: Error. self shouldnt: [self nonEmpty] raise: Error. self assert: self empty isEmpty. self deny: self nonEmpty isEmpty.! ! !BagTest methodsFor: 'tests - includes' stamp: 'stephane.ducasse 11/21/2008 14:58'! anotherElementNotIn ^ 42! ! !BagTest methodsFor: 'tests - includes' stamp: 'delaunay 4/2/2009 11:53'! elementNotInForOccurrences ^ 666! ! !BagTest methodsFor: 'tests - includes' stamp: 'delaunay 4/28/2009 10:22'! testIdentityIncludes " test the comportement in presence of elements 'includes' but not 'identityIncludes' " " can not be used by collections that can't include elements for wich copy doesn't return another instance " | collection element | self shouldnt: [ self collectionWithCopyNonIdentical ] raise: Error. collection := self collectionWithCopyNonIdentical. element := collection anyOne copy. "self assert: (collection includes: element)." self deny: (collection identityIncludes: element)! ! !BagTest methodsFor: 'tests - includes'! testIdentityIncludesNonSpecificComportement " test the same comportement than 'includes: ' " | collection | collection := self nonEmpty . self deny: (collection identityIncludes: self elementNotIn ). self assert:(collection identityIncludes: collection anyOne) ! ! !BagTest methodsFor: 'tests - includes'! testIncludesAllOfAllThere "self debug: #testIncludesAllOfAllThere'" self assert: (self empty includesAllOf: self empty). self assert: (self nonEmpty includesAllOf: { self nonEmpty anyOne }). self assert: (self nonEmpty includesAllOf: self nonEmpty).! ! !BagTest methodsFor: 'tests - includes' stamp: 'delaunay 4/2/2009 11:53'! testIncludesAllOfNoneThere "self debug: #testIncludesAllOfNoneThere'" self deny: (self empty includesAllOf: self collection). self deny: (self nonEmpty includesAllOf: { (self elementNotIn). (self anotherElementNotIn) })! ! !BagTest methodsFor: 'tests - includes'! testIncludesAnyOfAllThere "self debug: #testIncludesAnyOfAllThere'" self deny: (self nonEmpty includesAnyOf: self empty). self assert: (self nonEmpty includesAnyOf: { self nonEmpty anyOne }). self assert: (self nonEmpty includesAnyOf: self nonEmpty).! ! !BagTest methodsFor: 'tests - includes' stamp: 'delaunay 4/2/2009 11:53'! testIncludesAnyOfNoneThere "self debug: #testIncludesAnyOfNoneThere'" self deny: (self nonEmpty includesAnyOf: self empty). self deny: (self nonEmpty includesAnyOf: { (self elementNotIn). (self anotherElementNotIn) })! ! !BagTest methodsFor: 'tests - includes' stamp: 'delaunay 4/2/2009 11:53'! testIncludesElementIsNotThere "self debug: #testIncludesElementIsNotThere" self deny: (self nonEmpty includes: self elementNotInForOccurrences). self assert: (self nonEmpty includes: self nonEmpty anyOne). self deny: (self empty includes: self elementNotInForOccurrences)! ! !BagTest methodsFor: 'tests - includes'! testIncludesElementIsThere "self debug: #testIncludesElementIsThere" self assert: (self nonEmpty includes: self nonEmpty anyOne).! ! !BagTest methodsFor: 'tests - includes' stamp: 'delaunay 4/9/2009 10:44'! testIncludesSubstringAnywhere "self debug: #testIncludesSubstringAnywher'" self assert: (self empty includesAllOf: self empty). self assert: (self nonEmpty includesAllOf: { (self nonEmpty anyOne) }). self assert: (self nonEmpty includesAllOf: self nonEmpty)! ! !BagTest methodsFor: 'tests - occurrencesOf'! testOccurrencesOfEmpty | result | result := self empty occurrencesOf: (self collectionWithoutEqualElements anyOne). self assert: result = 0! ! !BagTest methodsFor: 'tests - occurrencesOf'! testOccurrencesOfNotIn | result | result := self collectionWithoutEqualElements occurrencesOf: self elementNotInForOccurrences. self assert: result = 0! ! !BagTest methodsFor: 'tests - occurrencesOf for multipliness'! testOccurrencesOfForMultipliness | collection element | collection := self collectionWithEqualElements . element := self elementTwiceInForOccurrences . self assert: (collection occurrencesOf: element ) = 2. ! ! !BagTest methodsFor: 'tests - printing'! testPrintElementsOn | aStream result allElementsAsString tmp | result:=''. aStream:= ReadWriteStream on: result. tmp:= OrderedCollection new. self nonEmpty do: [:each | tmp add: each asString]. self nonEmpty printElementsOn: aStream . allElementsAsString:=(result findBetweenSubStrs: ' ' ). 1 to: allElementsAsString size do: [:i | self assert: (tmp occurrencesOf:(allElementsAsString at:i))=(allElementsAsString occurrencesOf:(allElementsAsString at:i)). ].! ! !BagTest methodsFor: 'tests - printing'! testPrintNameOn | aStream result | result:=''. aStream:= ReadWriteStream on: result. self nonEmpty printNameOn: aStream . Transcript show: result asString. self nonEmpty class name first isVowel ifTrue:[ self assert: aStream contents =('an ',self nonEmpty class name ) ] ifFalse:[self assert: aStream contents =('a ',self nonEmpty class name)].! ! !BagTest methodsFor: 'tests - printing'! testPrintOn | aStream result allElementsAsString tmp | result:=''. aStream:= ReadWriteStream on: result. tmp:= OrderedCollection new. self nonEmpty do: [:each | tmp add: each asString]. self nonEmpty printOn: aStream . allElementsAsString:=(result findBetweenSubStrs: ' ' ). 1 to: allElementsAsString size do: [:i | i=1 ifTrue:[ self accessCollection class name first isVowel ifTrue:[self assert: (allElementsAsString at:i)='an' ] ifFalse:[self assert: (allElementsAsString at:i)='a'].]. i=2 ifTrue:[self assert: (allElementsAsString at:i)=self accessCollection class name]. i>2 ifTrue:[self assert: (tmp occurrencesOf:(allElementsAsString at:i))=(allElementsAsString occurrencesOf:(allElementsAsString at:i)).]. ].! ! !BagTest methodsFor: 'tests - printing'! testPrintOnDelimiter | aStream result allElementsAsString tmp | result:=''. aStream:= ReadWriteStream on: result. tmp:= OrderedCollection new. self nonEmpty do: [:each | tmp add: each asString]. self nonEmpty printOn: aStream delimiter: ', ' . allElementsAsString:=(result findBetweenSubStrs: ', ' ). 1 to: allElementsAsString size do: [:i | self assert: (tmp occurrencesOf:(allElementsAsString at:i))=(allElementsAsString occurrencesOf:(allElementsAsString at:i)) ].! ! !BagTest methodsFor: 'tests - printing'! testPrintOnDelimiterLast | aStream result allElementsAsString tmp | result:=''. aStream:= ReadWriteStream on: result. tmp:= OrderedCollection new. self nonEmpty do: [:each | tmp add: each asString]. self nonEmpty printOn: aStream delimiter: ', ' last: 'and'. allElementsAsString:=(result findBetweenSubStrs: ', ' ). 1 to: allElementsAsString size do: [:i | i<(allElementsAsString size-1 ) ifTrue: [self assert: (tmp occurrencesOf: (allElementsAsString at:i))=(allElementsAsString occurrencesOf: (allElementsAsString at:i))]. i=(allElementsAsString size-1) ifTrue:[ self deny: (allElementsAsString at:i)=('and')asString]. i=(allElementsAsString size) ifTrue: [self assert: (tmp occurrencesOf: (allElementsAsString at:i))=(allElementsAsString occurrencesOf: (allElementsAsString at:i))]. ].! ! !BagTest methodsFor: 'tests - printing'! testStoreOn " for the moment work only for collection that include simple elements such that Integer" "| string str result cuttedResult index elementsAsStringExpected elementsAsStringObtained tmp | string := ''. str := ReadWriteStream on: string. elementsAsStringExpected := OrderedCollection new. elementsAsStringObtained := OrderedCollection new. self nonEmpty do: [ :each | elementsAsStringExpected add: each asString]. self nonEmpty storeOn: str. result := str contents . cuttedResult := ( result findBetweenSubStrs: ';' ). index := 1. cuttedResult do: [ :each | index = 1 ifTrue: [ self assert: (each beginsWith: ( tmp := '((' , self nonEmpty class asString , ' new) add: ' )). tmp := each copyFrom: ( tmp size + 1) to: ( each size ). elementsAsStringObtained add: tmp. index := index + 1. ] ifFalse: [ index < cuttedResult size ifTrue:[self assert: (each beginsWith: ( tmp:= ' add: ' )). tmp := each copyFrom: ( tmp size + 1) to: ( each size ). elementsAsStringObtained add: tmp. index := index + 1.] ifFalse: [self assert: ( each = ' yourself)' ) ]. ] ]. elementsAsStringExpected do: [ :each | self assert: (elementsAsStringExpected occurrencesOf: each ) = ( elementsAsStringObtained occurrencesOf: each) ]" ! ! !BagTest methodsFor: 'tests - remove'! testRemoveAllError "self debug: #testRemoveElementThatExists" | el res subCollection | el := self elementNotIn. subCollection := self nonEmptyWithoutEqualElements copyWith: el. self should: [ res := self nonEmptyWithoutEqualElements removeAll: subCollection ] raise: Error! ! !BagTest methodsFor: 'tests - remove'! testRemoveAllFoundIn "self debug: #testRemoveElementThatExists" | el res subCollection | el := self nonEmptyWithoutEqualElements anyOne. subCollection := (self nonEmptyWithoutEqualElements copyWithout: el) copyWith: self elementNotIn. self shouldnt: [ res := self nonEmptyWithoutEqualElements removeAllFoundIn: subCollection ] raise: Error. self assert: self nonEmptyWithoutEqualElements size = 1. self nonEmptyWithoutEqualElements do: [ :each | self assert: each = el ]! ! !BagTest methodsFor: 'tests - remove'! testRemoveAllSuchThat "self debug: #testRemoveElementThatExists" | el subCollection | el := self nonEmptyWithoutEqualElements anyOne. subCollection := self nonEmptyWithoutEqualElements copyWithout: el. self nonEmptyWithoutEqualElements removeAllSuchThat: [ :each | subCollection includes: each ]. self assert: self nonEmptyWithoutEqualElements size = 1. self nonEmptyWithoutEqualElements do: [ :each | self assert: each = el ]! ! !BagTest methodsFor: 'tests - remove'! testRemoveElementFromEmpty "self debug: #testRemoveElementFromEmpty" self should: [ self empty remove: self nonEmptyWithoutEqualElements anyOne ] raise: Error! ! !BagTest methodsFor: 'tests - remove'! testRemoveElementReallyRemovesElement "self debug: #testRemoveElementReallyRemovesElement" | size | size := self nonEmptyWithoutEqualElements size. self nonEmptyWithoutEqualElements remove: self nonEmptyWithoutEqualElements anyOne. self assert: size - 1 = self nonEmptyWithoutEqualElements size! ! !BagTest methodsFor: 'tests - remove'! testRemoveElementThatExists "self debug: #testRemoveElementThatExists" | el res | el := self nonEmptyWithoutEqualElements anyOne. self shouldnt: [ res := self nonEmptyWithoutEqualElements remove: el ] raise: Error. self assert: res == el! ! !BagTest methodsFor: 'tests - remove'! testRemoveIfAbsent "self debug: #testRemoveElementThatExists" | el res | el := self elementNotIn. self shouldnt: [ res := self nonEmptyWithoutEqualElements remove: el ifAbsent: [ 33 ] ] raise: Error. self assert: res == 33! ! !BagTest methodsFor: 'tests - set arithmetic'! containsAll: union of: one andOf: another self assert: (one allSatisfy: [:each | union includes: each]). self assert: (another allSatisfy: [:each | union includes: each])! ! !BagTest methodsFor: 'tests - set arithmetic'! numberOfSimilarElementsInIntersection ^ self collection occurrencesOf: self anotherElementOrAssociationIn! ! !BagTest methodsFor: 'tests - set arithmetic'! testDifference "Answer the set theoretic difference of two collections." "self debug: #testDifference" self assert: (self collection difference: self collection) isEmpty. self assert: (self empty difference: self collection) isEmpty. self assert: (self collection difference: self empty) = self collection ! ! !BagTest methodsFor: 'tests - set arithmetic'! testDifferenceWithNonNullIntersection "Answer the set theoretic difference of two collections." "self debug: #testDifferenceWithNonNullIntersection" " #(1 2 3) difference: #(2 4) -> #(1 3)" | res overlapping | overlapping := self collectionClass with: self anotherElementOrAssociationNotIn with: self anotherElementOrAssociationIn. res := self collection difference: overlapping. self deny: (res includes: self anotherElementOrAssociationIn). overlapping do: [ :each | self deny: (res includes: each) ]! ! !BagTest methodsFor: 'tests - set arithmetic'! testDifferenceWithSeparateCollection "Answer the set theoretic difference of two collections." "self debug: #testDifferenceWithSeparateCollection" | res separateCol | separateCol := self collectionClass with: self anotherElementOrAssociationNotIn. res := self collection difference: separateCol. self deny: (res includes: self anotherElementOrAssociationNotIn). self assert: res = self collection. res := separateCol difference: self collection. self deny: (res includes: self collection anyOne). self assert: res = separateCol! ! !BagTest methodsFor: 'tests - set arithmetic'! testIntersectionBasic "self debug: #testIntersectionBasic" | inter | inter := self collection intersection: (self collectionClass with: self anotherElementOrAssociationIn). self deny: inter isEmpty. self assert: (inter includes: self anotherElementOrAssociationIn value)! ! !BagTest methodsFor: 'tests - set arithmetic'! testIntersectionEmpty "self debug: #testIntersectionEmpty" | inter | inter := self empty intersection: self empty. self assert: inter isEmpty. inter := self empty intersection: self collection . self assert: inter = self empty. ! ! !BagTest methodsFor: 'tests - set arithmetic'! testIntersectionItself "self debug: #testIntersectionItself" self assert: (self collection intersection: self collection) = self collection. ! ! !BagTest methodsFor: 'tests - set arithmetic'! testIntersectionTwoSimilarElementsInIntersection "self debug: #testIntersectionBasic" | inter | inter := self collection intersection: (self collectionClass with: self anotherElementOrAssociationIn). self assert: (self collection occurrencesOf: self anotherElementOrAssociationIn) = self numberOfSimilarElementsInIntersection. self assert: (inter includes: self anotherElementOrAssociationIn value)! ! !BagTest methodsFor: 'tests - set arithmetic'! testUnion "self debug: #testUnionOfEmpties" | union | union := self empty union: self nonEmpty. self containsAll: union of: self empty andOf: self nonEmpty. union := self nonEmpty union: self empty. self containsAll: union of: self empty andOf: self nonEmpty. union := self collection union: self nonEmpty. self containsAll: union of: self collection andOf: self nonEmpty.! ! !BagTest methodsFor: 'tests - set arithmetic'! testUnionOfEmpties "self debug: #testUnionOfEmpties" self assert: (self empty union: self empty) isEmpty. ! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! BagTest class uses: TAddTest classTrait + TCloneTest classTrait + TCopyTest classTrait + TSetArithmetic classTrait + TConvertTest classTrait + TAsStringCommaAndDelimiterTest classTrait + TRemoveForMultiplenessTest classTrait + TPrintTest classTrait + TConvertAsSortedTest classTrait + TIncludesWithIdentityCheckTest classTrait + TConvertAsSetForMultiplinessTest classTrait + TConcatenationTest classTrait + TStructuralEqualityTest classTrait + TCreationWithTest classTrait + TOccurrencesForMultiplinessTest classTrait instanceVariableNames: ''! Object subclass: #BalloonBezierSimulation instanceVariableNames: 'start end via lastX lastY fwDx fwDy fwDDx fwDDy maxSteps' classVariableNames: 'HeightSubdivisions LineConversions MonotonSubdivisions OverflowSubdivisions' poolDictionaries: '' category: 'Balloon-Simulation'! !BalloonBezierSimulation commentStamp: '' prior: 0! This class is a simulation of the code that's run by the Balloon engine. For debugging purposes only.! !BalloonBezierSimulation methodsFor: 'accessing' stamp: 'ar 10/27/1998 20:45'! end ^end! ! !BalloonBezierSimulation methodsFor: 'accessing' stamp: 'ar 10/27/1998 20:45'! end: aPoint end := aPoint! ! !BalloonBezierSimulation methodsFor: 'accessing' stamp: 'ar 10/30/1998 01:57'! inTangent "Return the tangent at the start point" ^via - start! ! !BalloonBezierSimulation methodsFor: 'accessing' stamp: 'ar 10/27/1998 20:45'! initialX ^start y <= end y ifTrue:[start x] ifFalse:[end x]! ! !BalloonBezierSimulation methodsFor: 'accessing' stamp: 'ar 10/27/1998 20:45'! initialY ^start y <= end y ifTrue:[start y] ifFalse:[end y]! ! !BalloonBezierSimulation methodsFor: 'accessing' stamp: 'ar 10/27/1998 20:45'! initialZ ^0 "Assume no depth given"! ! !BalloonBezierSimulation methodsFor: 'accessing' stamp: 'ar 10/30/1998 01:57'! outTangent "Return the tangent at the end point" ^end - via! ! !BalloonBezierSimulation methodsFor: 'accessing' stamp: 'ar 10/27/1998 20:45'! start ^start! ! !BalloonBezierSimulation methodsFor: 'accessing' stamp: 'ar 10/27/1998 20:45'! start: aPoint start := aPoint! ! !BalloonBezierSimulation methodsFor: 'accessing' stamp: 'ar 10/27/1998 20:45'! via ^via! ! !BalloonBezierSimulation methodsFor: 'accessing' stamp: 'ar 10/27/1998 20:45'! via: aPoint via := aPoint! ! !BalloonBezierSimulation methodsFor: 'computing' stamp: 'ar 10/27/1998 20:46'! computeInitialStateFrom: source with: transformation "Compute the initial state in the receiver." start := (transformation localPointToGlobal: source start) asIntegerPoint. end := (transformation localPointToGlobal: source end) asIntegerPoint. via := (transformation localPointToGlobal: source via) asIntegerPoint.! ! !BalloonBezierSimulation methodsFor: 'computing' stamp: 'ar 10/30/1998 02:39'! computeSplitAt: t "Split the receiver at the parametric value t" | left right newVia1 newVia2 newPoint | left := self clone. right := self clone. "Compute new intermediate points" newVia1 := (via - start) * t + start. newVia2 := (end - via) * t + via. "Compute new point on curve" newPoint := ((newVia1 - newVia2) * t + newVia2) asIntegerPoint. left via: newVia1 asIntegerPoint. left end: newPoint. right start: newPoint. right via: newVia2 asIntegerPoint. ^Array with: left with: right! ! !BalloonBezierSimulation methodsFor: 'computing' stamp: 'ar 10/30/1998 01:34'! floatStepToFirstScanLineAt: yValue in: edgeTableEntry "Float version of forward differencing" | startX endX startY endY deltaY fwX1 fwX2 fwY1 fwY2 steps scaledStepSize squaredStepSize | (end y) >= (start y) ifTrue:[ startX := start x. endX := end x. startY := start y. endY := end y. ] ifFalse:[ startX := end x. endX := start x. startY := end y. endY := start y. ]. deltaY := endY - startY. "Quickly check if the line is visible at all" (yValue >= endY or:[deltaY = 0]) ifTrue:[ ^edgeTableEntry lines: 0]. fwX1 := (startX + endX - (2 * via x)) asFloat. fwX2 := (via x - startX * 2) asFloat. fwY1 := (startY + endY - (2 * via y)) asFloat. fwY2 := ((via y - startY) * 2) asFloat. steps := deltaY asInteger * 2. scaledStepSize := 1.0 / steps asFloat. squaredStepSize := scaledStepSize * scaledStepSize. fwDx := fwX2 * scaledStepSize. fwDDx := 2.0 * fwX1 * squaredStepSize. fwDy := fwY2 * scaledStepSize. fwDDy := 2.0 * fwY1 * squaredStepSize. fwDx := fwDx + (fwDDx * 0.5). fwDy := fwDy + (fwDDy * 0.5). lastX := startX asFloat. lastY := startY asFloat. "self xDirection: xDir. self yDirection: yDir." edgeTableEntry xValue: startX. edgeTableEntry yValue: startY. edgeTableEntry zValue: 0. edgeTableEntry lines: deltaY. "If not at first scan line then step down to yValue" yValue = startY ifFalse:[ self stepToNextScanLineAt: yValue in: edgeTableEntry. "And adjust remainingLines" edgeTableEntry lines: deltaY - (yValue - startY). ].! ! !BalloonBezierSimulation methodsFor: 'computing' stamp: 'ar 10/30/1998 02:45'! floatStepToNextScanLineAt: yValue in: edgeTableEntry "Float version of forward differencing" [yValue asFloat > lastY] whileTrue:[ (fwDx < -50.0 or:[fwDx > 50.0]) ifTrue:[self halt]. (fwDy < -50.0 or:[fwDy > 50.0]) ifTrue:[self halt]. (fwDDx < -50.0 or:[fwDDx > 50.0]) ifTrue:[self halt]. (fwDDy < -50.0 or:[fwDDy > 50.0]) ifTrue:[self halt]. lastX := lastX + fwDx. lastY := lastY + fwDy. fwDx := fwDx + fwDDx. fwDy := fwDy + fwDDy. ]. edgeTableEntry xValue: lastX asInteger. edgeTableEntry zValue: 0.! ! !BalloonBezierSimulation methodsFor: 'computing' stamp: 'ar 10/30/1998 16:23'! intStepToFirstScanLineAt: yValue in: edgeTableEntry "Scaled integer version of forward differencing" | startX endX startY endY deltaY fwX1 fwX2 fwY1 fwY2 scaledStepSize squaredStepSize | (end y) >= (start y) ifTrue:[ startX := start x. endX := end x. startY := start y. endY := end y. ] ifFalse:[ startX := end x. endX := start x. startY := end y. endY := start y. ]. deltaY := endY - startY. "Quickly check if the line is visible at all" (yValue >= endY or:[deltaY = 0]) ifTrue:[ ^edgeTableEntry lines: 0]. fwX1 := (startX + endX - (2 * via x)). fwX2 := (via x - startX * 2). fwY1 := (startY + endY - (2 * via y)). fwY2 := ((via y - startY) * 2). maxSteps := deltaY asInteger * 2. scaledStepSize := 16r1000000 // maxSteps. "@@: Okay, we need some fancy 64bit multiplication here" squaredStepSize := self absoluteSquared8Dot24: scaledStepSize. squaredStepSize = ((scaledStepSize * scaledStepSize) bitShift: -24) ifFalse:[self error:'Bad computation']. fwDx := fwX2 * scaledStepSize. fwDDx := 2 * fwX1 * squaredStepSize. fwDy := fwY2 * scaledStepSize. fwDDy := 2 * fwY1 * squaredStepSize. fwDx := fwDx + (fwDDx // 2). fwDy := fwDy + (fwDDy // 2). self validateIntegerRange. lastX := startX * 256. lastY := startY * 256. edgeTableEntry xValue: startX. edgeTableEntry yValue: startY. edgeTableEntry zValue: 0. edgeTableEntry lines: deltaY. "If not at first scan line then step down to yValue" yValue = startY ifFalse:[ self stepToNextScanLineAt: yValue in: edgeTableEntry. "And adjust remainingLines" edgeTableEntry lines: deltaY - (yValue - startY). ].! ! !BalloonBezierSimulation methodsFor: 'computing' stamp: 'ar 10/30/1998 04:02'! intStepToNextScanLineAt: yValue in: edgeTableEntry "Scaled integer version of forward differencing" [maxSteps >= 0 and:[yValue * 256 > lastY]] whileTrue:[ self validateIntegerRange. lastX := lastX + ((fwDx + 16r8000) // 16r10000). lastY := lastY + ((fwDy + 16r8000) // 16r10000). fwDx := fwDx + fwDDx. fwDy := fwDy + fwDDy. maxSteps := maxSteps - 1. ]. edgeTableEntry xValue: lastX // 256. edgeTableEntry zValue: 0.! ! !BalloonBezierSimulation methodsFor: 'computing' stamp: 'ar 10/29/1998 22:14'! isMonoton "Return true if the receiver is monoton along the y-axis, e.g., check if the tangents have the same sign" ^(via y - start y) * (end y - via y) >= 0! ! !BalloonBezierSimulation methodsFor: 'computing' stamp: 'ar 10/31/1998 16:36'! stepToFirstScanLineAt: yValue in: edgeTableEntry "Compute the initial x value for the scan line at yValue" ^self intStepToFirstScanLineAt: yValue in: edgeTableEntry! ! !BalloonBezierSimulation methodsFor: 'computing' stamp: 'ar 10/30/1998 03:40'! stepToNextScanLineAt: yValue in: edgeTableEntry "Compute the next x value for the scan line at yValue. This message is sent during incremental updates. The yValue parameter is passed in here for edges that have more complicated computations," ^self intStepToNextScanLineAt: yValue in: edgeTableEntry! ! !BalloonBezierSimulation methodsFor: 'computing' stamp: 'ar 11/1/1998 00:31'! subdivide "Subdivide the receiver" | dy dx | "Test 1: If the bezier curve is not monoton in Y, we need a subdivision" self isMonoton ifFalse:[ MonotonSubdivisions := MonotonSubdivisions + 1. ^self subdivideToBeMonoton]. "Test 2: If the receiver is horizontal, don't do anything" (end y = start y) ifTrue:[^nil]. "Test 3: If the receiver can be represented as a straight line, make a line from the receiver and declare it invalid" ((end - start) crossProduct: (via - start)) = 0 ifTrue:[ LineConversions := LineConversions + 1. ^self subdivideToBeLine]. "Test 4: If the height of the curve exceeds 256 pixels, subdivide (forward differencing is numerically not very stable)" dy := end y - start y. dy < 0 ifTrue:[dy := dy negated]. (dy > 255) ifTrue:[ HeightSubdivisions := HeightSubdivisions + 1. ^self subdivideAt: 0.5]. "Test 5: Check if the incremental values could possibly overflow the scaled integer range" dx := end x - start x. dx < 0 ifTrue:[dx := dx negated]. dy * 32 < dx ifTrue:[ OverflowSubdivisions := OverflowSubdivisions + 1. ^self subdivideAt: 0.5]. ^nil! ! !BalloonBezierSimulation methodsFor: 'computing' stamp: 'ar 10/30/1998 22:13'! subdivideAt: parameter "Subdivide the receiver at the given parameter" | both | (parameter <= 0.0 or:[parameter >= 1.0]) ifTrue:[self halt]. both := self computeSplitAt: parameter. "Transcript cr. self quickPrint: self. Transcript space. self quickPrint: both first. Transcript space. self quickPrint: both last. Transcript endEntry." self via: both first via. self end: both first end. ^both last! ! !BalloonBezierSimulation methodsFor: 'computing' stamp: 'ar 11/11/1998 22:15'! subdivideToBeLine "Not a true subdivision. Just return a line representing the receiver and fake me to be of zero height" | line | line := BalloonLineSimulation new. line start: start. line end: end. "Make me invalid" end := start. via := start. ^line! ! !BalloonBezierSimulation methodsFor: 'computing' stamp: 'ar 10/30/1998 02:24'! subdivideToBeMonoton "Subdivide the receiver at it's extreme point" | v1 v2 t other | v1 := (via - start). v2 := (end - via). t := (v1 y / (v2 y - v1 y)) negated asFloat. other := self subdivideAt: t. self isMonoton ifFalse:[self halt]. other isMonoton ifFalse:[self halt]. ^other! ! !BalloonBezierSimulation methodsFor: 'private' stamp: 'ar 10/30/1998 16:37'! absoluteSquared8Dot24: value "Compute the squared value of a 8.24 number with 0.0 <= value < 1.0, e.g., compute (value * value) bitShift: -24" | halfWord1 halfWord2 result | (value >= 0 and:[value < 16r1000000]) ifFalse:[^self error:'Value out of range']. halfWord1 := value bitAnd: 16rFFFF. halfWord2 := (value bitShift: -16) bitAnd: 255. result := (halfWord1 * halfWord1) bitShift: -16. "We don't need the lower 16bits at all" result := result + ((halfWord1 * halfWord2) * 2). result := result + ((halfWord2 * halfWord2) bitShift: 16). "word1 := halfWord1 * halfWord1. word2 := (halfWord2 * halfWord1) + (word1 bitShift: -16). word1 := word1 bitAnd: 16rFFFF. word2 := word2 + (halfWord1 * halfWord2). word2 := word2 + ((halfWord2 * halfWord2) bitShift: 16)." ^result bitShift: -8! ! !BalloonBezierSimulation methodsFor: 'private' stamp: 'ar 5/25/2000 17:57'! debugDraw | entry minY maxY lX lY canvas | entry := BalloonEdgeData new. canvas := Display getCanvas. minY := (start y min: end y) min: via y. maxY := (start y max: end y) max: via y. entry yValue: minY. self stepToFirstScanLineAt: minY in: entry. lX := entry xValue. lY := entry yValue. minY+1 to: maxY do:[:y| self stepToNextScanLineAt: y in: entry. canvas line: lX@lY to: entry xValue @ y width: 2 color: Color black. lX := entry xValue. lY := y. ]. ! ! !BalloonBezierSimulation methodsFor: 'private' stamp: 'ar 5/25/2000 17:57'! debugDraw2 | canvas last max t next | canvas := Display getCanvas. max := 100. last := nil. 0 to: max do:[:i| t := i asFloat / max asFloat. next := self valueAt: t. last ifNotNil:[ canvas line: last to: next rounded width: 2 color: Color blue. ]. last := next rounded. ].! ! !BalloonBezierSimulation methodsFor: 'private' stamp: 'ar 5/25/2000 17:57'! debugDrawWide: n | entry minY maxY canvas curve p1 p2 entry2 y | curve := self class new. curve start: start + (0@n). curve via: via + (0@n). curve end: end + (0@n). entry := BalloonEdgeData new. entry2 := BalloonEdgeData new. canvas := Display getCanvas. minY := (start y min: end y) min: via y. maxY := (start y max: end y) max: via y. entry yValue: minY. entry2 yValue: minY + n. self stepToFirstScanLineAt: minY in: entry. curve stepToFirstScanLineAt: minY+n in: entry2. y := minY. 1 to: n do:[:i| y := y + 1. self stepToNextScanLineAt: y in: entry. p1 := entry xValue @ y. canvas line: p1 to: p1 + (n@0) width: 1 color: Color black. ]. [y < maxY] whileTrue:[ y := y + 1. self stepToNextScanLineAt: y in: entry. p2 := (entry xValue + n) @ y. curve stepToNextScanLineAt: y in: entry2. p1 := entry2 xValue @ y. canvas line: p1 to: p2 width: 1 color: Color black. ]. ! ! !BalloonBezierSimulation methodsFor: 'private' stamp: 'ar 10/30/1998 00:35'! printOn: aStream aStream nextPutAll: self class name; nextPut:$(; print: start; nextPutAll:' - '; print: via; nextPutAll:' - '; print: end; nextPut:$)! ! !BalloonBezierSimulation methodsFor: 'private' stamp: 'MPW 1/1/1901 21:55'! printOnStream: aStream aStream print: self class name; print:'('; write: start; print:' - '; write: via; print:' - '; write: end; print:')'.! ! !BalloonBezierSimulation methodsFor: 'private' stamp: 'ar 10/30/1998 21:56'! quickPrint: curve Transcript nextPut:$(; print: curve start; space; print: curve via; space; print: curve end; nextPut:$).! ! !BalloonBezierSimulation methodsFor: 'private' stamp: 'ar 10/30/1998 22:13'! quickPrint: curve first: aBool aBool ifTrue:[Transcript cr]. Transcript nextPut:$(; print: curve start; space; print: curve via; space; print: curve end; nextPut:$). Transcript endEntry.! ! !BalloonBezierSimulation methodsFor: 'private' stamp: 'ar 10/30/1998 03:53'! stepToFirst | startX endX startY endY deltaY fwX1 fwX2 fwY1 fwY2 steps scaledStepSize squaredStepSize | (end y) >= (start y) ifTrue:[ startX := start x. endX := end x. startY := start y. endY := end y. ] ifFalse:[ startX := end x. endX := start x. startY := end y. endY := start y. ]. deltaY := endY - startY. "Quickly check if the line is visible at all" (deltaY = 0) ifTrue:[^self]. fwX1 := (startX + endX - (2 * via x)) asFloat. fwX2 := (via x - startX * 2) asFloat. fwY1 := (startY + endY - (2 * via y)) asFloat. fwY2 := ((via y - startY) * 2) asFloat. steps := deltaY asInteger * 2. scaledStepSize := 1.0 / steps asFloat. squaredStepSize := scaledStepSize * scaledStepSize. fwDx := fwX2 * scaledStepSize. fwDDx := 2.0 * fwX1 * squaredStepSize. fwDy := fwY2 * scaledStepSize. fwDDy := 2.0 * fwY1 * squaredStepSize. fwDx := fwDx + (fwDDx * 0.5). fwDy := fwDy + (fwDDy * 0.5). lastX := startX asFloat. lastY := startY asFloat. ! ! !BalloonBezierSimulation methodsFor: 'private' stamp: 'ar 10/30/1998 03:50'! stepToFirstInt "Scaled integer version of forward differencing" | startX endX startY endY deltaY fwX1 fwX2 fwY1 fwY2 scaledStepSize squaredStepSize | self halt. (end y) >= (start y) ifTrue:[ startX := start x. endX := end x. startY := start y. endY := end y. ] ifFalse:[ startX := end x. endX := start x. startY := end y. endY := start y. ]. deltaY := endY - startY. "Quickly check if the line is visible at all" (deltaY = 0) ifTrue:[^nil]. fwX1 := (startX + endX - (2 * via x)). fwX2 := (via x - startX * 2). fwY1 := (startY + endY - (2 * via y)). fwY2 := ((via y - startY) * 2). maxSteps := deltaY asInteger * 2. scaledStepSize := 16r1000000 // maxSteps. "@@: Okay, we need some fancy 64bit multiplication here" squaredStepSize := (scaledStepSize * scaledStepSize) bitShift: -24. fwDx := fwX2 * scaledStepSize. fwDDx := 2 * fwX1 * squaredStepSize. fwDy := fwY2 * scaledStepSize. fwDDy := 2 * fwY1 * squaredStepSize. fwDx := fwDx + (fwDDx // 2). fwDy := fwDy + (fwDDy // 2). self validateIntegerRange. lastX := startX * 256. lastY := startY * 256. ! ! !BalloonBezierSimulation methodsFor: 'private' stamp: 'ar 10/30/1998 00:26'! stepToNext lastX := lastX + fwDx. lastY := lastY + fwDy. fwDx := fwDx + fwDDx. fwDy := fwDy + fwDDy.! ! !BalloonBezierSimulation methodsFor: 'private' stamp: 'ar 10/30/1998 04:01'! stepToNextInt "Scaled integer version of forward differencing" self halt. (maxSteps >= 0) ifTrue:[ self validateIntegerRange. lastX := lastX + ((fwDx + 16r8000) // 16r10000). lastY := lastY + ((fwDy + 16r8000) // 16r10000). fwDx := fwDx + fwDDx. fwDy := fwDy + fwDDy. maxSteps := maxSteps - 1. ].! ! !BalloonBezierSimulation methodsFor: 'private' stamp: 'ar 10/30/1998 03:27'! validateIntegerRange fwDx class == SmallInteger ifFalse:[self halt]. fwDy class == SmallInteger ifFalse:[self halt]. fwDDx class == SmallInteger ifFalse:[self halt]. fwDDy class == SmallInteger ifFalse:[self halt]. ! ! !BalloonBezierSimulation methodsFor: 'private' stamp: 'ar 10/29/1998 21:26'! valueAt: parameter "Return the point at the value parameter: p(t) = (1-t)^2 * p1 + 2*t*(1-t) * p2 + t^2 * p3. " | t1 t2 t3 | t1 := (1.0 - parameter) squared. t2 := 2 * parameter * (1.0 - parameter). t3 := parameter squared. ^(start * t1) + (via * t2) + (end * t3)! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! BalloonBezierSimulation class instanceVariableNames: ''! !BalloonBezierSimulation class methodsFor: 'initialization' stamp: 'MarcusDenker 9/30/2009 11:56'! initialize HeightSubdivisions := 0. LineConversions := 0. MonotonSubdivisions := 0. OverflowSubdivisions := 0.! ! Object variableWordSubclass: #BalloonBuffer instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Balloon-Engine'! !BalloonBuffer commentStamp: '' prior: 0! BalloonBuffer is a repository for primitive data used by the BalloonEngine.! !BalloonBuffer methodsFor: 'accessing' stamp: 'ar 10/26/1998 21:12'! at: index "For simulation only" | word | word := self basicAt: index. word < 16r3FFFFFFF ifTrue:[^word]. "Avoid LargeInteger computations" ^word >= 16r80000000 "Negative?!!" ifTrue:["word - 16r100000000" (word bitInvert32 + 1) negated] ifFalse:[word]! ! !BalloonBuffer methodsFor: 'accessing' stamp: 'ar 10/26/1998 21:12'! at: index put: anInteger "For simulation only" | word | anInteger < 0 ifTrue:["word := 16r100000000 + anInteger" word := (anInteger + 1) negated bitInvert32] ifFalse:[word := anInteger]. self basicAt: index put: word. ^anInteger! ! !BalloonBuffer methodsFor: 'accessing' stamp: 'ar 2/2/2001 15:47'! floatAt: index "For simulation only" ^Float fromIEEE32Bit: (self basicAt: index)! ! !BalloonBuffer methodsFor: 'accessing' stamp: 'ar 2/2/2001 15:47'! floatAt: index put: value "For simulation only" value isFloat ifTrue:[self basicAt: index put: value asIEEE32BitWord] ifFalse:[self at: index put: value asFloat]. ^value! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! BalloonBuffer class instanceVariableNames: ''! !BalloonBuffer class methodsFor: 'instance creation' stamp: 'ar 10/26/1998 21:11'! new ^self new: 256.! ! FormCanvas subclass: #BalloonCanvas instanceVariableNames: 'transform colorTransform engine aaLevel deferred' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Balloon'! !BalloonCanvas commentStamp: '' prior: 0! BalloonCanvas is a canvas using the BalloonEngine for drawing wherever possible. It has various methods which other canvases do not support due to the extra features of the balloon engine.! !BalloonCanvas methodsFor: '*Polymorph-Widgets' stamp: 'gvc 3/21/2008 16:46'! fillRectangle: aRectangle basicFillStyle: aFillStyle "Fill the given rectangle with the given, non-composite, fill style." ^self drawRectangle: aRectangle color: aFillStyle "@@: Name confusion!!!!!!" borderWidth: 0 borderColor: nil ! ! !BalloonCanvas methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 3/21/2008 16:46'! fillRectangle: aRectangle fillStyle: aFillStyle "Fill the given rectangle. Double-dispatched via the fill style." aFillStyle fillRectangle: aRectangle on: self! ! !BalloonCanvas methodsFor: 'accessing' stamp: 'ar 11/13/1998 01:02'! aaLevel ^aaLevel! ! !BalloonCanvas methodsFor: 'accessing' stamp: 'ar 12/30/1998 10:53'! aaLevel: newLevel "Only allow changes to aaLevel if we're working on >= 8 bit forms" form depth >= 8 ifFalse:[^self]. aaLevel = newLevel ifTrue:[^self]. self flush. "In case there are pending primitives in the engine" aaLevel := newLevel. engine ifNotNil:[engine aaLevel: aaLevel].! ! !BalloonCanvas methodsFor: 'accessing' stamp: 'ar 12/30/1998 10:54'! deferred ^deferred! ! !BalloonCanvas methodsFor: 'accessing' stamp: 'ar 12/30/1998 10:55'! deferred: aBoolean deferred == aBoolean ifTrue:[^self]. self flush. "Force pending prims on screen" deferred := aBoolean. engine ifNotNil:[engine deferred: aBoolean].! ! !BalloonCanvas methodsFor: 'accessing' stamp: 'ar 2/13/2001 21:07'! ensuredEngine engine ifNil:[ engine := BalloonEngine new. "engine := BalloonDebugEngine new" engine aaLevel: aaLevel. engine bitBlt: port. engine destOffset: origin. engine clipRect: clipRect. engine deferred: deferred. engine]. engine colorTransform: colorTransform. engine edgeTransform: transform. ^engine! ! !BalloonCanvas methodsFor: 'balloon drawing' stamp: 'DSM 10/15/1999 15:14'! drawBezier3Shape: vertices color: c borderWidth: borderWidth borderColor: borderColor self drawBezierShape: (Bezier3Segment convertBezier3ToBezier2: vertices) color: c borderWidth: borderWidth borderColor: borderColor! ! !BalloonCanvas methodsFor: 'balloon drawing' stamp: 'ar 2/17/2000 00:25'! drawBezierShape: vertices color: c borderWidth: borderWidth borderColor: borderColor "Draw a boundary shape that is defined by a list of vertices. Each three subsequent vertices define a quadratic bezier segment. For lines, the control point should be set to either the start or the end of the bezier curve." | fillC borderC | fillC := self shadowColor ifNil:[c]. borderC := self shadowColor ifNil:[borderColor]. self ensuredEngine drawBezierShape: vertices fill: fillC borderWidth: borderWidth borderColor: borderC transform: transform.! ! !BalloonCanvas methodsFor: 'balloon drawing' stamp: 'ar 11/24/1998 15:16'! drawCompressedShape: compressedShape "Draw a compressed shape" self ensuredEngine drawCompressedShape: compressedShape transform: transform.! ! !BalloonCanvas methodsFor: 'balloon drawing' stamp: 'DSM 10/15/1999 15:18'! drawGeneralBezier3Shape: contours color: c borderWidth: borderWidth borderColor: borderColor | b2 | b2 := contours collect: [:b3 | Bezier3Segment convertBezier3ToBezier2: b3 ]. self drawGeneralBezierShape: b2 color: c borderWidth: borderWidth borderColor: borderColor! ! !BalloonCanvas methodsFor: 'balloon drawing' stamp: 'ar 2/17/2000 00:24'! drawGeneralBezierShape: contours color: c borderWidth: borderWidth borderColor: borderColor "Draw a general boundary shape (e.g., possibly containing holes)" | fillC borderC | fillC := self shadowColor ifNil:[c]. borderC := self shadowColor ifNil:[borderColor]. self ensuredEngine drawGeneralBezierShape: contours fill: fillC borderWidth: borderWidth borderColor: borderC transform: transform.! ! !BalloonCanvas methodsFor: 'balloon drawing' stamp: 'ar 2/17/2000 00:24'! drawGeneralPolygon: contours color: c borderWidth: borderWidth borderColor: borderColor "Draw a general polygon (e.g., a polygon that can contain holes)" | fillC borderC | fillC := self shadowColor ifNil:[c]. borderC := self shadowColor ifNil:[borderColor]. self ensuredEngine drawGeneralPolygon: contours fill: fillC borderWidth: borderWidth borderColor: borderC transform: transform.! ! !BalloonCanvas methodsFor: 'balloon drawing' stamp: 'ar 2/17/2000 00:24'! drawOval: r color: c borderWidth: borderWidth borderColor: borderColor "Draw the oval defined by the given rectangle" | fillC borderC | fillC := self shadowColor ifNil:[c]. borderC := self shadowColor ifNil:[borderColor]. self ensuredEngine drawOval: r fill: fillC borderWidth: borderWidth borderColor: borderC transform: transform.! ! !BalloonCanvas methodsFor: 'balloon drawing' stamp: 'ar 2/17/2000 00:24'! drawRectangle: r color: c borderWidth: borderWidth borderColor: borderColor "Draw a rectangle" | fillC borderC | fillC := self shadowColor ifNil:[c]. borderC := self shadowColor ifNil:[borderColor]. self ensuredEngine drawRectangle: r fill: fillC borderWidth: borderWidth borderColor: borderC transform: transform.! ! !BalloonCanvas methodsFor: 'converting' stamp: 'ar 11/11/1998 22:57'! asBalloonCanvas ^self! ! !BalloonCanvas methodsFor: 'copying' stamp: 'ar 11/24/1998 22:33'! copy self flush. ^super copy resetEngine! ! !BalloonCanvas methodsFor: 'drawing' stamp: 'ar 2/9/1999 05:40'! fillColor: c "Note: This always fills, even if the color is transparent." "Note2: To achieve the above we must make sure that c is NOT transparent" self frameAndFillRectangle: form boundingBox fillColor: (c alpha: 1.0) borderWidth: 0 borderColor: nil! ! !BalloonCanvas methodsFor: 'drawing' stamp: 'ar 2/9/1999 05:51'! fillOval: r color: c borderWidth: borderWidth borderColor: borderColor "Draw a filled and outlined oval" "Note: The optimization test below should actually read: self ifNoTransformWithIn: (r insetBy: borderWidth // 2) but since borderWidth is assumed to be very small related to r we don't check it." (self ifNoTransformWithIn: r) ifTrue:[^super fillOval: r color: c borderWidth: borderWidth borderColor: borderColor]. ^self drawOval: (r insetBy: borderWidth // 2) color: c borderWidth: borderWidth borderColor: borderColor! ! !BalloonCanvas methodsFor: 'drawing' stamp: 'ar 2/9/1999 05:40'! fillRectangle: r color: c "Fill the rectangle with the given color" ^self frameAndFillRectangle: r fillColor: c borderWidth: 0 borderColor: nil! ! !BalloonCanvas methodsFor: 'drawing' stamp: 'ar 2/9/1999 06:26'! frameAndFillRectangle: r fillColor: c borderWidth: borderWidth borderColor: borderColor "Draw a filled and outlined rectangle" "Note: The optimization test below should actually read: self ifNoTransformWithIn: (r insetBy: borderWidth // 2) but since borderWidth is assumed to be very small related to r we don't check it." (self ifNoTransformWithIn: r) ifTrue:[^super frameAndFillRectangle: r fillColor: c borderWidth: borderWidth borderColor: borderColor]. ^self drawRectangle: (r insetBy: borderWidth // 2) color: c borderWidth: borderWidth borderColor: borderColor! ! !BalloonCanvas methodsFor: 'drawing' stamp: 'ar 2/9/1999 05:52'! frameAndFillRectangle: r fillColor: fillColor borderWidth: borderWidth topLeftColor: topLeftColor bottomRightColor: bottomRightColor "Draw a beveled or raised rectangle" | bw | "Note: The optimization test below should actually read: self ifNoTransformWithIn: (r insetBy: borderWidth // 2) but since borderWidth is assumed to be very small related to r we don't check it." (self ifNoTransformWithIn: r) ifTrue:[^super frameAndFillRectangle: r fillColor: fillColor borderWidth: borderWidth topLeftColor: topLeftColor bottomRightColor: bottomRightColor]. "Fill rectangle and draw top and left border" bw := borderWidth // 2. self drawRectangle: (r insetBy: bw) color: fillColor borderWidth: borderWidth borderColor: topLeftColor. "Now draw bottom right border." self drawPolygon: (Array with: r topRight + (bw negated@bw) with: r bottomRight - bw asPoint with: r bottomLeft + (bw@bw negated)) color: nil borderWidth: borderWidth borderColor: bottomRightColor.! ! !BalloonCanvas methodsFor: 'drawing' stamp: 'ar 2/12/1999 17:45'! line: pt1 to: pt2 width: w color: c "Draw a line from pt1 to: pt2" (self ifNoTransformWithIn:(pt1 rect: pt2)) ifTrue:[^super line: pt1 to: pt2 width: w color: c]. ^self drawPolygon: (Array with: pt1 with: pt2) color: c borderWidth: w borderColor: c! ! !BalloonCanvas methodsFor: 'drawing' stamp: 'ar 11/11/1998 19:39'! point: pt color: c "Is there any use for this?" | myPt | transform ifNil:[myPt := pt] ifNotNil:[myPt := transform localPointToGlobal: pt]. ^super point: myPt color: c! ! !BalloonCanvas methodsFor: 'drawing-ovals' stamp: 'ar 6/18/1999 08:50'! fillOval: aRectangle fillStyle: aFillStyle borderWidth: bw borderColor: bc "Fill the given rectangle." ^self drawOval: (aRectangle insetBy: bw // 2) color: aFillStyle "@@: Name confusion!!!!!!" borderWidth: bw borderColor: bc ! ! !BalloonCanvas methodsFor: 'drawing-polygons' stamp: 'ar 8/26/2001 22:14'! drawPolygon: vertices fillStyle: aFillStyle "Fill the given polygon." self drawPolygon: vertices fillStyle: aFillStyle borderWidth: 0 borderColor: nil! ! !BalloonCanvas methodsFor: 'drawing-polygons' stamp: 'ar 2/17/2000 00:25'! drawPolygon: vertices fillStyle: aFillStyle borderWidth: borderWidth borderColor: borderColor "Draw a simple polygon defined by the list of vertices." | fillC borderC | fillC := self shadowColor ifNil:[aFillStyle]. borderC := self shadowColor ifNil:[borderColor]. self ensuredEngine drawPolygon: (vertices copyWith: vertices first) fill: fillC borderWidth: borderWidth borderColor: borderC transform: transform.! ! !BalloonCanvas methodsFor: 'initialize' stamp: 'ar 11/24/1998 15:28'! flush "Force all pending primitives onscreen" engine ifNotNil:[engine flush].! ! !BalloonCanvas methodsFor: 'initialize' stamp: 'alain.plantec 5/28/2009 09:42'! initialize super initialize. aaLevel := 1. deferred := false.! ! !BalloonCanvas methodsFor: 'initialize' stamp: 'ar 11/11/1998 20:25'! resetEngine engine := nil.! ! !BalloonCanvas methodsFor: 'testing' stamp: 'ar 11/13/1998 13:19'! isBalloonCanvas ^true! ! !BalloonCanvas methodsFor: 'testing' stamp: 'ar 11/12/1998 01:07'! isVisible: aRectangle ^transform ifNil:[super isVisible: aRectangle] ifNotNil:[super isVisible: (transform localBoundsToGlobal: aRectangle)]! ! !BalloonCanvas methodsFor: 'todo' stamp: 'ar 12/31/2001 02:27'! drawString: s from: firstIndex to: lastIndex in: boundsRect font: fontOrNil color: c (self ifNoTransformWithIn: boundsRect) ifTrue:[^super drawString: s from: firstIndex to: lastIndex in: boundsRect font: fontOrNil color: c]! ! !BalloonCanvas methodsFor: 'todo' stamp: 'tween 3/10/2009 07:49'! drawString: s from: firstIndex to: lastIndex in: boundsRect font: fontOrNil color: c underline: underline underlineColor: uc strikethrough: strikethrough strikethroughColor: sc (self ifNoTransformWithIn: boundsRect) ifTrue:[^super drawString: s from: firstIndex to: lastIndex in: boundsRect font: fontOrNil color: c underline: underline underlineColor: uc strikethrough: strikethrough strikethroughColor: sc]! ! !BalloonCanvas methodsFor: 'todo' stamp: 'ar 2/9/1999 05:46'! line: point1 to: point2 brushForm: brush "Who's gonna use this?" | pt1 pt2 | self flush. "Sorry, but necessary..." transform ifNil:[pt1 := point1. pt2 := point2] ifNotNil:[pt1 := transform localPointToGlobal: point1. pt2 := transform localPointToGlobal: point2]. ^super line: pt1 to: pt2 brushForm: brush! ! !BalloonCanvas methodsFor: 'todo' stamp: 'ar 2/9/1999 05:46'! paragraph: para bounds: bounds color: c (self ifNoTransformWithIn: bounds) ifTrue:[^super paragraph: para bounds: bounds color: c].! ! !BalloonCanvas methodsFor: 'transforming' stamp: 'ar 11/24/1998 14:45'! colorTransformBy: aColorTransform aColorTransform ifNil:[^self]. colorTransform ifNil:[colorTransform := aColorTransform] ifNotNil:[colorTransform := colorTransform composedWithLocal: aColorTransform]! ! !BalloonCanvas methodsFor: 'transforming' stamp: 'ar 12/30/1998 10:47'! preserveStateDuring: aBlock | state result | state := BalloonState new. state transform: transform. state colorTransform: colorTransform. state aaLevel: self aaLevel. result := aBlock value: self. transform := state transform. colorTransform := state colorTransform. self aaLevel: state aaLevel. ^result! ! !BalloonCanvas methodsFor: 'transforming' stamp: 'ar 11/12/1998 00:32'! transformBy: aTransform aTransform ifNil:[^self]. transform ifNil:[transform := aTransform] ifNotNil:[transform := transform composedWithLocal: aTransform]! ! !BalloonCanvas methodsFor: 'transforming' stamp: 'ar 5/29/1999 08:59'! transformBy: aDisplayTransform during: aBlock | myTransform result | myTransform := transform. self transformBy: aDisplayTransform. result := aBlock value: self. transform := myTransform. ^result! ! !BalloonCanvas methodsFor: 'private' stamp: 'marcus.denker 9/14/2008 21:01'! ifNoTransformWithIn: box "Return true if the current transformation does not affect the given bounding box" | delta | transform ifNil: [^true]. delta := (transform localPointToGlobal: box origin) - box origin. ^(transform localPointToGlobal: box corner) - box corner = delta! ! !BalloonCanvas methodsFor: 'private' stamp: 'nk 5/1/2004 12:54'! image: aForm at: aPoint sourceRect: sourceRect rule: rule | warp dstRect srcQuad dstOffset center | (self ifNoTransformWithIn: sourceRect) & false ifTrue:[^super image: aForm at: aPoint sourceRect: sourceRect rule: rule]. dstRect := (transform localBoundsToGlobal: (aForm boundingBox translateBy: aPoint)). dstOffset := 0@0. "dstRect origin." "dstRect := 0@0 corner: dstRect extent." center := 0@0."transform globalPointToLocal: dstRect origin." srcQuad := transform globalPointsToLocal: (dstRect innerCorners). srcQuad := srcQuad collect:[:pt| pt - aPoint]. warp := (WarpBlt current toForm: form) sourceForm: aForm; cellSize: 2; "installs a new colormap if cellSize > 1" combinationRule: Form over. warp copyQuad: srcQuad toRect: (dstRect translateBy: dstOffset). self frameRectangle: (aForm boundingBox translateBy: aPoint) color: Color green. "... TODO ... create a bitmap fill style from the form and use it for a simple rectangle."! ! Object subclass: #BalloonEdgeData instanceVariableNames: 'index xValue yValue zValue lines source' classVariableNames: '' poolDictionaries: '' category: 'Balloon-Simulation'! !BalloonEdgeData commentStamp: '' prior: 0! BalloonEdgeData defines an entry in the internal edge table of the Balloon engine. Instance Variables: index The index into the external objects array of the associated graphics engine xValue The computed x-value of the requested operation yValue The y-value for the requested operation height The (remaining) height of the edge source The object from the external objects array! !BalloonEdgeData methodsFor: 'accessing' stamp: 'ar 10/27/1998 15:34'! index ^index! ! !BalloonEdgeData methodsFor: 'accessing' stamp: 'ar 10/27/1998 15:35'! index: anInteger index := anInteger! ! !BalloonEdgeData methodsFor: 'accessing' stamp: 'ar 10/27/1998 20:13'! lines ^lines! ! !BalloonEdgeData methodsFor: 'accessing' stamp: 'ar 10/27/1998 20:13'! lines: anInteger ^lines := anInteger! ! !BalloonEdgeData methodsFor: 'accessing' stamp: 'ar 10/27/1998 15:34'! source ^source! ! !BalloonEdgeData methodsFor: 'accessing' stamp: 'ar 10/27/1998 21:39'! source: anObject source := anObject! ! !BalloonEdgeData methodsFor: 'accessing' stamp: 'ar 10/27/1998 15:34'! xValue ^xValue! ! !BalloonEdgeData methodsFor: 'accessing' stamp: 'ar 10/27/1998 15:35'! xValue: anInteger xValue := anInteger! ! !BalloonEdgeData methodsFor: 'accessing' stamp: 'ar 10/27/1998 15:34'! yValue ^yValue! ! !BalloonEdgeData methodsFor: 'accessing' stamp: 'ar 10/27/1998 15:35'! yValue: anInteger yValue := anInteger! ! !BalloonEdgeData methodsFor: 'accessing' stamp: 'ar 10/27/1998 19:56'! zValue ^zValue! ! !BalloonEdgeData methodsFor: 'accessing' stamp: 'ar 10/27/1998 19:56'! zValue: anInteger zValue := anInteger! ! !BalloonEdgeData methodsFor: 'computing' stamp: 'ar 10/27/1998 15:53'! stepToFirstScanLine source stepToFirstScanLineAt: yValue in: self! ! !BalloonEdgeData methodsFor: 'computing' stamp: 'ar 10/27/1998 15:53'! stepToNextScanLine source stepToNextScanLineAt: yValue in: self! ! Object subclass: #BalloonEngine instanceVariableNames: 'workBuffer span bitBlt forms clipRect destOffset externals aaLevel edgeTransform colorTransform deferred postFlushNeeded' classVariableNames: 'BezierStats BufferCache CacheProtect Counts Debug Times' poolDictionaries: 'BalloonEngineConstants' category: 'Balloon-Engine'! !BalloonEngine commentStamp: '' prior: 0! BalloonEngine is the representative for the Balloon engine inside Squeak. For most purposes it should not be used directly but via BalloonCanvas since this ensures proper initialization and is polymorphic with other canvas uses.! !BalloonEngine methodsFor: 'accessing' stamp: 'ar 11/11/1998 23:04'! aaLevel ^aaLevel ifNil:[1]! ! !BalloonEngine methodsFor: 'accessing' stamp: 'ar 11/11/1998 23:04'! aaLevel: anInteger aaLevel := (anInteger min: 4) max: 1.! ! !BalloonEngine methodsFor: 'accessing' stamp: 'ar 10/29/1998 01:51'! aaTransform "Return a transformation for the current anti-aliasing level" | matrix | matrix := MatrixTransform2x3 withScale: (self aaLevel) asFloat asPoint. matrix offset: (self aaLevel // 2) asFloat asPoint. ^matrix composedWith:(MatrixTransform2x3 withOffset: destOffset asFloatPoint)! ! !BalloonEngine methodsFor: 'accessing' stamp: 'ar 10/13/1998 03:04'! bitBlt ^bitBlt! ! !BalloonEngine methodsFor: 'accessing' stamp: 'ar 5/28/2000 15:02'! bitBlt: aBitBlt bitBlt := aBitBlt. bitBlt isNil ifTrue:[^self]. self class primitiveSetBitBltPlugin: bitBlt getPluginName. self clipRect: bitBlt clipRect. bitBlt sourceForm: (Form extent: span size @ 1 depth: 32 bits: span); sourceRect: (0@0 extent: 1@span size); colorMap: (Color colorMapIfNeededFrom: 32 to: bitBlt destForm depth); combinationRule: (bitBlt destForm depth >= 8 ifTrue:[34] ifFalse:[Form paint]).! ! !BalloonEngine methodsFor: 'accessing' stamp: 'ar 11/1/1998 02:57'! clipRect ^clipRect! ! !BalloonEngine methodsFor: 'accessing' stamp: 'ar 10/13/1998 02:44'! clipRect: aRect clipRect := aRect truncated! ! !BalloonEngine methodsFor: 'accessing' stamp: 'ar 11/24/1998 15:04'! colorTransform ^colorTransform! ! !BalloonEngine methodsFor: 'accessing' stamp: 'ar 11/24/1998 15:04'! colorTransform: aColorTransform colorTransform := aColorTransform! ! !BalloonEngine methodsFor: 'accessing' stamp: 'ar 12/30/1998 11:24'! deferred ^deferred! ! !BalloonEngine methodsFor: 'accessing' stamp: 'ar 12/30/1998 11:24'! deferred: aBoolean deferred := aBoolean.! ! !BalloonEngine methodsFor: 'accessing' stamp: 'ar 11/1/1998 02:56'! destOffset ^destOffset! ! !BalloonEngine methodsFor: 'accessing' stamp: 'ar 11/12/1998 00:22'! destOffset: aPoint destOffset := aPoint asIntegerPoint. bitBlt destX: aPoint x; destY: aPoint y.! ! !BalloonEngine methodsFor: 'accessing' stamp: 'ar 11/25/1998 22:34'! edgeTransform ^edgeTransform! ! !BalloonEngine methodsFor: 'accessing' stamp: 'ar 11/25/1998 22:34'! edgeTransform: aTransform edgeTransform := aTransform.! ! !BalloonEngine methodsFor: 'accessing' stamp: 'ar 10/29/1998 01:51'! fullTransformFrom: aMatrix | m | m := self aaTransform composedWith: aMatrix. "m offset: m offset + destOffset." ^m! ! !BalloonEngine methodsFor: 'copying' stamp: 'ar 11/25/1998 00:45'! canProceedAfter: failureReason "Check if we can proceed after the failureReason indicated." | newBuffer | failureReason = GErrorNeedFlush ifTrue:[ "Need to flush engine before proceeding" self copyBits. self reset. ^true]. failureReason = GErrorNoMoreSpace ifTrue:[ "Work buffer is too small" newBuffer := workBuffer species new: workBuffer size * 2. self primCopyBufferFrom: workBuffer to: newBuffer. workBuffer := newBuffer. ^true]. "Not handled" ^false! ! !BalloonEngine methodsFor: 'copying' stamp: 'ar 3/6/2001 12:06'! copyBits (bitBlt notNil and:[bitBlt destForm notNil]) ifTrue:[bitBlt destForm unhibernate]. self copyLoopFaster.! ! !BalloonEngine methodsFor: 'copying' stamp: 'ar 11/14/1998 19:32'! copyLoop "This is the basic rendering loop using as little primitive support as possible." | finished edge fill | edge := BalloonEdgeData new. fill := BalloonFillData new. self primInitializeProcessing. "Initialize the GE for processing" [self primFinishedProcessing] whileFalse:[ "Step 1: Process the edges in the global edge table that will be added in this step" [finished := self primNextGlobalEdgeEntryInto: edge. finished] whileFalse:[ edge source: (externals at: edge index). edge stepToFirstScanLine. self primAddActiveEdgeTableEntryFrom: edge]. "Step 2: Scan the active edge table" [finished := self primNextFillEntryInto: fill. finished] whileFalse:[ fill source: (externals at: fill index). "Compute the new fill" fill computeFill. "And mix it in the out buffer" self primMergeFill: fill destForm bits from: fill]. "Step 3: Display the current span buffer if necessary" self primDisplaySpanBuffer. "Step 4: Advance and resort the active edge table" [finished := self primNextActiveEdgeEntryInto: edge. finished] whileFalse:[ "If the index is zero then the edge has been handled by the GE" edge source: (externals at: edge index). edge stepToNextScanLine. self primChangeActiveEdgeTableEntryFrom: edge]. ]. self primGetTimes: Times. self primGetCounts: Counts. self primGetBezierStats: BezierStats.! ! !BalloonEngine methodsFor: 'copying' stamp: 'ar 11/14/1998 19:32'! copyLoopFaster "This is a copy loop drawing one scan line at a time" | edge fill reason | edge := BalloonEdgeData new. fill := BalloonFillData new. [self primFinishedProcessing] whileFalse:[ reason := self primRenderScanline: edge with: fill. "reason ~= 0 means there has been a problem" reason = 0 ifFalse:[ self processStopReason: reason edge: edge fill: fill. ]. ]. self primGetTimes: Times. self primGetCounts: Counts. self primGetBezierStats: BezierStats.! ! !BalloonEngine methodsFor: 'copying' stamp: 'ar 11/14/1998 19:33'! copyLoopFastest "This is a copy loop drawing the entire image" | edge fill reason | edge := BalloonEdgeData new. fill := BalloonFillData new. [self primFinishedProcessing] whileFalse:[ reason := self primRenderImage: edge with: fill. "reason ~= 0 means there has been a problem" reason = 0 ifFalse:[ self processStopReason: reason edge: edge fill: fill. ]. ]. self primGetTimes: Times. self primGetCounts: Counts. self primGetBezierStats: BezierStats.! ! !BalloonEngine methodsFor: 'copying' stamp: 'ar 11/11/1998 21:19'! processStopReason: reason edge: edge fill: fill "The engine has stopped because of some reason. Try to figure out how to respond and do the necessary actions." "Note: The order of operations below can affect the speed" "Process unknown fills first" reason = GErrorFillEntry ifTrue:[ fill source: (externals at: fill index). "Compute the new fill" fill computeFill. "And mix it in the out buffer" ^self primMergeFill: fill destForm bits from: fill]. "Process unknown steppings in the AET second" reason = GErrorAETEntry ifTrue:[ edge source: (externals at: edge index). edge stepToNextScanLine. ^self primChangeActiveEdgeTableEntryFrom: edge]. "Process unknown entries in the GET third" reason = GErrorGETEntry ifTrue:[ edge source: (externals at: edge index). edge stepToFirstScanLine. ^self primAddActiveEdgeTableEntryFrom: edge]. "Process generic problems last" (self canProceedAfter: reason) ifTrue:[^self]. "Okay." ^self error:'Unkown stop reason in graphics engine' ! ! !BalloonEngine methodsFor: 'drawing' stamp: 'ar 10/11/1999 16:49'! drawBezierShape: points fill: fillStyle borderWidth: borderWidth borderColor: borderFill transform: aTransform | fills | self edgeTransform: aTransform. self resetIfNeeded. fills := self registerFill: fillStyle and: borderFill. self primAddBezierShape: points segments: (points size) // 3 fill: (fills at: 1) lineWidth: borderWidth lineFill: (fills at: 2). self postFlushIfNeeded.! ! !BalloonEngine methodsFor: 'drawing' stamp: 'ar 11/26/1998 19:44'! drawCompressedShape: shape transform: aTransform | fillIndexList | self edgeTransform: aTransform. self resetIfNeeded. fillIndexList := self registerFills: shape fillStyles. self primAddCompressedShape: shape points segments: shape numSegments leftFills: shape leftFills rightFills: shape rightFills lineWidths: shape lineWidths lineFills: shape lineFills fillIndexList: fillIndexList. self postFlushIfNeeded.! ! !BalloonEngine methodsFor: 'drawing' stamp: 'ar 1/15/1999 03:02'! drawGeneralBezierShape: contours fill: fillStyle borderWidth: borderWidth borderColor: borderFill transform: aTransform | fills | self edgeTransform: aTransform. self resetIfNeeded. fills := self registerFill: fillStyle and: borderFill. contours do:[:points| self primAddBezierShape: points segments: (points size // 3) fill: (fills at: 1) lineWidth: borderWidth lineFill: (fills at: 2). "Note: To avoid premature flushing of the pipeline we need to reset the flush bit within the engine." self primFlushNeeded: false. ]. "And set the flush bit afterwards" self primFlushNeeded: true. self postFlushIfNeeded.! ! !BalloonEngine methodsFor: 'drawing' stamp: 'ar 1/15/1999 03:02'! drawGeneralPolygon: contours fill: fillStyle borderWidth: borderWidth borderColor: borderFill transform: aTransform | fills | self edgeTransform: aTransform. self resetIfNeeded. fills := self registerFill: fillStyle and: borderFill. contours do:[:points| self primAddPolygon: points segments: points size fill: (fills at: 1) lineWidth: borderWidth lineFill: (fills at: 2). "Note: To avoid premature flushing of the pipeline we need to reset the flush bit within the engine." self primFlushNeeded: false. ]. "And set the flush bit afterwards" self primFlushNeeded: true. self postFlushIfNeeded.! ! !BalloonEngine methodsFor: 'drawing' stamp: 'ar 11/26/1998 19:45'! drawOval: rect fill: fillStyle borderWidth: borderWidth borderColor: borderColor transform: aMatrix | fills | self edgeTransform: aMatrix. self resetIfNeeded. fills := self registerFill: fillStyle and: borderColor. self primAddOvalFrom: rect origin to: rect corner fillIndex: (fills at: 1) borderWidth: borderWidth borderColor: (fills at: 2). self postFlushIfNeeded.! ! !BalloonEngine methodsFor: 'drawing' stamp: 'ar 11/26/1998 19:45'! drawPolygon: points fill: fillStyle borderWidth: borderWidth borderColor: borderFill transform: aTransform | fills | self edgeTransform: aTransform. self resetIfNeeded. fills := self registerFill: fillStyle and: borderFill. self primAddPolygon: points segments: points size fill: (fills at: 1) lineWidth: borderWidth lineFill: (fills at: 2). self postFlushIfNeeded.! ! !BalloonEngine methodsFor: 'drawing' stamp: 'ar 11/26/1998 19:45'! drawRectangle: rect fill: fillStyle borderWidth: borderWidth borderColor: borderColor transform: aMatrix | fills | self edgeTransform: aMatrix. self resetIfNeeded. fills := self registerFill: fillStyle and: borderColor. self primAddRectFrom: rect origin to: rect corner fillIndex: (fills at: 1) borderWidth: borderWidth borderColor: (fills at: 2). self postFlushIfNeeded.! ! !BalloonEngine methodsFor: 'drawing' stamp: 'bf 4/3/2004 01:36'! registerFill: aFillStyle "Register the given fill style." | theForm | aFillStyle ifNil:[^0]. aFillStyle isSolidFill ifTrue:[^aFillStyle scaledPixelValue32]. aFillStyle isGradientFill ifTrue:[ ^self primAddGradientFill: aFillStyle pixelRamp from: aFillStyle origin along: aFillStyle direction normal: aFillStyle normal radial: aFillStyle isRadialFill ]. aFillStyle isBitmapFill ifTrue:[ theForm := aFillStyle form asSourceForm. theForm unhibernate. forms := forms copyWith: theForm. ^self primAddBitmapFill: theForm colormap: (theForm colormapIfNeededForDepth: 32) tile: aFillStyle isTiled from: aFillStyle origin along: aFillStyle direction normal: aFillStyle normal xIndex: forms size]. ^0! ! !BalloonEngine methodsFor: 'drawing' stamp: 'ar 11/26/1998 19:45'! registerFill: fill1 and: fill2 ^self registerFills: (Array with: fill1 with: fill2)! ! !BalloonEngine methodsFor: 'drawing' stamp: 'di 11/21/1999 20:15'! registerFills: fills | fillIndexList index fillIndex | ((colorTransform notNil and:[colorTransform isAlphaTransform]) or:[ fills anySatisfy: [:any| any notNil and:[any isTranslucent]]]) ifTrue:[ self flush. self reset. postFlushNeeded := true]. fillIndexList := WordArray new: fills size. index := 1. [index <= fills size] whileTrue:[ fillIndex := self registerFill: (fills at: index). fillIndex == nil ifTrue:[index := 1] "Need to start over" ifFalse:[fillIndexList at: index put: fillIndex. index := index+1] ]. ^fillIndexList! ! !BalloonEngine methodsFor: 'initialize' stamp: 'ar 11/25/1998 22:29'! flush "Force all pending primitives onscreen" workBuffer ifNil:[^self]. self copyBits. self release.! ! !BalloonEngine methodsFor: 'initialize' stamp: 'stephane.ducasse 6/14/2009 22:37'! initialize | w | super initialize. w := Display width > 2048 ifTrue: [ 4096 ] ifFalse: [ 2048 ]. externals := OrderedCollection new: 100. span := Bitmap new: w. bitBlt := nil. self bitBlt: ((BitBlt toForm: Display) destRect: Display boundingBox; yourself). forms := #(). deferred := false.! ! !BalloonEngine methodsFor: 'initialize' stamp: 'ar 11/25/1998 22:42'! postFlushIfNeeded "Force all pending primitives onscreen" workBuffer ifNil:[^self]. (deferred not or:[postFlushNeeded]) ifTrue:[ self copyBits. self release].! ! !BalloonEngine methodsFor: 'initialize' stamp: 'ar 11/25/1998 22:43'! preFlushIfNeeded "Force all pending primitives onscreen" workBuffer ifNil:[^self]. self primFlushNeeded ifTrue:[ self copyBits. self reset].! ! !BalloonEngine methodsFor: 'initialize' stamp: 'ar 11/11/1998 22:52'! release self class recycleBuffer: workBuffer. workBuffer := nil.! ! !BalloonEngine methodsFor: 'initialize' stamp: 'ar 11/25/1998 22:34'! reset workBuffer ifNil:[workBuffer := self class allocateOrRecycleBuffer: 10000]. self primInitializeBuffer: workBuffer. self primSetAALevel: self aaLevel. self primSetOffset: destOffset. self primSetClipRect: clipRect. self primSetEdgeTransform: edgeTransform. self primSetColorTransform: colorTransform. forms := #().! ! !BalloonEngine methodsFor: 'initialize' stamp: 'ar 11/25/1998 22:39'! resetIfNeeded workBuffer ifNil:[self reset]. self primSetEdgeTransform: edgeTransform. self primSetColorTransform: colorTransform. self primSetDepth: self primGetDepth + 1. postFlushNeeded := false.! ! !BalloonEngine methodsFor: 'primitives-access' stamp: 'ar 2/2/2001 15:48'! primClipRectInto: rect ^self primitiveFailed! ! !BalloonEngine methodsFor: 'primitives-access' stamp: 'ar 2/2/2001 15:47'! primFlushNeeded ^self primitiveFailed! ! !BalloonEngine methodsFor: 'primitives-access' stamp: 'ar 2/2/2001 15:47'! primFlushNeeded: aBoolean ^self primitiveFailed! ! !BalloonEngine methodsFor: 'primitives-access' stamp: 'ar 2/2/2001 15:49'! primGetAALevel "Set the AA level" ^self primitiveFailed! ! !BalloonEngine methodsFor: 'primitives-access' stamp: 'ar 2/2/2001 15:49'! primGetBezierStats: statsArray ^self primitiveFailed! ! !BalloonEngine methodsFor: 'primitives-access' stamp: 'ar 2/2/2001 15:49'! primGetClipRect: rect ^self primitiveFailed! ! !BalloonEngine methodsFor: 'primitives-access' stamp: 'ar 2/2/2001 15:49'! primGetCounts: statsArray ^self primitiveFailed! ! !BalloonEngine methodsFor: 'primitives-access' stamp: 'ar 2/2/2001 15:47'! primGetDepth ^self primitiveFailed! ! !BalloonEngine methodsFor: 'primitives-access' stamp: 'ar 2/2/2001 15:49'! primGetFailureReason ^0! ! !BalloonEngine methodsFor: 'primitives-access' stamp: 'ar 2/2/2001 15:49'! primGetOffset ^self primitiveFailed! ! !BalloonEngine methodsFor: 'primitives-access' stamp: 'ar 2/2/2001 15:49'! primGetTimes: statsArray ^self primitiveFailed! ! !BalloonEngine methodsFor: 'primitives-access' stamp: 'ar 2/2/2001 15:49'! primSetAALevel: level "Set the AA level" ^self primitiveFailed! ! !BalloonEngine methodsFor: 'primitives-access' stamp: 'ar 2/2/2001 15:49'! primSetClipRect: rect ^self primitiveFailed! ! !BalloonEngine methodsFor: 'primitives-access' stamp: 'ar 2/2/2001 15:47'! primSetColorTransform: transform ^self primitiveFailed! ! !BalloonEngine methodsFor: 'primitives-access' stamp: 'ar 2/2/2001 15:47'! primSetDepth: depth ^self primitiveFailed! ! !BalloonEngine methodsFor: 'primitives-access' stamp: 'ar 2/2/2001 15:47'! primSetEdgeTransform: transform ^self primitiveFailed! ! !BalloonEngine methodsFor: 'primitives-access' stamp: 'ar 2/2/2001 15:49'! primSetOffset: point ^self primitiveFailed! ! !BalloonEngine methodsFor: 'primitives-adding' stamp: 'ar 2/2/2001 15:47'! primAddBezierFrom: start to: end via: via leftFillIndex: leftFillIndex rightFillIndex: rightFillIndex (self canProceedAfter: self primGetFailureReason) ifTrue:[ ^self primAddBezierFrom: start to: end via: via leftFillIndex: leftFillIndex rightFillIndex: rightFillIndex ]. ^self primitiveFailed! ! !BalloonEngine methodsFor: 'primitives-adding' stamp: 'ar 2/2/2001 15:47'! primAddBezierShape: points segments: nSegments fill: fillStyle lineWidth: lineWidth lineFill: lineFill (self canProceedAfter: self primGetFailureReason) ifTrue:[ ^self primAddBezierShape: points segments: nSegments fill: fillStyle lineWidth: lineWidth lineFill: lineFill ]. ^self primitiveFailed! ! !BalloonEngine methodsFor: 'primitives-adding' stamp: 'ar 2/2/2001 15:47'! primAddBitmapFill: form colormap: cmap tile: tileFlag from: origin along: direction normal: normal xIndex: xIndex (self canProceedAfter: self primGetFailureReason) ifTrue:[ ^self primAddBitmapFill: form colormap: cmap tile: tileFlag from: origin along: direction normal: normal xIndex: xIndex ]. ^self primitiveFailed! ! !BalloonEngine methodsFor: 'primitives-adding' stamp: 'ar 2/2/2001 15:47'! primAddCompressedShape: points segments: nSegments leftFills: leftFills rightFills: rightFills lineWidths: lineWidths lineFills: lineFills fillIndexList: fillIndexList (self canProceedAfter: self primGetFailureReason) ifTrue:[ ^self primAddCompressedShape: points segments: nSegments leftFills: leftFills rightFills: rightFills lineWidths: lineWidths lineFills: lineFills fillIndexList: fillIndexList ]. ^self primitiveFailed! ! !BalloonEngine methodsFor: 'primitives-adding' stamp: 'ar 2/2/2001 15:47'! primAddExternalEdge: index initialX: initialX initialY: initialY initialZ: initialZ leftFillIndex: leftFillIndex rightFillIndex: rightFillIndex (self canProceedAfter: self primGetFailureReason) ifTrue:[ ^self primAddExternalEdge: index initialX: initialX initialY: initialY initialZ: initialZ leftFillIndex: leftFillIndex rightFillIndex: rightFillIndex ]. ^self primitiveFailed! ! !BalloonEngine methodsFor: 'primitives-adding' stamp: 'ar 2/2/2001 15:47'! primAddExternalFill: index (self canProceedAfter: self primGetFailureReason) ifTrue:[ ^self primAddExternalFill: index ]. ^self primitiveFailed! ! !BalloonEngine methodsFor: 'primitives-adding' stamp: 'ar 2/2/2001 15:47'! primAddGradientFill: colorRamp from: origin along: direction normal: normal radial: isRadial (self canProceedAfter: self primGetFailureReason) ifTrue:[ ^self primAddGradientFill: colorRamp from: origin along: direction normal: normal radial: isRadial ]. ^self primitiveFailed! ! !BalloonEngine methodsFor: 'primitives-adding' stamp: 'ar 2/2/2001 15:47'! primAddLineFrom: start to: end leftFillIndex: leftFillIndex rightFillIndex: rightFillIndex (self canProceedAfter: self primGetFailureReason) ifTrue:[ ^self primAddLineFrom: start to: end leftFillIndex: leftFillIndex rightFillIndex: rightFillIndex ]. ^self primitiveFailed! ! !BalloonEngine methodsFor: 'primitives-adding' stamp: 'ar 2/2/2001 15:47'! primAddOvalFrom: start to: end fillIndex: fillIndex borderWidth: width borderColor: pixelValue32 (self canProceedAfter: self primGetFailureReason) ifTrue:[ ^self primAddOvalFrom: start to: end fillIndex: fillIndex borderWidth: width borderColor: pixelValue32 ]. ^self primitiveFailed! ! !BalloonEngine methodsFor: 'primitives-adding' stamp: 'ar 2/2/2001 15:47'! primAddPolygon: points segments: nSegments fill: fillStyle lineWidth: lineWidth lineFill: lineFill (self canProceedAfter: self primGetFailureReason) ifTrue:[ ^self primAddPolygon: points segments: nSegments fill: fillStyle lineWidth: lineWidth lineFill: lineFill ]. ^self primitiveFailed! ! !BalloonEngine methodsFor: 'primitives-adding' stamp: 'ar 2/2/2001 15:47'! primAddRectFrom: start to: end fillIndex: fillIndex borderWidth: width borderColor: pixelValue32 (self canProceedAfter: self primGetFailureReason) ifTrue:[ ^self primAddRectFrom: start to: end fillIndex: fillIndex borderWidth: width borderColor: pixelValue32 ]. ^self primitiveFailed! ! !BalloonEngine methodsFor: 'primitives-incremental' stamp: 'ar 2/2/2001 15:48'! primAddActiveEdgeTableEntryFrom: edgeEntry "Add edge entry to the AET." (self canProceedAfter: self primGetFailureReason) ifTrue:[ ^self primAddActiveEdgeTableEntryFrom: edgeEntry ]. ^self primitiveFailed! ! !BalloonEngine methodsFor: 'primitives-incremental' stamp: 'ar 2/2/2001 15:48'! primChangeActiveEdgeTableEntryFrom: edgeEntry "Change the entry in the active edge table from edgeEntry" ^self primitiveFailed! ! !BalloonEngine methodsFor: 'primitives-incremental' stamp: 'ar 2/2/2001 15:48'! primDisplaySpanBuffer "Display the current scan line if necessary" ^self primitiveFailed! ! !BalloonEngine methodsFor: 'primitives-incremental' stamp: 'ar 2/2/2001 15:49'! primFinishedProcessing "Return true if there are no more entries in AET and GET and the last scan line has been displayed" ^self primitiveFailed! ! !BalloonEngine methodsFor: 'primitives-incremental' stamp: 'ar 2/2/2001 15:49'! primInitializeProcessing "Initialize processing in the GE. Create the active edge table and sort it." ^self primitiveFailed! ! !BalloonEngine methodsFor: 'primitives-incremental' stamp: 'ar 2/2/2001 15:49'! primMergeFill: fillBitmap from: fill "Merge the filled bitmap into the current output buffer." ^self primitiveFailed! ! !BalloonEngine methodsFor: 'primitives-incremental' stamp: 'ar 2/2/2001 15:49'! primNextActiveEdgeEntryInto: edgeEntry "Store the next entry of the AET at the current y-value in edgeEntry. Return false if there is no entry, true otherwise." ^self primitiveFailed! ! !BalloonEngine methodsFor: 'primitives-incremental' stamp: 'ar 2/2/2001 15:49'! primNextFillEntryInto: fillEntry "Store the next fill entry of the active edge table in fillEntry. Return false if there is no such entry, true otherwise" ^self primitiveFailed! ! !BalloonEngine methodsFor: 'primitives-incremental' stamp: 'ar 2/2/2001 15:49'! primNextGlobalEdgeEntryInto: edgeEntry "Store the next entry of the GET at the current y-value in edgeEntry. Return false if there is no entry, true otherwise." ^self primitiveFailed! ! !BalloonEngine methodsFor: 'primitives-incremental' stamp: 'ar 2/2/2001 15:49'! primRenderImage: edge with: fill "Start/Proceed rendering the current scan line" ^self primitiveFailed! ! !BalloonEngine methodsFor: 'primitives-incremental' stamp: 'ar 2/2/2001 15:49'! primRenderScanline: edge with: fill "Start/Proceed rendering the current scan line" ^self primitiveFailed! ! !BalloonEngine methodsFor: 'primitives-misc' stamp: 'ar 2/2/2001 15:48'! primCopyBufferFrom: oldBuffer to: newBuffer "Copy the contents of oldBuffer into the (larger) newBuffer" ^self primitiveFailed! ! !BalloonEngine methodsFor: 'primitives-misc' stamp: 'ar 2/2/2001 15:49'! primInitializeBuffer: buffer ^self primitiveFailed! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! BalloonEngine class instanceVariableNames: ''! !BalloonEngine class methodsFor: 'accessing' stamp: 'ar 10/25/1998 17:37'! debug: aBoolean "BalloonEngine debug: true" "BalloonEngine debug: false" Debug := aBoolean! ! !BalloonEngine class methodsFor: 'accessing' stamp: 'ar 2/2/2001 15:47'! doProfileStats: aBool "Note: On Macintosh systems turning on profiling can significantly degrade the performance of Balloon since we're using the high accuracy timer for measuring." "BalloonEngine doProfileStats: true" "BalloonEngine doProfileStats: false" ^false! ! !BalloonEngine class methodsFor: 'accessing' stamp: 'ar 10/30/1998 23:57'! printBezierStats "BalloonEngine printBezierStats" "BalloonEngine resetBezierStats" Transcript cr; nextPutAll:'Bezier statistics:'; crtab; print: (BezierStats at: 1); tab; nextPutAll:' non-monoton curves splitted'; crtab; print: (BezierStats at: 2); tab; nextPutAll:' curves splitted for numerical accuracy'; crtab; print: (BezierStats at: 3); tab; nextPutAll:' curves splitted to avoid integer overflow'; crtab; print: (BezierStats at: 4); tab; nextPutAll:' curves internally converted to lines'; endEntry.! ! !BalloonEngine class methodsFor: 'accessing' stamp: 'ar 10/28/1998 23:59'! printStat: time count: n string: aString Transcript cr; print: time; tab; nextPutAll:' mSecs -- '; print: n; tab; nextPutAll:' ops -- '; print: ((time asFloat / (n max: 1) asFloat) roundTo: 0.01); tab; nextPutAll: ' avg. mSecs/op -- '; nextPutAll: aString.! ! !BalloonEngine class methodsFor: 'accessing' stamp: 'ar 1/12/1999 10:52'! printStats "BalloonEngine doProfileStats: true" "BalloonEngine printStats" "BalloonEngine resetStats" Transcript cr; nextPutAll:'/************** BalloonEngine statistics ****************/'. self printStat: (Times at: 1) count: (Counts at: 1) string: 'Initialization'. self printStat: (Times at: 2) count: (Counts at: 2) string: 'Finish test'. self printStat: (Times at: 3) count: (Counts at: 3) string: 'Fetching/Adding GET entries'. self printStat: (Times at: 4) count: (Counts at: 4) string: 'Adding AET entries'. self printStat: (Times at: 5) count: (Counts at: 5) string: 'Fetching/Computing fills'. self printStat: (Times at: 6) count: (Counts at: 6) string: 'Merging fills'. self printStat: (Times at: 7) count: (Counts at: 7) string: 'Displaying span buffer'. self printStat: (Times at: 8) count: (Counts at: 8) string: 'Fetching/Updating AET entries'. self printStat: (Times at: 9) count: (Counts at: 9) string: 'Changing AET entries'. Transcript cr; print: Times sum; nextPutAll:' mSecs for all operations'. Transcript cr; print: Counts sum; nextPutAll: ' overall operations'. Transcript endEntry.! ! !BalloonEngine class methodsFor: 'accessing' stamp: 'ar 10/30/1998 23:57'! resetBezierStats BezierStats := WordArray new: 4.! ! !BalloonEngine class methodsFor: 'accessing' stamp: 'ar 10/28/1998 23:38'! resetStats Times := WordArray new: 10. Counts := WordArray new: 10.! ! !BalloonEngine class methodsFor: 'initialization' stamp: 'ar 11/11/1998 22:49'! initialize "BalloonEngine initialize" BufferCache := WeakArray new: 1. Smalltalk garbageCollect. "Make the cache old" CacheProtect := Semaphore forMutualExclusion. Times := WordArray new: 10. Counts := WordArray new: 10. BezierStats := WordArray new: 4. Debug ifNil:[Debug := false].! ! !BalloonEngine class methodsFor: 'private' stamp: 'ar 11/11/1998 22:50'! allocateOrRecycleBuffer: initialSize "Try to recycly a buffer. If this is not possibly, create a new one." | buffer | CacheProtect critical:[ buffer := BufferCache at: 1. BufferCache at: 1 put: nil. ]. ^buffer ifNil:[BalloonBuffer new: initialSize]! ! !BalloonEngine class methodsFor: 'private' stamp: 'ar 5/28/2000 22:17'! primitiveSetBitBltPlugin: pluginName ^nil! ! !BalloonEngine class methodsFor: 'private' stamp: 'eem 6/11/2008 13:00'! recycleBuffer: balloonBuffer "Try to keep the buffer for later drawing operations." CacheProtect critical:[ | buffer | buffer := BufferCache at: 1. (buffer isNil or:[buffer size < balloonBuffer size] ) ifTrue:[BufferCache at: 1 put: balloonBuffer]. ].! ! SharedPool subclass: #BalloonEngineConstants instanceVariableNames: '' classVariableNames: 'BEAaLevelIndex BEBalloonEngineSize BEBitBltIndex BEClipRectIndex BEColorTransformIndex BEDeferredIndex BEDestOffsetIndex BEEdgeTransformIndex BEExternalsIndex BEFormsIndex BEPostFlushNeededIndex BESpanIndex BEWorkBufferIndex ETBalloonEdgeDataSize ETIndexIndex ETLinesIndex ETSourceIndex ETXValueIndex ETYValueIndex ETZValueIndex FTBalloonFillDataSize FTDestFormIndex FTIndexIndex FTMaxXIndex FTMinXIndex FTSourceIndex FTYValueIndex GBBaseSize GBBitmapDepth GBBitmapHeight GBBitmapRaster GBBitmapSize GBBitmapWidth GBColormapOffset GBColormapSize GBEndX GBEndY GBFinalX GBMBaseSize GBTileFlag GBUpdateDDX GBUpdateDDY GBUpdateDX GBUpdateDY GBUpdateData GBUpdateX GBUpdateY GBViaX GBViaY GBWideEntry GBWideExit GBWideExtent GBWideFill GBWideSize GBWideUpdateData GBWideWidth GEBaseEdgeSize GEBaseFillSize GEEdgeClipFlag GEEdgeFillsInvalid GEFillIndexLeft GEFillIndexRight GENumLines GEObjectIndex GEObjectLength GEObjectType GEObjectUnused GEPrimitiveBezier GEPrimitiveClippedBitmapFill GEPrimitiveEdge GEPrimitiveEdgeMask GEPrimitiveFill GEPrimitiveFillMask GEPrimitiveLine GEPrimitiveLinearGradientFill GEPrimitiveRadialGradientFill GEPrimitiveRepeatedBitmapFill GEPrimitiveTypeMask GEPrimitiveUnknown GEPrimitiveWide GEPrimitiveWideBezier GEPrimitiveWideEdge GEPrimitiveWideLine GEPrimitiveWideMask GEStateAddingFromGET GEStateBlitBuffer GEStateCompleted GEStateScanningAET GEStateUnlocked GEStateUpdateEdges GEStateWaitingChange GEStateWaitingForEdge GEStateWaitingForFill GEXValue GEYValue GEZValue GErrorAETEntry GErrorBadState GErrorFillEntry GErrorGETEntry GErrorNeedFlush GErrorNoMoreSpace GFDirectionX GFDirectionY GFNormalX GFNormalY GFOriginX GFOriginY GFRampLength GFRampOffset GGBaseSize GLBaseSize GLEndX GLEndY GLError GLErrorAdjDown GLErrorAdjUp GLWideEntry GLWideExit GLWideExtent GLWideFill GLWideSize GLWideWidth GLXDirection GLXIncrement GLYDirection GWAAColorMask GWAAColorShift GWAAHalfPixel GWAALevel GWAAScanMask GWAAShift GWAETStart GWAETUsed GWBezierHeightSubdivisions GWBezierLineConversions GWBezierMonotonSubdivisions GWBezierOverflowSubdivisions GWBufferTop GWClearSpanBuffer GWClipMaxX GWClipMaxY GWClipMinX GWClipMinY GWColorTransform GWCountAddAETEntry GWCountChangeAETEntry GWCountDisplaySpan GWCountFinishTest GWCountInitializing GWCountMergeFill GWCountNextAETEntry GWCountNextFillEntry GWCountNextGETEntry GWCurrentY GWCurrentZ GWDestOffsetX GWDestOffsetY GWEdgeTransform GWFillMaxX GWFillMaxY GWFillMinX GWFillMinY GWFillOffsetX GWFillOffsetY GWGETStart GWGETUsed GWHasClipShapes GWHasColorTransform GWHasEdgeTransform GWHeaderSize GWLastExportedEdge GWLastExportedFill GWLastExportedLeftX GWLastExportedRightX GWMagicIndex GWMagicNumber GWMinimalSize GWNeedsFlush GWObjStart GWObjUsed GWPoint1 GWPoint2 GWPoint3 GWPoint4 GWPointListFirst GWSize GWSpanEnd GWSpanEndAA GWSpanSize GWSpanStart GWState GWStopReason GWTimeAddAETEntry GWTimeChangeAETEntry GWTimeDisplaySpan GWTimeFinishTest GWTimeInitializing GWTimeMergeFill GWTimeNextAETEntry GWTimeNextFillEntry GWTimeNextGETEntry' poolDictionaries: '' category: 'Balloon-Engine'! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! BalloonEngineConstants class instanceVariableNames: ''! !BalloonEngineConstants class methodsFor: 'pool definition' stamp: 'ar 5/18/2003 19:55'! initEdgeConstants "Initialize the edge constants" "Edge primitive types" GEPrimitiveEdge := 2. "External edge - not handled by the GE" GEPrimitiveWideEdge := 3. "Wide external edge" GEPrimitiveLine := 4. "Straight line" GEPrimitiveWideLine := 5. "Wide line" GEPrimitiveBezier := 6. "Quadratic bezier curve" GEPrimitiveWideBezier := 7. "Wide bezier curve" "Special flags" GEPrimitiveWide := 16r01. "Flag determining a wide primitive" GEPrimitiveWideMask := 16rFE. "Mask for clearing the wide flag" GEEdgeFillsInvalid := 16r10000. "Flag determining if left/right fills of an edge are invalid" GEEdgeClipFlag := 16r20000. "Flag determining if this is a clip edge" "General edge state constants" GEXValue := 4. "Current raster x" GEYValue := 5. "Current raster y" GEZValue := 6. "Current raster z" GENumLines := 7. "Number of scan lines remaining" GEFillIndexLeft := 8. "Left fill index" GEFillIndexRight := 9. "Right fill index" GEBaseEdgeSize := 10. "Basic size of each edge" "General fill state constants" GEBaseFillSize := 4. "Basic size of each fill" "General Line state constants" GLXDirection := 10. "Direction of edge (1: left-to-right; -1: right-to-left)" GLYDirection := 11. "Direction of edge (1: top-to-bottom; -1: bottom-to-top)" GLXIncrement := 12. "Increment at each scan line" GLError := 13. "Current error" GLErrorAdjUp := 14. "Error to add at each scan line" GLErrorAdjDown := 15. "Error to subtract on roll-over" "Note: The following entries are only needed before the incremental state is computed. They are therefore aliased to the error values above" GLEndX := 14. "End X of line" GLEndY := 15. "End Y of line" GLBaseSize := 16. "Basic size of each line" "Additional stuff for wide lines" GLWideFill := 16. "Current fill of line" GLWideWidth := 17. "Current width of line" GLWideEntry := 18. "Initial steps" GLWideExit := 19. "Final steps" GLWideExtent := 20. "Target width" GLWideSize := 21. "Size of wide lines" "General Bezier state constants" GBUpdateData := 10. "Incremental update data for beziers" GBUpdateX := 0. "Last computed X value (24.8)" GBUpdateY := 1. "Last computed Y value (24.8)" GBUpdateDX := 2. "Delta X forward difference step (8.24)" GBUpdateDY := 3. "Delta Y forward difference step (8.24)" GBUpdateDDX := 4. "Delta DX forward difference step (8.24)" GBUpdateDDY := 5. "Delta DY forward difference step (8.24)" "Note: The following four entries are only needed before the incremental state is computed. They are therefore aliased to the incremental values above" GBViaX := 12. "via x" GBViaY := 13. "via y" GBEndX := 14. "end x" GBEndY := 15. "end y" GBBaseSize := 16. "Basic size of each bezier. Note: MUST be greater or equal to the size of lines" "Additional stuff for wide beziers" GBWideFill := 16. "Current fill of line" GBWideWidth := 17. "Current width of line" GBWideEntry := 18. "Initial steps" GBWideExit := 19. "Final steps" GBWideExtent := 20. "Target extent" GBFinalX := 21. "Final X value" GBWideUpdateData := 22. "Update data for second curve" GBWideSize := 28. "Size of wide beziers" ! ! !BalloonEngineConstants class methodsFor: 'pool definition' stamp: 'ar 5/18/2003 20:08'! initFillConstants "Initialize the fill constants" "Fill primitive types" GEPrimitiveFill := 16r100. GEPrimitiveLinearGradientFill := 16r200. GEPrimitiveRadialGradientFill := 16r300. GEPrimitiveClippedBitmapFill := 16r400. GEPrimitiveRepeatedBitmapFill := 16r500. "General fill state constants" GEBaseFillSize := 4. "Basic size of each fill" "Oriented fill constants" GFOriginX := 4. "X origin of fill" GFOriginY := 5. "Y origin of fill" GFDirectionX := 6. "X direction of fill" GFDirectionY := 7. "Y direction of fill" GFNormalX := 8. "X normal of fill" GFNormalY := 9. "Y normal of fill" "Gradient fill constants" GFRampLength := 10. "Length of following color ramp" GFRampOffset := 12. "Offset of first ramp entry" GGBaseSize := 12. "Bitmap fill constants" GBBitmapWidth := 10. "Width of bitmap" GBBitmapHeight := 11. "Height of bitmap" GBBitmapDepth := 12. "Depth of bitmap" GBBitmapSize := 13. "Size of bitmap words" GBBitmapRaster := 14. "Size of raster line" GBColormapSize := 15. "Size of colormap, if any" GBTileFlag := 16. "True if the bitmap is tiled" GBColormapOffset := 18. "Offset of colormap, if any" GBMBaseSize := 18. "Basic size of bitmap fill" ! ! !BalloonEngineConstants class methodsFor: 'pool definition' stamp: 'ar 5/18/2003 19:59'! initPrimitiveConstants "Initialize the primitive constants" "Primitive type constants" GEPrimitiveUnknown := 0. GEPrimitiveEdgeMask := 16rFF. GEPrimitiveFillMask := 16rFF00. GEPrimitiveTypeMask := 16rFFFF. "General state constants (Note: could be compressed later)" GEObjectType := 0. "Type of object" GEObjectLength := 1. "Length of object" GEObjectIndex := 2. "Index into external objects" GEObjectUnused := 3. "Currently unused" ! ! !BalloonEngineConstants class methodsFor: 'pool definition' stamp: 'ar 5/18/2003 20:00'! initStateConstants "Initialize the state Constants" GEStateUnlocked := 0. "Buffer is unlocked and can be modified as wanted" GEStateAddingFromGET := 1. "Adding edges from the GET" GEStateWaitingForEdge := 2. "Waiting for edges added to GET" GEStateScanningAET := 3. "Scanning the active edge table" GEStateWaitingForFill := 4. "Waiting for a fill to mix in during AET scan" GEStateBlitBuffer := 5. "Blt the current scan line" GEStateUpdateEdges := 6. "Update edges to next scan line" GEStateWaitingChange := 7. "Waiting for a changed edge" GEStateCompleted := 8. "Rendering completed" "Error constants" GErrorNoMoreSpace := 1. "No more space in collection" GErrorBadState := 2. "Tried to call a primitive while engine in bad state" GErrorNeedFlush := 3. "Tried to call a primitive that requires flushing before" "Incremental error constants" GErrorGETEntry := 4. "Unknown entry in GET" GErrorFillEntry := 5. "Unknown FILL encountered" GErrorAETEntry := 6. "Unknown entry in AET" ! ! !BalloonEngineConstants class methodsFor: 'pool definition' stamp: 'ar 5/18/2003 20:04'! initWorkBufferConstants "Initialize the work buffer constants" "General work buffer constants" GWMagicNumber := 16r416E6469. "Magic number" GWHeaderSize := 128. "Size of header" GWMinimalSize := 256. "Minimal size of work buffer" "Header entries" GWMagicIndex := 0. "Index of magic number" GWSize := 1. "Size of full buffer" GWState := 2. "Current state (e.g., locked or not." "Buffer entries" GWObjStart := 8. "objStart" GWObjUsed := 9. "objUsed" GWBufferTop := 10. "wbTop" GWGETStart := 11. "getStart" GWGETUsed := 12. "getUsed" GWAETStart := 13. "aetStart" GWAETUsed := 14. "aetUsed" "Transform entries" GWHasEdgeTransform := 16. "True if we have an edge transformation" GWHasColorTransform := 17. "True if we have a color transformation" GWEdgeTransform := 18. "2x3 edge transformation" GWColorTransform := 24. "8 word RGBA color transformation" "Span entries" GWSpanStart := 32. "spStart" GWSpanSize := 33. "spSize" GWSpanEnd := 34. "spEnd" GWSpanEndAA := 35. "spEndAA" "Bounds entries" GWFillMinX := 36. "fillMinX" GWFillMaxX := 37. "fillMaxX" GWFillMinY := 38. "fillMinY" GWFillMaxY := 39. "fillMaxY" GWFillOffsetX := 40. "fillOffsetX" GWFillOffsetY := 41. "fillOffsetY" GWClipMinX := 42. GWClipMaxX := 43. GWClipMinY := 44. GWClipMaxY := 45. GWDestOffsetX := 46. GWDestOffsetY := 47. "AA entries" GWAALevel := 48. "aaLevel" GWAAShift := 49. "aaShift" GWAAColorShift := 50. "aaColorShift" GWAAColorMask := 51. "aaColorMask" GWAAScanMask := 52. "aaScanMask" GWAAHalfPixel := 53. "aaHalfPixel" "Misc entries" GWNeedsFlush := 63. "True if the engine may need a flush" GWStopReason := 64. "stopReason" GWLastExportedEdge := 65. "last exported edge" GWLastExportedFill := 66. "last exported fill" GWLastExportedLeftX := 67. "last exported leftX" GWLastExportedRightX := 68. "last exported rightX" GWClearSpanBuffer := 69. "Do we have to clear the span buffer?" GWPointListFirst := 70. "First point list in buffer" GWPoint1 := 80. GWPoint2 := 82. GWPoint3 := 84. GWPoint4 := 86. GWCurrentY := 88. "Profile stats" GWTimeInitializing := 90. GWCountInitializing := 91. GWTimeFinishTest := 92. GWCountFinishTest := 93. GWTimeNextGETEntry := 94. GWCountNextGETEntry := 95. GWTimeAddAETEntry := 96. GWCountAddAETEntry := 97. GWTimeNextFillEntry := 98. GWCountNextFillEntry := 99. GWTimeMergeFill := 100. GWCountMergeFill := 101. GWTimeDisplaySpan := 102. GWCountDisplaySpan := 103. GWTimeNextAETEntry := 104. GWCountNextAETEntry := 105. GWTimeChangeAETEntry := 106. GWCountChangeAETEntry := 107. "Bezier stats" GWBezierMonotonSubdivisions := 108. "# of subdivision due to non-monoton beziers" GWBezierHeightSubdivisions := 109. "# of subdivisions due to excessive height" GWBezierOverflowSubdivisions := 110. "# of subdivisions due to possible int overflow" GWBezierLineConversions := 111. "# of beziers converted to lines" GWHasClipShapes := 112. "True if the engine contains clip shapes" GWCurrentZ := 113. "Current z value of primitives" ! ! !BalloonEngineConstants class methodsFor: 'pool definition' stamp: 'ar 5/18/2003 20:08'! initialize "BalloonEngineConstants initialize" self initStateConstants. self initWorkBufferConstants. self initPrimitiveConstants. self initEdgeConstants. self initFillConstants. self initializeInstVarNames: BalloonEngine prefixedBy: 'BE'. self initializeInstVarNames: BalloonEdgeData prefixedBy: 'ET'. self initializeInstVarNames: BalloonFillData prefixedBy: 'FT'.! ! !BalloonEngineConstants class methodsFor: 'pool definition' stamp: 'ar 5/18/2003 20:07'! initializeInstVarNames: aClass prefixedBy: aString | token value | aClass instVarNames doWithIndex:[:instVarName :index| token := (aString, instVarName first asUppercase asString, (instVarName copyFrom: 2 to: instVarName size),'Index') asSymbol. value := index - 1. (self bindingOf: token) ifNil:[self addClassVarName: token]. (self bindingOf: token) value: value. ]. token := (aString, aClass name,'Size') asSymbol. (self bindingOf: token) ifNil:[self addClassVarName: token]. (self bindingOf: token) value: aClass instSize.! ! Object subclass: #BalloonFillData instanceVariableNames: 'index minX maxX yValue source destForm' classVariableNames: '' poolDictionaries: '' category: 'Balloon-Simulation'! !BalloonFillData commentStamp: '' prior: 0! This class is a simulation of the code that's run by the Balloon engine. For debugging purposes only.! !BalloonFillData methodsFor: 'accessing' stamp: 'ar 10/27/1998 15:56'! destForm ^destForm! ! !BalloonFillData methodsFor: 'accessing' stamp: 'ar 10/27/1998 15:56'! destForm: aForm destForm := aForm! ! !BalloonFillData methodsFor: 'accessing' stamp: 'ar 10/27/1998 15:55'! index ^index! ! !BalloonFillData methodsFor: 'accessing' stamp: 'ar 10/27/1998 15:55'! index: anInteger index := anInteger! ! !BalloonFillData methodsFor: 'accessing' stamp: 'ar 10/27/1998 15:55'! maxX ^maxX! ! !BalloonFillData methodsFor: 'accessing' stamp: 'ar 10/27/1998 15:55'! maxX: anInteger maxX := anInteger! ! !BalloonFillData methodsFor: 'accessing' stamp: 'ar 10/27/1998 15:55'! minX ^minX! ! !BalloonFillData methodsFor: 'accessing' stamp: 'ar 10/27/1998 15:55'! minX: anInteger minX := anInteger! ! !BalloonFillData methodsFor: 'accessing' stamp: 'ar 10/27/1998 15:56'! source ^source! ! !BalloonFillData methodsFor: 'accessing' stamp: 'ar 10/27/1998 15:56'! source: anObject source := anObject! ! !BalloonFillData methodsFor: 'accessing' stamp: 'ar 10/28/1998 16:35'! width ^maxX - minX! ! !BalloonFillData methodsFor: 'accessing' stamp: 'ar 10/27/1998 15:55'! yValue ^yValue! ! !BalloonFillData methodsFor: 'accessing' stamp: 'ar 10/27/1998 15:55'! yValue: anInteger yValue := anInteger! ! !BalloonFillData methodsFor: 'computing' stamp: 'ar 11/14/1998 19:32'! computeFill (destForm isNil or:[destForm width < self width]) ifTrue:[ destForm := Form extent: (self width + 10) @ 1 depth: 32. ]. source computeFillFrom: minX to: maxX at: yValue in: destForm! ! TestCase subclass: #BalloonFontTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'MorphicTests-Widgets'! !BalloonFontTest methodsFor: 'tests' stamp: 'sd 12/9/2001 21:44'! testDefaultFont "(self selector: #testDefaultFont) debug" self assert: RectangleMorph new balloonFont = BalloonMorph balloonFont. self assert: RectangleMorph new defaultBalloonFont = BalloonMorph balloonFont.! ! !BalloonFontTest methodsFor: 'tests' stamp: 'sd 12/9/2001 21:55'! testSpecificFont "(self selector: #testSpecificFont) debug" | aMorph | aMorph := RectangleMorph new. self assert: RectangleMorph new balloonFont = BalloonMorph balloonFont. self assert: RectangleMorph new defaultBalloonFont = BalloonMorph balloonFont. aMorph balloonFont: (StrikeFont familyName: #ComicPlain size: 19). self assert: aMorph balloonFont = (StrikeFont familyName: #ComicPlain size: 19). "The next test is horrible because I do no know how to access the font with the appropiate interface" self assert: (((BalloonMorph getTextMorph: 'lulu' for: aMorph) text runs at: 1) at: 1) font = (StrikeFont familyName: #ComicPlain size: 19)! ! Object subclass: #BalloonLineSimulation instanceVariableNames: 'start end xIncrement xDirection error errorAdjUp errorAdjDown' classVariableNames: '' poolDictionaries: '' category: 'Balloon-Simulation'! !BalloonLineSimulation commentStamp: '' prior: 0! This class is a simulation of the code that's run by the Balloon engine. For debugging purposes only.! !BalloonLineSimulation methodsFor: 'accessing' stamp: 'ar 10/30/1998 03:02'! end ^end! ! !BalloonLineSimulation methodsFor: 'accessing' stamp: 'ar 10/30/1998 03:02'! end: aPoint end := aPoint! ! !BalloonLineSimulation methodsFor: 'accessing' stamp: 'ar 10/27/1998 20:31'! initialX ^start y <= end y ifTrue:[start x] ifFalse:[end x]! ! !BalloonLineSimulation methodsFor: 'accessing' stamp: 'ar 10/27/1998 20:31'! initialY ^start y <= end y ifTrue:[start y] ifFalse:[end y]! ! !BalloonLineSimulation methodsFor: 'accessing' stamp: 'ar 10/27/1998 20:31'! initialZ ^0 "Assume no depth given"! ! !BalloonLineSimulation methodsFor: 'accessing' stamp: 'ar 10/30/1998 03:02'! start ^start! ! !BalloonLineSimulation methodsFor: 'accessing' stamp: 'ar 10/30/1998 03:02'! start: aPoint start := aPoint! ! !BalloonLineSimulation methodsFor: 'computing' stamp: 'ar 10/27/1998 20:52'! computeInitialStateFrom: source with: aTransformation "Compute the initial state in the receiver." start := (aTransformation localPointToGlobal: source start) asIntegerPoint. end := (aTransformation localPointToGlobal: source end) asIntegerPoint.! ! !BalloonLineSimulation methodsFor: 'computing' stamp: 'ar 10/27/1998 23:22'! stepToFirstScanLineAt: yValue in: edgeTableEntry "Compute the initial x value for the scan line at yValue" | startX endX startY endY yDir deltaY deltaX widthX | (start y) <= (end y) ifTrue:[ startX := start x. endX := end x. startY := start y. endY := end y. yDir := 1. ] ifFalse:[ startX := end x. endX := start x. startY := end y. endY := start y. yDir := -1. ]. deltaY := endY - startY. deltaX := endX - startX. "Quickly check if the line is visible at all" (yValue >= endY or:[deltaY = 0]) ifTrue:[^edgeTableEntry lines: 0]. "Check if edge goes left to right" deltaX >= 0 ifTrue:[ xDirection := 1. widthX := deltaX. error := 0. ] ifFalse:[ xDirection := -1. widthX := 0 - deltaX. error := 1 - deltaY. ]. "Check if edge is horizontal" deltaY = 0 ifTrue:[ xIncrement := 0. errorAdjUp := 0] ifFalse:["Check if edge is y-major" deltaY > widthX ifTrue:[ xIncrement := 0. errorAdjUp := widthX] ifFalse:[ xIncrement := (widthX // deltaY) * xDirection. errorAdjUp := widthX \\ deltaY]]. errorAdjDown := deltaY. edgeTableEntry xValue: startX. edgeTableEntry lines: deltaY. "If not at first scan line then step down to yValue" yValue = startY ifFalse:[ startY to: yValue do:[:y| self stepToNextScanLineAt: y in: edgeTableEntry]. "And adjust remainingLines" edgeTableEntry lines: deltaY - (yValue - startY). ].! ! !BalloonLineSimulation methodsFor: 'computing' stamp: 'ar 10/27/1998 20:39'! stepToNextScanLineAt: yValue in: edgeTableEntry "Compute the next x value for the scan line at yValue. This message is sent during incremental updates. The yValue parameter is passed in here for edges that have more complicated computations," | x | x := edgeTableEntry xValue + xIncrement. error := error + errorAdjUp. error > 0 ifTrue:[ x := x + xDirection. error := error - errorAdjDown. ]. edgeTableEntry xValue: x.! ! !BalloonLineSimulation methodsFor: 'computing' stamp: 'ar 10/29/1998 23:42'! subdivide ^nil! ! !BalloonLineSimulation methodsFor: 'printing' stamp: 'ar 10/27/1998 23:20'! printOn: aStream aStream nextPutAll: self class name; nextPut:$(; print: start; nextPutAll:' - '; print: end; nextPut:$)! ! !BalloonLineSimulation methodsFor: 'printing' stamp: 'MPW 1/1/1901 21:57'! printOnStream: aStream aStream print: self class name; print:'('; write: start; print:' - '; write: end; print:')'.! ! PolygonMorph subclass: #BalloonMorph instanceVariableNames: 'target offsetFromTarget balloonOwner' classVariableNames: 'BalloonColor BalloonFont' poolDictionaries: '' category: 'Morphic-Widgets'! !BalloonMorph commentStamp: '' prior: 0! A balloon with text used for the display of explanatory information. Balloon help is integrated into Morphic as follows: If a Morph has the property #balloonText, then it will respond to #showBalloon by adding a text balloon to the world, and to #deleteBalloon by removing the balloon. Moreover, if mouseOverEnabled is true (see class msg), then the Hand will arrange to cause display of the balloon after the mouse has lingered over the morph for a while, and removal of the balloon when the mouse leaves the bounds of that morph. In any case, the Hand will attempt to remove any such balloons before handling mouseDown events, or displaying other balloons. Balloons should not be duplicated with veryDeepCopy unless their target is also duplicated at the same time.! !BalloonMorph methodsFor: 'accessing' stamp: 'ar 10/3/2000 17:19'! balloonOwner ^balloonOwner! ! !BalloonMorph methodsFor: 'initialization' stamp: 'dgd 3/12/2006 14:27'! defaultBorderColor "answer the default border color/fill style for the receiver" ^ self defaultColor muchDarker"Color black"! ! !BalloonMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:36'! defaultBorderWidth "answer the default border width for the receiver" ^ 1! ! !BalloonMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:24'! defaultColor "answer the default color/fill style for the receiver" ^ self class balloonColor! ! !BalloonMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 20:20'! initialize "initialize the state of the receiver" super initialize. "" self beSmoothCurve. offsetFromTarget := 0 @ 0! ! !BalloonMorph methodsFor: 'initialization' stamp: 'ar 10/4/2000 10:13'! popUpFor: aMorph hand: aHand "Pop up the receiver as balloon help for the given hand" balloonOwner := aMorph. self popUpForHand: aHand.! ! !BalloonMorph methodsFor: 'initialization' stamp: 'RAA 7/1/2001 18:48'! popUpForHand: aHand "Pop up the receiver as balloon help for the given hand" | worldBounds | self lock. self fullBounds. "force layout" self setProperty: #morphicLayerNumber toValue: self morphicLayerNumber. aHand world addMorphFront: self. "So that if the translation below makes it overlap the receiver, it won't interfere with the rootMorphsAt: logic and hence cause flashing. Without this, flashing happens, believe me!!" ((worldBounds := aHand world bounds) containsRect: self bounds) ifFalse: [self bounds: (self bounds translatedToBeWithin: worldBounds)]. aHand balloonHelp: self. ! ! !BalloonMorph methodsFor: 'menus' stamp: 'wiz 12/30/2004 17:14'! adjustedCenter "Return the center of the original textMorph box within the balloon." ^ (self vertices last: 4) average rounded ! ! !BalloonMorph methodsFor: 'stepping and presenter' stamp: 'sma 12/23/1999 14:05'! step "Move with target." target ifNotNil: [self position: target position + offsetFromTarget]. ! ! !BalloonMorph methodsFor: 'testing' stamp: 'di 9/18/97 10:10'! stepTime ^ 0 "every cycle"! ! !BalloonMorph methodsFor: 'wiw support' stamp: 'RAA 6/27/2000 18:07'! morphicLayerNumber "helpful for insuring some morphs always appear in front of or behind others. smaller numbers are in front" ^5 "Balloons are very front-like things"! ! !BalloonMorph methodsFor: 'private' stamp: 'sma 12/23/1999 14:06'! setTarget: aMorph (target := aMorph) ifNotNil: [offsetFromTarget := self position - target position]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! BalloonMorph class instanceVariableNames: ''! !BalloonMorph class methodsFor: '*FreeType-override' stamp: 'tween 8/7/2007 01:59'! chooseBalloonFont "BalloonMorph chooseBalloonFont" Preferences chooseFontWithPrompt: 'Ballon Help font...' translated andSendTo: self withSelector: #setBalloonFontTo: highlightSelector: #balloonFont! ! !BalloonMorph class methodsFor: 'instance creation' stamp: 'sma 12/23/1999 20:05'! string: str for: morph ^ self string: str for: morph corner: #bottomLeft! ! !BalloonMorph class methodsFor: 'instance creation' stamp: 'sd 12/5/2001 20:27'! string: str for: morph corner: cornerName "Make up and return a balloon for morph. Find the quadrant that clips the text the least, using cornerName as a tie-breaker. tk 9/12/97" | tm vertices | tm := self getTextMorph: str for: morph. vertices := self getVertices: tm bounds. vertices := self getBestLocation: vertices for: morph corner: cornerName. ^ self new color: morph balloonColor; setVertices: vertices; addMorph: tm; setTarget: morph! ! !BalloonMorph class methodsFor: 'utility' stamp: 'sma 11/11/2000 14:59'! balloonColor ^ BalloonColor! ! !BalloonMorph class methodsFor: 'utility' stamp: 'sw 1/31/2000 15:43'! balloonFont ^ BalloonFont! ! !BalloonMorph class methodsFor: 'utility' stamp: 'sma 11/11/2000 14:59'! setBalloonColorTo: aColor aColor ifNotNil: [BalloonColor := aColor]! ! !BalloonMorph class methodsFor: 'utility' stamp: 'sw 1/31/2000 15:40'! setBalloonFontTo: aFont aFont ifNotNil: [BalloonFont := aFont]! ! !BalloonMorph class methodsFor: 'private' stamp: 'wiz 1/24/2005 00:32'! getBestLocation: vertices for: morph corner: cornerName "Try four rel locations of the balloon for greatest unclipped area. 12/99 sma" | rect maxArea verts rectCorner morphPoint mbc a mp dir bestVerts result usableArea | "wiz 1/8/2005 Choose rect independantly of vertice order or size. Would be nice it this took into account curveBounds but it does not." rect := Rectangle encompassing: vertices. maxArea := -1. verts := vertices. usableArea := (morph world ifNil: [self currentWorld]) viewBox. 1 to: 4 do: [:i | dir := #(vertical horizontal) atWrap: i. verts := verts collect: [:p | p flipBy: dir centerAt: rect center]. rectCorner := #(bottomLeft bottomRight topRight topLeft) at: i. morphPoint := #(topCenter topCenter bottomCenter bottomCenter) at: i. a := ((rect align: (rect perform: rectCorner) with: (mbc := morph boundsForBalloon perform: morphPoint)) intersect: usableArea) area. (a > maxArea or: [a = rect area and: [rectCorner = cornerName]]) ifTrue: [maxArea := a. bestVerts := verts. mp := mbc]]. result := bestVerts collect: [:p | p + (mp - bestVerts first)] "Inlined align:with:". ^ result! ! !BalloonMorph class methodsFor: 'private' stamp: 'sd 12/5/2001 20:28'! getTextMorph: aStringOrMorph for: balloonOwner "Construct text morph." | m text | aStringOrMorph isMorph ifTrue: [m := aStringOrMorph] ifFalse: [BalloonFont ifNil: [text := aStringOrMorph] ifNotNil: [text := Text string: aStringOrMorph attribute: (TextFontReference toFont: balloonOwner balloonFont)]. m := (TextMorph new contents: text) centered]. m setToAdhereToEdge: #adjustedCenter. ^ m! ! !BalloonMorph class methodsFor: 'private' stamp: 'wiz 1/8/2005 18:05'! getVertices: bounds "Construct vertices for a balloon up and to left of anchor" | corners | corners := bounds corners atAll: #(1 4 3 2). ^ (Array with: corners first + (0 - bounds width // 2 @ 0) with: corners first + (0 - bounds width // 4 @ (bounds height // 2))) , corners! ! RectangleMorph subclass: #BalloonRectangleMorph instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Balloon'! !BalloonRectangleMorph commentStamp: '' prior: 0! BalloonRectangleMorph is an example for drawing using the BalloonEngine.! !BalloonRectangleMorph methodsFor: 'accessing' stamp: 'ar 11/15/1998 22:24'! doesBevels "To return true means that this object can show bevelled borders, and therefore can accept, eg, #raised or #inset as valid borderColors. Must be overridden by subclasses that do not support bevelled borders." ^ false! ! !BalloonRectangleMorph methodsFor: 'drawing' stamp: 'ar 11/15/1998 22:40'! drawOn: aCanvas (color isKindOf: OrientedFillStyle) ifTrue:[ color origin: bounds center. color direction: (bounds extent x * 0.7) @ 0. color normal: 0@(bounds extent y * 0.7). ]. (borderColor isKindOf: OrientedFillStyle) ifTrue:[ borderColor origin: bounds topLeft. borderColor direction: (bounds extent x) @ 0. borderColor normal: 0@(bounds extent y). ]. aCanvas asBalloonCanvas drawRectangle: (bounds insetBy: borderWidth // 2) color: color borderWidth: borderWidth borderColor: borderColor.! ! !BalloonRectangleMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:33'! defaultBorderColor "answer the default border color/fill style for the receiver" ^ GradientFillStyle ramp: {0.0 -> Color black. 1.0 -> Color white}! ! !BalloonRectangleMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:36'! defaultBorderWidth "answer the default border width for the receiver" ^ 10! ! !BalloonRectangleMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:24'! defaultColor "answer the default color/fill style for the receiver" | result | result := GradientFillStyle ramp: {0.0 -> Color green. 0.5 -> Color yellow. 1.0 -> Color red}. result radial: true. ^ result! ! !BalloonRectangleMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:41'! initialize "initialize the state of the receiver" super initialize. "" self extent: 100 @ 100! ! !BalloonRectangleMorph methodsFor: 'rotate scale and flex' stamp: 'ar 11/15/1998 22:20'! newTransformationMorph ^MatrixTransformMorph new! ! !BalloonRectangleMorph methodsFor: 'testing' stamp: 'ar 8/25/2001 19:08'! canDrawBorder: aBorderStyle ^aBorderStyle style == #simple! ! Object subclass: #BalloonSolidFillSimulation instanceVariableNames: 'color' classVariableNames: '' poolDictionaries: '' category: 'Balloon-Simulation'! !BalloonSolidFillSimulation commentStamp: '' prior: 0! This class is a simulation of the code that's run by the Balloon engine. For debugging purposes only.! !BalloonSolidFillSimulation methodsFor: 'computing' stamp: 'ar 10/27/1998 23:07'! computeFillFrom: minX to: maxX at: yValue in: form | bb | color isTransparent ifFalse:[ bb := BitBlt toForm: form. bb fillColor: color. bb destX: 0 destY: 0 width: (maxX - minX) height: 1. bb combinationRule: Form over. bb copyBits].! ! !BalloonSolidFillSimulation methodsFor: 'computing' stamp: 'ar 10/27/1998 23:08'! computeInitialStateFrom: source with: aColorTransform color := source asColor.! ! Object subclass: #BalloonState instanceVariableNames: 'transform colorTransform aaLevel' classVariableNames: '' poolDictionaries: '' category: 'Balloon-Engine'! !BalloonState commentStamp: '' prior: 0! This class is a repository for data which needs to be preserved during certain operations of BalloonCanvas.! !BalloonState methodsFor: 'accessing' stamp: 'ar 12/30/1998 10:47'! aaLevel ^aaLevel! ! !BalloonState methodsFor: 'accessing' stamp: 'ar 12/30/1998 10:47'! aaLevel: aNumber aaLevel := aNumber! ! !BalloonState methodsFor: 'accessing' stamp: 'ar 12/30/1998 10:42'! colorTransform ^colorTransform! ! !BalloonState methodsFor: 'accessing' stamp: 'ar 12/30/1998 10:42'! colorTransform: aColorTransform colorTransform := aColorTransform! ! !BalloonState methodsFor: 'accessing' stamp: 'ar 12/30/1998 10:41'! transform ^transform! ! !BalloonState methodsFor: 'accessing' stamp: 'ar 12/30/1998 10:42'! transform: aMatrixTransform transform := aMatrixTransform! ! MimeConverter subclass: #Base64MimeConverter instanceVariableNames: 'data' classVariableNames: 'FromCharTable ToCharTable' poolDictionaries: '' category: 'Network-MIME'! !Base64MimeConverter commentStamp: '' prior: 0! This class encodes and decodes data in Base64 format. This is MIME encoding. We translate a whole stream at once, taking a Stream as input and giving one as output. Returns a whole stream for the caller to use. 0 A 17 R 34 i 51 z 1 B 18 S 35 j 52 0 2 C 19 T 36 k 53 1 3 D 20 U 37 l 54 2 4 E 21 V 38 m 55 3 5 F 22 W 39 n 56 4 6 G 23 X 40 o 57 5 7 H 24 Y 41 p 58 6 8 I 25 Z 42 q 59 7 9 J 26 a 43 r 60 8 10 K 27 b 44 s 61 9 11 L 28 c 45 t 62 + 12 M 29 d 46 u 63 / 13 N 30 e 47 v 14 O 31 f 48 w (pad) = 15 P 32 g 49 x 16 Q 33 h 50 y Outbound: bytes are broken into 6 bit chunks, and the 0-63 value is converted to a character. 3 data bytes go into 4 characters. Inbound: Characters are translated in to 0-63 values and shifted into 8 bit bytes. (See: N. Borenstein, Bellcore, N. Freed, Innosoft, Network Working Group, Request for Comments: RFC 1521, September 1993, MIME (Multipurpose Internet Mail Extensions) Part One: Mechanisms for Specifying and Describing the Format of Internet Message Bodies. Sec 6.2) By Ted Kaehler, based on Tim Olson's Base64Filter.! !Base64MimeConverter methodsFor: 'conversion' stamp: 'tk 12/9/97 13:34'! mimeDecode "Convert a stream in base 64 with only a-z,A-Z,0-9,+,/ to a full byte stream of characters. Reutrn a whole stream for the user to read." | nibA nibB nibC nibD | [mimeStream atEnd] whileFalse: [ (nibA := self nextValue) ifNil: [^ dataStream]. (nibB := self nextValue) ifNil: [^ dataStream]. dataStream nextPut: ((nibA bitShift: 2) + (nibB bitShift: -4)) asCharacter. nibB := nibB bitAnd: 16rF. (nibC := self nextValue) ifNil: [^ dataStream]. dataStream nextPut: ((nibB bitShift: 4) + (nibC bitShift: -2)) asCharacter. nibC := nibC bitAnd: 16r3. (nibD := self nextValue) ifNil: [^ dataStream]. dataStream nextPut: ((nibC bitShift: 6) + nibD) asCharacter. ]. ^ dataStream! ! !Base64MimeConverter methodsFor: 'conversion' stamp: 'tk 12/9/97 13:39'! mimeDecodeToByteArray "Convert a stream in base 64 with only a-z,A-Z,0-9,+,/ to a full ByteArray of 0-255 values. Reutrn a whole stream for the user to read." | nibA nibB nibC nibD | [mimeStream atEnd] whileFalse: [ (nibA := self nextValue) ifNil: [^ dataStream]. (nibB := self nextValue) ifNil: [^ dataStream]. dataStream nextPut: ((nibA bitShift: 2) + (nibB bitShift: -4)). nibB := nibB bitAnd: 16rF. (nibC := self nextValue) ifNil: [^ dataStream]. dataStream nextPut: ((nibB bitShift: 4) + (nibC bitShift: -2)). nibC := nibC bitAnd: 16r3. (nibD := self nextValue) ifNil: [^ dataStream]. dataStream nextPut: ((nibC bitShift: 6) + nibD). ]. ^ dataStream! ! !Base64MimeConverter methodsFor: 'conversion' stamp: 'ls 2/10/2001 13:26'! mimeEncode "Convert from data to 6 bit characters." | phase1 phase2 raw nib lineLength | phase1 := phase2 := false. lineLength := 0. [dataStream atEnd] whileFalse: [ lineLength >= 70 ifTrue: [ mimeStream cr. lineLength := 0. ]. data := raw := dataStream next asInteger. nib := (data bitAnd: 16rFC) bitShift: -2. mimeStream nextPut: (ToCharTable at: nib+1). (raw := dataStream next) ifNil: [raw := 0. phase1 := true]. data := ((data bitAnd: 3) bitShift: 8) + raw asInteger. nib := (data bitAnd: 16r3F0) bitShift: -4. mimeStream nextPut: (ToCharTable at: nib+1). (raw := dataStream next) ifNil: [raw := 0. phase2 := true]. data := ((data bitAnd: 16rF) bitShift: 8) + (raw asInteger). nib := (data bitAnd: 16rFC0) bitShift: -6. mimeStream nextPut: (ToCharTable at: nib+1). nib := (data bitAnd: 16r3F). mimeStream nextPut: (ToCharTable at: nib+1). lineLength := lineLength + 4.]. phase1 ifTrue: [mimeStream skip: -2; nextPut: $=; nextPut: $=. ^ mimeStream]. phase2 ifTrue: [mimeStream skip: -1; nextPut: $=. ^ mimeStream]. ! ! !Base64MimeConverter methodsFor: 'conversion' stamp: 'tk 12/9/97 13:21'! nextValue "The next six bits of data char from the mimeStream, or nil. Skip all other chars" | raw num | [raw := mimeStream next. raw ifNil: [^ nil]. "end of stream" raw == $= ifTrue: [^ nil]. num := FromCharTable at: raw asciiValue + 1. num ifNotNil: [^ num]. "else ignore space, return, tab, ..." true] whileTrue.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Base64MimeConverter class instanceVariableNames: ''! !Base64MimeConverter class methodsFor: 'as yet unclassified' stamp: 'damiencassou 5/30/2008 11:45'! decodeInteger: mimeString "Decode the MIME string into an integer of any length" | bytes sum | bytes := (Base64MimeConverter mimeDecodeToBytes: mimeString readStream) contents. sum := 0. bytes reverseDo: [ :by | sum := sum * 256 + by ]. ^ sum! ! !Base64MimeConverter class methodsFor: 'as yet unclassified' stamp: 'tk 2/21/2000 17:22'! encodeInteger: int | strm | "Encode an integer of any length and return the MIME string" strm := ReadWriteStream on: (ByteArray new: int digitLength). 1 to: int digitLength do: [:ii | strm nextPut: (int digitAt: ii)]. strm reset. ^ ((self mimeEncode: strm) contents) copyUpTo: $= "remove padding"! ! !Base64MimeConverter class methodsFor: 'as yet unclassified' stamp: 'tk 12/9/97 13:53'! initialize FromCharTable := Array new: 256. "nils" ToCharTable := Array new: 64. ($A asciiValue to: $Z asciiValue) doWithIndex: [:val :ind | FromCharTable at: val+1 put: ind-1. ToCharTable at: ind put: val asCharacter]. ($a asciiValue to: $z asciiValue) doWithIndex: [:val :ind | FromCharTable at: val+1 put: ind+25. ToCharTable at: ind+26 put: val asCharacter]. ($0 asciiValue to: $9 asciiValue) doWithIndex: [:val :ind | FromCharTable at: val+1 put: ind+25+26. ToCharTable at: ind+26+26 put: val asCharacter]. FromCharTable at: $+ asciiValue + 1 put: 62. ToCharTable at: 63 put: $+. FromCharTable at: $/ asciiValue + 1 put: 63. ToCharTable at: 64 put: $/. ! ! !Base64MimeConverter class methodsFor: 'as yet unclassified' stamp: 'tk 12/12/97 11:41'! mimeDecodeToBytes: aStream "Return a RWBinaryOrTextStream of the original ByteArray. aStream has only 65 innocuous character values. aStream is not binary. (See class comment). 4 bytes in aStream goes to 3 bytes in output." | me | aStream position: 0. me := self new mimeStream: aStream. me dataStream: (RWBinaryOrTextStream on: (ByteArray new: aStream size * 3 // 4)). me mimeDecodeToByteArray. me dataStream position: 0. ^ me dataStream! ! !Base64MimeConverter class methodsFor: 'as yet unclassified' stamp: 'tk 12/9/97 13:01'! mimeDecodeToChars: aStream "Return a ReadWriteStream of the original String. aStream has only 65 innocuous character values. It is not binary. (See class comment). 4 bytes in aStream goes to 3 bytes in output." | me | aStream position: 0. me := self new mimeStream: aStream. me dataStream: (ReadWriteStream on: (String new: aStream size * 3 // 4)). me mimeDecode. me dataStream position: 0. ^ me dataStream! ! !Base64MimeConverter class methodsFor: 'as yet unclassified' stamp: 'tk 12/9/97 12:28'! mimeEncode: aStream "Return a ReadWriteStream of characters. The data of aStream is encoded as 65 innocuous characters. (See class comment). 3 bytes in aStream goes to 4 bytes in output." | me | aStream position: 0. me := self new dataStream: aStream. me mimeStream: (ReadWriteStream on: (String new: aStream size + 20 * 4 // 3)). me mimeEncode. me mimeStream position: 0. ^ me mimeStream! ! TestCase subclass: #Base64MimeConverterTest instanceVariableNames: 'message' classVariableNames: '' poolDictionaries: '' category: 'CollectionsTests-Streams'! !Base64MimeConverterTest commentStamp: '' prior: 0! This is the unit test for the class Base64MimeConverter. Unit tests are a good way to exercise the functionality of your system in a repeatable and automatic manner. They are therefore recommended if you plan to release anything. For more information, see: - http://www.c2.com/cgi/wiki?UnitTest - http://minnow.cc.gatech.edu/squeak/1547 - the sunit class category! !Base64MimeConverterTest methodsFor: 'initialization' stamp: 'stephaneducasse 2/4/2006 20:10'! setUp message := ReadWriteStream on: (String new: 10). message nextPutAll: 'Hi There!!'.! ! !Base64MimeConverterTest methodsFor: 'tests' stamp: 'sd 6/5/2005 09:23'! testMimeEncodeDecode | encoded | encoded := Base64MimeConverter mimeEncode: message. self assert: (encoded contents = 'SGkgVGhlcmUh'). self assert: ((Base64MimeConverter mimeDecodeToChars: encoded) contents = message contents).! ! TestCase subclass: #BasicBehaviorClassMetaclassTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'KernelTests-Classes'! !BasicBehaviorClassMetaclassTest commentStamp: '' prior: 0! This class contains some tests regarding the classes Behavior ClassDescription Class Metaclass --- ! !BasicBehaviorClassMetaclassTest methodsFor: 'testing' stamp: 'sd 6/5/2005 08:19'! testBehaviorClassClassDescriptionMetaclassHierarchy "self run: #testBehaviorClassClassDescriptionMetaclassHierarchy" self assert: Class superclass == ClassDescription. self assert: Metaclass superclass == ClassDescription. self assert: ClassDescription superclass == Behavior. self assert: Behavior superclass = Object. self assert: Class class class == Metaclass. self assert: Metaclass class class == Metaclass. self assert: ClassDescription class class == Metaclass. self assert: Behavior class class == Metaclass. ! ! !BasicBehaviorClassMetaclassTest methodsFor: 'testing' stamp: 'md 7/24/2009 15:29'! testClassDescriptionAllSubInstances "self run: #testClassDescriptionAllSubInstances" | cdNo clsNo metaclsNo | Smalltalk garbageCollect. cdNo := ClassDescription allSubInstances size. clsNo := Class allSubInstances size . metaclsNo := Metaclass allSubInstances size. self assert: cdNo = (clsNo + metaclsNo). ! ! !BasicBehaviorClassMetaclassTest methodsFor: 'testing' stamp: 'sd 6/5/2005 08:17'! testMetaclass "self run: #testMetaclass" self assert: OrderedCollection class class == Metaclass. self assert: Dictionary class class == Metaclass. self assert: Object class class == Metaclass. ! ! !BasicBehaviorClassMetaclassTest methodsFor: 'testing' stamp: 'sd 6/5/2005 08:12'! testMetaclassName "self run: #testMetaclassName" self assert: Dictionary class name = 'Dictionary class'. self assert: OrderedCollection class name = 'OrderedCollection class'. ! ! !BasicBehaviorClassMetaclassTest methodsFor: 'testing' stamp: 'sd 6/5/2005 08:12'! testMetaclassNumberOfInstances "self run: #testMetaclassNumberOfInstances" self assert: Dictionary class allInstances size = 1. self assert: OrderedCollection class allInstances size = 1.! ! !BasicBehaviorClassMetaclassTest methodsFor: 'testing' stamp: 'sd 6/5/2005 08:18'! testMetaclassPointOfCircularity "self run: #testMetaclassPointOfCircularity" self assert: Metaclass class instanceCount = 1. self assert: Metaclass class someInstance == Metaclass. ! ! !BasicBehaviorClassMetaclassTest methodsFor: 'testing' stamp: 'sd 6/5/2005 08:13'! testMetaclassSuperclass "self run: #testMetaclassSuperclass" self assert: Dictionary class superclass == Set class. self assert: OrderedCollection class superclass == SequenceableCollection class. ! ! !BasicBehaviorClassMetaclassTest methodsFor: 'testing' stamp: 'sd 6/5/2005 08:14'! testMetaclassSuperclassHierarchy "self run: #testMetaclassSuperclassHierarchy" | s | self assert: SequenceableCollection class instanceCount = 1. self assert: Collection class instanceCount = 1. self assert: Object class instanceCount = 1. self assert: ProtoObject class instanceCount = 1. s := OrderedCollection new. s add: SequenceableCollection class. s add: Collection class. s add: Object class. s add: ProtoObject class. s add: Class. s add: ClassDescription. s add: Behavior. s add: Object. s add: ProtoObject. self assert: OrderedCollection class allSuperclasses = s. ! ! !BasicBehaviorClassMetaclassTest methodsFor: 'testing' stamp: 'sd 6/5/2005 08:21'! testObjectAllSubclasses "self run: #testObjectAllSubclasses" | n2 | n2 := Object allSubclasses size. self assert: n2 = (Object allSubclasses select: [:cls | cls class class == Metaclass or: [cls class == Metaclass]]) size! ! !BasicBehaviorClassMetaclassTest methodsFor: 'testing' stamp: 'sd 6/5/2005 08:13'! testSuperclass "self run: #testSuperclass" | s | self assert: Dictionary superclass == Set. self assert: OrderedCollection superclass == SequenceableCollection. s := OrderedCollection new. s add: SequenceableCollection. s add: Collection. s add: Object. s add: ProtoObject. self assert: OrderedCollection allSuperclasses = s. ! ! Categorizer subclass: #BasicClassOrganizer instanceVariableNames: 'subject classComment commentStamp' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Classes'! !BasicClassOrganizer methodsFor: 'accessing' stamp: 'NS 4/7/2004 16:02'! classComment classComment ifNil: [^ '']. ^ classComment text ifNil: ['']! ! !BasicClassOrganizer methodsFor: 'accessing' stamp: 'marcus.denker 8/17/2008 20:56'! classComment: aString "Store the comment, aString, associated with the object that refers to the receiver." (aString isKindOf: RemoteString) ifTrue: [classComment := aString] ifFalse: [aString isEmptyOrNil ifTrue: [classComment := nil] ifFalse: [ self error: 'use aClass classComment:'. classComment := RemoteString newString: aString onFileNumber: 2]] "Later add priorSource and date and initials?"! ! !BasicClassOrganizer methodsFor: 'accessing' stamp: 'marcus.denker 8/17/2008 20:56'! classComment: aString stamp: aStamp "Store the comment, aString, associated with the object that refers to the receiver." self commentStamp: aStamp. (aString isKindOf: RemoteString) ifTrue: [classComment := aString] ifFalse: [aString isEmptyOrNil ifTrue: [classComment := nil] ifFalse: [self error: 'use aClass classComment:'. classComment := RemoteString newString: aString onFileNumber: 2]] "Later add priorSource and date and initials?"! ! !BasicClassOrganizer methodsFor: 'accessing' stamp: 'NS 4/7/2004 16:03'! commentRemoteStr ^ classComment! ! !BasicClassOrganizer methodsFor: 'accessing' stamp: 'NS 4/7/2004 16:03'! commentStamp "Answer the comment stamp for the class" ^ commentStamp! ! !BasicClassOrganizer methodsFor: 'accessing' stamp: 'NS 4/7/2004 16:03'! commentStamp: aStamp commentStamp := aStamp! ! !BasicClassOrganizer methodsFor: 'accessing' stamp: 'NS 4/7/2004 16:03'! dateCommentLastSubmitted "Answer a Date object indicating when my class comment was last submitted. If there is no date stamp, or one of the old-time guys, return nil" "RecentMessageSet organization dateCommentLastSubmitted" | aStamp tokens | (aStamp := self commentStamp) isEmptyOrNil ifTrue: [^ nil]. tokens := aStamp findBetweenSubStrs: ' '. "space is expected delimiter, but cr is sometimes seen, though of mysterious provenance" ^ tokens size > 1 ifTrue: [[tokens second asDate] ifError: [nil]] ifFalse: [nil]! ! !BasicClassOrganizer methodsFor: 'accessing' stamp: 'marcus.denker 7/29/2009 15:26'! hasComment "Answer whether the class classified by the receiver has a comment." ^classComment notNil! ! !BasicClassOrganizer methodsFor: 'accessing' stamp: 'NS 4/7/2004 16:04'! hasSubject ^ self subject notNil! ! !BasicClassOrganizer methodsFor: 'accessing' stamp: 'NS 4/7/2004 16:04'! subject ^ subject.! ! !BasicClassOrganizer methodsFor: 'fileIn/Out' stamp: 'NS 4/7/2004 16:03'! fileOutCommentOn: aFileStream moveSource: moveSource toFile: fileIndex "Copy the class comment to aFileStream. If moveSource is true (as in compressChanges or compressSources, then update classComment to point to the new file." | fileComment | classComment ifNotNil: [aFileStream cr. fileComment := RemoteString newString: classComment text onFileNumber: fileIndex toFile: aFileStream. moveSource ifTrue: [classComment := fileComment]]! ! !BasicClassOrganizer methodsFor: 'fileIn/Out' stamp: 'NS 4/7/2004 16:04'! moveChangedCommentToFile: aFileStream numbered: fileIndex "If the comment is in the changes file, then move it to a new file." (classComment ~~ nil and: [classComment sourceFileNumber > 1]) ifTrue: [self fileOutCommentOn: aFileStream moveSource: true toFile: fileIndex]! ! !BasicClassOrganizer methodsFor: 'fileIn/Out' stamp: 'NS 4/7/2004 16:04'! objectForDataStream: refStrm | dp | "I am about to be written on an object file. Write a path to me in the other system instead." self hasSubject ifTrue: [ (refStrm insideASegment and: [self subject isSystemDefined not]) ifTrue: [ ^ self]. "do trace me" (self subject isKindOf: Class) ifTrue: [ dp := DiskProxy global: self subject name selector: #organization args: #(). refStrm replace: self with: dp. ^ dp]]. ^ self "in desparation" ! ! !BasicClassOrganizer methodsFor: 'fileIn/Out' stamp: 'NS 4/7/2004 16:04'! putCommentOnFile: aFileStream numbered: sourceIndex moveSource: moveSource forClass: aClass "Store the comment about the class onto file, aFileStream." | header | classComment ifNotNil: [aFileStream cr; nextPut: $!!. header := String streamContents: [:strm | strm nextPutAll: aClass name; nextPutAll: ' commentStamp: '. commentStamp ifNil: [commentStamp := '']. commentStamp storeOn: strm. strm nextPutAll: ' prior: '; nextPutAll: '0']. aFileStream nextChunkPut: header. aClass organization fileOutCommentOn: aFileStream moveSource: moveSource toFile: sourceIndex. aFileStream cr]! ! !BasicClassOrganizer methodsFor: 'private' stamp: 'NS 4/7/2004 16:04'! setSubject: aClassDescription subject := aClassDescription! ! !BasicClassOrganizer methodsFor: 'deprecated' stamp: 'AndrewBlack 9/3/2009 01:08'! hasNoComment "Answer whether the class classified by the receiver has a comment." self deprecated: 'Use ''hasComment'' instead.' on: '29 July 2009' in: #Pharo1.0. ^classComment == nil! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! BasicClassOrganizer class instanceVariableNames: ''! !BasicClassOrganizer class methodsFor: 'constants' stamp: 'NS 4/19/2004 15:52'! ambiguous ^ #ambiguous! ! !BasicClassOrganizer class methodsFor: 'instance creation' stamp: 'NS 4/7/2004 16:04'! class: aClassDescription ^ self new setSubject: aClassDescription! ! !BasicClassOrganizer class methodsFor: 'instance creation' stamp: 'NS 4/7/2004 16:04'! class: aClassDescription defaultList: aSortedCollection | inst | inst := self defaultList: aSortedCollection. inst setSubject: aClassDescription. ^ inst! ! Inspector subclass: #BasicInspector instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Tools-Inspector'! !BasicInspector methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:26'! inspect: anObject "Initialize the receiver so that it is inspecting anObject. There is no current selection." self initialize. object := anObject. selectionIndex := 0. contents := ''! ! Object subclass: #BasicRequestor instanceVariableNames: 'caption answer' classVariableNames: '' poolDictionaries: '' category: 'Services-Base'! !BasicRequestor commentStamp: 'rr 7/10/2006 14:44' prior: 0! This class is the root of the Requestor hierarchy. Requestors are interfaces between services and the system. ServiceActions are given an instance of a Requestor, and they ask it for the data they need. The requestor is determined by the model of the application. A class used as a model can implement the #requestor message to return the most suited requestor. A requestor knows how to query its model and the user if needed. Requestor are defined in hierarchies so that the protocol they rely on (methods starting with 'get') can be easily reused.! !BasicRequestor methodsFor: 'executing' stamp: 'rr 5/31/2004 22:43'! get: aString self caption: aString. ^ self getSymbol! ! !BasicRequestor methodsFor: 'generic requests' stamp: 'rr 6/1/2004 21:50'! caption: aString caption := aString! ! !BasicRequestor methodsFor: 'generic requests' stamp: 'DamienCassou 9/29/2009 09:02'! getString | result | result := UIManager default request:caption initialAnswer: answer contents. self newCaption. result isEmptyOrNil ifTrue:[ServiceCancelled signal]. ^ result! ! !BasicRequestor methodsFor: 'generic requests' stamp: 'rr 5/31/2004 22:18'! getStringCollection caption := caption, Character cr asString, 'Separate items with space'. ^ (self getString findTokens: ' ') collect: [:each | each copyWithoutAll: ' ' ]! ! !BasicRequestor methodsFor: 'generic requests' stamp: 'rr 5/31/2004 22:19'! getSymbol ^ self getString asSymbol! ! !BasicRequestor methodsFor: 'generic requests' stamp: 'rr 5/31/2004 22:20'! getSymbolCollection ^[self getStringCollection collect: [:each | each asSymbol]] on: ServiceCancelled do: [#()]! ! !BasicRequestor methodsFor: 'generic requests' stamp: 'PeterHugossonMiller 9/3/2009 00:12'! newCaption caption := 'Enter text'. answer := String new writeStream.! ! !BasicRequestor methodsFor: 'initialization' stamp: 'alain.plantec 5/28/2009 09:42'! initialize super initialize. self newCaption! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! BasicRequestor class instanceVariableNames: ''! TestCase subclass: #BecomeTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Tests-VM'! !BecomeTest methodsFor: 'testing' stamp: 'brp 9/19/2003 15:28'! testBecome "Test the two way become. Note. we cannot use string literals for this test" | a b c d | a := 'ab' copy. b := 'cd' copy. c := a. d := b. a become: b. self assert: a = 'cd'; assert: b = 'ab'; assert: c = 'cd'; assert: d = 'ab'. ! ! !BecomeTest methodsFor: 'testing' stamp: 'brp 9/19/2003 15:28'! testBecomeForward "Test the forward become." | a b c d | a := 'ab' copy. b := 'cd' copy. c := a. d := b. a becomeForward: b. self assert: a = 'cd'; assert: b = 'cd'; assert: c = 'cd'; assert: d = 'cd'. ! ! !BecomeTest methodsFor: 'testing' stamp: 'brp 9/19/2003 17:36'! testBecomeForwardDontCopyIdentityHash "Check that 1. the argument to becomeForward: is NOT modified to have the receiver's identity hash. 2. the receiver's identity hash is unchanged." | a b hb | a := 'ab' copy. b := 'cd' copy. hb := b identityHash. a becomeForward: b copyHash: false. self assert: a identityHash = hb; assert: b identityHash = hb. ! ! !BecomeTest methodsFor: 'testing' stamp: 'brp 9/19/2003 15:29'! testBecomeForwardHash | a b c hb | a := 'ab' copy. b := 'cd' copy. c := a. hb := b hash. a becomeForward: b. self assert: a hash = hb; assert: b hash = hb; assert: c hash = hb. ! ! !BecomeTest methodsFor: 'testing' stamp: 'brp 9/19/2003 15:27'! testBecomeForwardIdentityHash "Check that 1. the argument to becomeForward: is modified to have the receiver's identity hash. 2. the receiver's identity hash is unchanged." | a b ha | a := 'ab' copy. b := 'cd' copy. ha := a identityHash. a becomeForward: b. self assert: a identityHash = ha; assert: b identityHash = ha. ! ! !BecomeTest methodsFor: 'testing' stamp: 'brp 9/19/2003 15:30'! testBecomeHash | a b c d ha hb | a := 'ab' copy. b := 'cd' copy. c := a. d := b. ha := a hash. hb := b hash. a become: b. self assert: a hash = hb; assert: b hash = ha; assert: c hash = hb; assert: d hash = ha. ! ! !BecomeTest methodsFor: 'testing' stamp: 'brp 9/19/2003 15:31'! testBecomeIdentityHash "Note. The identity hash of both objects seems to change after the become:" | a b c d | a := 'ab' copy. b := 'cd' copy. c := a. d := b. a become: b. self assert: a identityHash = c identityHash; assert: b identityHash = d identityHash; deny: a identityHash = b identityHash. ! ! Object subclass: #Beeper instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'System-Support'! !Beeper commentStamp: 'gk 2/26/2004 22:44' prior: 0! Beeper provides simple audio (or in some other way) feedback to the user. The recommended use is "Beeper beep" to give the user the equivalence of a beep. If you want to force the beep to use the primitive in the VM for beeping, then use "Beeper beepPrimitive". In either case, if sounds are disabled there will be no beep. The actual beeping, when you use "Beeper beep", is done by sending a #play message to a registered playable object. You can register your own playable object by invoking the class side method #setDefault: passing in an object that responds to the #play message. The default playable object is an instance of Beeper itself which implements #play on the instance side. That implementation delegates the playing of the beep to the default SoundService. Note that #play is introduced as a common interface between AbstractSound and Beeper. This way we can register instances of AbstractSound as playable entities, for example: Beeper setDefault: (SampledSound new setSamples: self coffeeCupClink samplingRate: 12000). Then "Beeper beep" will play the coffeeCup sound.! !Beeper methodsFor: 'play interface' stamp: 'gk 2/24/2004 23:25'! play "This is how the default Beeper makes a beep, by sending beep to the default sound service. The sound system will check if sounds are enabled." SoundService default beep! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Beeper class instanceVariableNames: 'default'! !Beeper class methodsFor: 'beeping' stamp: 'pavel.krivanek 3/11/2009 07:39'! beep "The preferred way of producing an audible feedback. The default playable entity (an instance of Beeper) also uses the pluggable SoundService mechanism, so it will use the primitive beep only if there is no other sound mechanism available." self default ifNil: [self beepPrimitive] ifNotNil: [ self default play]. ! ! !Beeper class methodsFor: 'beeping' stamp: 'gk 2/24/2004 08:38'! beepPrimitive "Make a primitive beep. Only use this if you want to force this to be a primitive beep. Otherwise use Beeper class>>beep since this method bypasses the current registered playable entity." Preferences soundsEnabled ifTrue: [ self primitiveBeep]! ! !Beeper class methodsFor: 'customize' stamp: 'gk 2/22/2004 17:51'! clearDefault "Clear the default playable. Will be lazily initialized in Beeper class >>default." default := nil! ! !Beeper class methodsFor: 'customize' stamp: 'gk 2/22/2004 17:55'! default "When the default is not defined it is initialized using #newDefault." default isNil ifTrue: [default := self newDefault ]. ^ default! ! !Beeper class methodsFor: 'customize' stamp: 'gk 2/24/2004 22:12'! newDefault "Subclasses may override me to provide a default beep. This base implementation returns an instance of Beeper which uses the pluggable sound service." ^ self new! ! !Beeper class methodsFor: 'customize' stamp: 'gk 2/22/2004 17:54'! setDefault: aPlayableEntity "Set the playable entity used when making a beep. The playable entity should implement the message #play." default := aPlayableEntity! ! !Beeper class methodsFor: 'private' stamp: 'gk 2/24/2004 23:51'! primitiveBeep "Make a primitive beep. Not to be called directly. It is much better to use Beeper class>>beep or Beeper class>>beepPrimitive since this method bypasses the current registered playable entity and does not check Preferences class>>soundsEnabled." self primitiveFailed! ! Object subclass: #Behavior uses: TPureBehavior instanceVariableNames: 'superclass methodDict format' classVariableNames: 'ObsoleteSubclasses' poolDictionaries: '' category: 'Kernel-Classes'! !Behavior commentStamp: 'al 12/8/2005 20:44' prior: 0! My instances describe the behavior of other objects. I provide the minimum state necessary for compiling methods, and creating and running instances. Most objects are created as instances of the more fully supported subclass, Class, but I am a good starting point for providing instance-specific behavior (as in Metaclass).! !Behavior methodsFor: '*system-support' stamp: 'tpr 12/17/2003 16:04'! allCallsOn "Answer a SortedCollection of all the methods that refer to me by name or as part of an association in a global dict." ^ (self systemNavigation allCallsOn: (self environment associationAt: self theNonMetaClass name)), (self systemNavigation allCallsOn: self theNonMetaClass name) ! ! !Behavior methodsFor: '*system-support' stamp: 'dvf 8/23/2003 12:43'! allCallsOn: aSymbol "Answer a SortedCollection of all the methods that call on aSymbol." ^ self systemNavigation allCallsOn: aSymbol from: self . ! ! !Behavior methodsFor: '*system-support' stamp: 'stephane.ducasse 10/12/2008 21:02'! allUnsentMessages "Answer an array of all the messages defined by the receiver that are not sent anywhere in the system." ^ SystemNavigation default allUnsentMessagesIn: self selectors! ! !Behavior methodsFor: '*traits'! providedSelectors ^ProvidedSelectors current for: self! ! !Behavior methodsFor: '*traits-requires' stamp: 'NS 5/26/2005 12:11'! classAndMethodFor: aSymbol do: binaryBlock ifAbsent: absentBlock "Looks up the selector aSymbol in the class chain. If it is found, binaryBlock is evaluated with the class that defines the selector and the associated method. Otherwise absentBlock is evaluated." | method | self withAllSuperclassesDo: [:class | method := class compiledMethodAt: aSymbol ifAbsent: [nil]. method ifNotNil: [^ binaryBlock value: class value: method]. ]. ^ absentBlock value.! ! !Behavior methodsFor: '*traits-requires' stamp: 'dvf 9/9/2005 19:45'! classesComposedWithMe ^{self}! ! !Behavior methodsFor: '*traits-requires' stamp: 'NS 5/26/2005 14:27'! computeSelfSendersFromInheritedSelfSenders: inheritedCollection localSelfSenders: localCollection "Compute the set of all self-senders from the set of inherited self-senders and the set of local self-senders." | result mDict | mDict := self methodDict. result := IdentitySet new: inheritedCollection size + localCollection size. "This if-statement is just a performance optimization. Both branches are semantically equivalent." inheritedCollection size > mDict size ifTrue: [ result addAll: inheritedCollection. mDict keysDo: [:each | result remove: each ifAbsent: []]. ] ifFalse: [ inheritedCollection do: [:each | (mDict includesKey: each) ifFalse: [result add: each]]. ]. result addAll: localCollection. ^ result.! ! !Behavior methodsFor: '*traits-requires' stamp: 'NS 5/26/2005 14:11'! computeTranslationsAndUpdateUnreachableSet: unreachableCollection "This method computes the set of unreachable selectors in the superclass by altering the set of unreachable selectors in this class. In addition, it builds a dictionary mapping super-sent selectors to the selectors of methods sending these selectors." | translations reachableSenders oldUnreachable | oldUnreachable := unreachableCollection copy. translations := IdentityDictionary new. "Add selectors implemented in this class to unreachable set." self methodDict keysDo: [:s | unreachableCollection add: s]. "Fill translation dictionary and remove super-reachable selectors from unreachable." self sendCaches superSentSelectorsAndSendersDo: [:sent :senders | reachableSenders := FixedIdentitySet readonlyWithAll: senders notIn: oldUnreachable. reachableSenders isEmpty ifFalse: [ translations at: sent put: reachableSenders. unreachableCollection remove: sent ifAbsent: []. ]. ]. ^ translations! ! !Behavior methodsFor: '*traits-requires' stamp: 'dvf 8/4/2005 16:48'! findSelfSendersOf: selector unreachable: unreachableCollection noInheritedSelfSenders: noInheritedBoolean "This method answers a subset of all the reachable methods (local or inherited) that self-send selector (empty set => no self-senders). See Nathanael Sch䲬i's PhD for more details." | selfSenders reachableSelfSenders translations | "Check whether there are local methods that self-send selector and are reachable." selfSenders := self sendCaches selfSendersOf: selector. reachableSelfSenders := FixedIdentitySet readonlyWithAll: selfSenders notIn: unreachableCollection. (self superclass isNil or: [noInheritedBoolean or: [reachableSelfSenders notEmpty]]) ifTrue: [^ reachableSelfSenders]. "Compute the set of unreachable superclass methods and super-send translations and recurse." translations := self computeTranslationsAndUpdateUnreachableSet: unreachableCollection. reachableSelfSenders := superclass findSelfSendersOf: selector unreachable: unreachableCollection noInheritedSelfSenders: false. "Use the translations to replace selectors that are super-sent with the methods that issue the super-sends." reachableSelfSenders := self translateReachableSelfSenders: reachableSelfSenders translations: translations. ^ reachableSelfSenders.! ! !Behavior methodsFor: '*traits-requires' stamp: 'dvf 9/12/2005 11:44'! requiredSelectors ^RequiredSelectors current for: self! ! !Behavior methodsFor: '*traits-requires' stamp: 'dvf 9/6/2005 13:14'! requiredSelectorsCache ^RequiredSelectors current cacheFor: self! ! !Behavior methodsFor: '*traits-requires' stamp: 'dvf 9/1/2005 16:36'! sendCaches ^LocalSends current for: self! ! !Behavior methodsFor: '*traits-requires' stamp: 'NS 5/24/2005 16:38'! translateReachableSelfSenders: senderCollection translations: translationDictionary | result superSenders | (translationDictionary isEmptyOrNil or: [senderCollection isEmpty]) ifTrue: [^ senderCollection]. result := FixedIdentitySet new. senderCollection do: [:s | superSenders := translationDictionary at: s ifAbsent: [nil]. superSenders isNil ifTrue: [result add: s] ifFalse: [result addAll: superSenders]. result isFull ifTrue: [^ result]. ]. ^ result.! ! !Behavior methodsFor: '*traits-requires' stamp: 'dvf 9/12/2005 18:28'! updateRequiredStatusFor: selector inSubclasses: someClasses "Updates the requirements cache to reflect whether selector is required in this class and some of its subclasses." | inheritedMethod | inheritedMethod := self superclass ifNotNil: [self superclass lookupSelector: selector]. ^self updateRequiredStatusFor: selector inSubclasses: someClasses parentSelfSenders: FixedIdentitySet new providedInParent: inheritedMethod noInheritedSelfSenders: false accumulatingInto: IdentitySet new.! ! !Behavior methodsFor: '*traits-requires' stamp: 'dvf 8/9/2005 17:02'! updateRequiredStatusFor: selector inSubclasses: someClasses parentSelfSenders: inheritedSelfSenders providedInParent: providedBoolean noInheritedSelfSenders: noInheritedBoolean "Updates the requirements cache to reflect whether selector is required in this class and all of its subclasses. The parameter inheritedSelfSenders is a subset of the methods in the parent of this class that are known to self-send selector. providedBoolean indicates whether selector is provided in the parent. noInheritedBoolean is true if no self-senders could be found in the superclass. See Nathanael Sch䲬i's PhD for more details." | selfSenders provided m | "Remove from the inherited selfSenders methods that are potentially unreachable." selfSenders := inheritedSelfSenders reject: [:each | self includesSelector: each]. "Check whether the method is provided." m := self compiledMethodAt: selector ifAbsent: [nil]. providedBoolean ifTrue: [ provided := m isNil or: [m isDisabled not and: [m isExplicitlyRequired not and: [m isSubclassResponsibility not]]]. ] ifFalse: [ provided := m notNil and: [m isProvided]. ]. provided ifTrue: [ "If it is provided, it cannot be required." self setRequiredStatusOf: selector to: false. ] ifFalse: [ "If there are non-overridden inherited selfSenders we know that it must be required. Otherwise, we search for self-senders." selfSenders isEmpty ifTrue: [selfSenders := self findSelfSendersOf: selector unreachable: IdentitySet new noInheritedSelfSenders: noInheritedBoolean]. self setRequiredStatusOf: selector to: selfSenders notEmpty. ]. "Do the same for all subclasses." self subclassesDo: [:each | (someClasses includes: each) ifTrue: [each updateRequiredStatusFor: selector inSubclasses: someClasses parentSelfSenders: selfSenders providedInParent: provided noInheritedSelfSenders: (provided not and: [selfSenders isEmpty])]].! ! !Behavior methodsFor: '*traits-requires' stamp: 'dvf 9/12/2005 19:43'! updateRequiredStatusFor: selector inSubclasses: someClasses parentSelfSenders: inheritedSelfSenders providedInParent: inheritedMethod noInheritedSelfSenders: noInheritedBoolean accumulatingInto: requiringClasses "Updates the requirements cache to reflect whether selector is required in this class and all of its subclasses. The parameter inheritedSelfSenders is a subset of the methods in the parent of this class that are known to self-send selector. providedBoolean indicates whether selector is provided in the parent. noInheritedBoolean is true if no self-senders could be found in the superclass. See Nathanael Sch䲬i's PhD for more details." "Remove from the inherited selfSenders methods that are potentially unreachable." | selfSenders m relevantMethod required lookedForInheritedSelfSenders | lookedForInheritedSelfSenders := false. selfSenders := inheritedSelfSenders reject: [:each | self includesSelector: each]. "Check whether the method is provided." m := self compiledMethodAt: selector ifAbsent: [nil]. relevantMethod := m ifNotNil: [m] ifNil: [inheritedMethod]. relevantMethod ifNotNil: [required := relevantMethod isSubclassResponsibility or: [ relevantMethod isDisabled or: [ relevantMethod isExplicitlyRequired]]] ifNil: ["If there are non-overridden inherited selfSenders we know that it must be required. Otherwise, we search for self-senders." selfSenders isEmpty ifTrue: [selfSenders := self findSelfSendersOf: selector unreachable: IdentitySet new noInheritedSelfSenders: noInheritedBoolean. lookedForInheritedSelfSenders := true]. required := selfSenders notEmpty]. required ifTrue: [requiringClasses add: self]. "Do the same for all subclasses." self subclassesDo: [:each | (someClasses includes: each) ifTrue: [each updateRequiredStatusFor: selector inSubclasses: someClasses parentSelfSenders: selfSenders providedInParent: relevantMethod noInheritedSelfSenders: (lookedForInheritedSelfSenders and: [selfSenders isEmpty]) accumulatingInto: requiringClasses]]. ^requiringClasses! ! !Behavior methodsFor: '*traits-requires' stamp: 'dvf 8/9/2005 15:39'! withInheritanceTraitCompositionIncludes: aTrait ^self withAllSuperclasses anySatisfy: [:c | c traitCompositionIncludes: aTrait]! ! !Behavior methodsFor: 'accessing' stamp: 'ajh 9/19/2001 17:30'! classDepth superclass ifNil: [^ 1]. ^ superclass classDepth + 1! ! !Behavior methodsFor: 'accessing'! compilerClass "Answer a compiler class appropriate for source methods of this class." ^Compiler! ! !Behavior methodsFor: 'accessing'! decompilerClass "Answer a decompiler class appropriate for compiled methods of this class." ^ self compilerClass decompilerClass! ! !Behavior methodsFor: 'accessing'! environment "Return the environment in which the receiver is visible" ^Smalltalk! ! !Behavior methodsFor: 'accessing'! evaluatorClass "Answer an evaluator class appropriate for evaluating expressions in the context of this class." ^Compiler! ! !Behavior methodsFor: 'accessing'! format "Answer an Integer that encodes the kinds and numbers of variables of instances of the receiver." ^format! ! !Behavior methodsFor: 'accessing' stamp: 'di 3/7/2001 17:05'! methodDict methodDict == nil ifTrue: [self recoverFromMDFaultWithTrace]. ^ methodDict! ! !Behavior methodsFor: 'accessing' stamp: 'rca 7/26/2000 16:53'! name "Answer a String that is the name of the receiver." ^'a subclass of ', superclass name! ! !Behavior methodsFor: 'accessing'! parserClass "Answer a parser class to use for parsing method headers." ^self compilerClass parserClass! ! !Behavior methodsFor: 'accessing'! sourceCodeTemplate "Answer an expression to be edited and evaluated in order to define methods in this class or trait." ^'message selector and argument names "comment stating purpose of message" | temporary variable names | statements'! ! !Behavior methodsFor: 'accessing'! subclassDefinerClass "Answer an evaluator class appropriate for evaluating definitions of new subclasses of this class." ^Compiler! ! !Behavior methodsFor: 'accessing' stamp: 'ar 7/13/1999 22:00'! typeOfClass "Answer a symbol uniquely describing the type of the receiver" self instSpec = CompiledMethod instSpec ifTrue:[^#compiledMethod]. "Very special!!" self isBytes ifTrue:[^#bytes]. (self isWords and:[self isPointers not]) ifTrue:[^#words]. self isWeak ifTrue:[^#weak]. self isVariable ifTrue:[^#variable]. ^#normal.! ! !Behavior methodsFor: 'accessing class hierarchy' stamp: 'nb 5/6/2003 17:11'! allSubclasses "Answer a Set of the receiver's and the receiver's descendent's subclasses. " | scan scanTop | scan := OrderedCollection withAll: self subclasses. scanTop := 1. [scanTop > scan size] whileFalse: [scan addAll: (scan at: scanTop) subclasses. scanTop := scanTop + 1]. ^ scan asSet! ! !Behavior methodsFor: 'accessing class hierarchy' stamp: 'sd 3/28/2003 15:06'! allSubclassesWithLevelDo: classAndLevelBlock startingLevel: level "Walk the tree of subclasses, giving the class and its level" | subclassNames | classAndLevelBlock value: self value: level. self == Class ifTrue: [^ self]. "Don't visit all the metaclasses" "Visit subclasses in alphabetical order" subclassNames := SortedCollection new. self subclassesDo: [:subC | subclassNames add: subC name]. subclassNames do: [:name | (self environment at: name) allSubclassesWithLevelDo: classAndLevelBlock startingLevel: level+1]! ! !Behavior methodsFor: 'accessing class hierarchy'! allSuperclasses "Answer an OrderedCollection of the receiver's and the receiver's ancestor's superclasses. The first element is the receiver's immediate superclass, followed by its superclass; the last element is Object." | temp | ^ superclass == nil ifTrue: [ OrderedCollection new] ifFalse: [temp := superclass allSuperclasses. temp addFirst: superclass. temp]! ! !Behavior methodsFor: 'accessing class hierarchy' stamp: 'sd 1/28/2009 14:20'! allSuperclassesIncluding: aClass "Answer an OrderedCollection of the receiver's and the receiver's ancestor's superclasses up to aClass included. The first element is the receiver's immediate superclass up to aClass included." | temp | ^ superclass == aClass ifTrue: [ OrderedCollection with: aClass] ifFalse: [temp := superclass allSuperclassesIncluding: aClass. temp addFirst: superclass. temp]! ! !Behavior methodsFor: 'accessing class hierarchy' stamp: 'sd 3/14/2004 18:09'! subclasses "slow implementation since Behavior does not keep trace of subclasses" ^ self class allInstances select: [:each | each superclass = self ]! ! !Behavior methodsFor: 'accessing class hierarchy'! superclass "Answer the receiver's superclass, a Class." ^superclass! ! !Behavior methodsFor: 'accessing class hierarchy' stamp: 'ar 7/10/1999 12:10'! superclass: aClass "Change the receiver's superclass to be aClass." "Note: Do not use 'aClass isKindOf: Behavior' here in case we recompile from Behavior itself." (aClass == nil or: [aClass isBehavior]) ifTrue: [superclass := aClass. Object flushCache] ifFalse: [self error: 'superclass must be a class-describing object']! ! !Behavior methodsFor: 'accessing class hierarchy'! withAllSubclasses "Answer a Set of the receiver, the receiver's descendent's, and the receiver's descendent's subclasses." ^ self allSubclasses add: self; yourself! ! !Behavior methodsFor: 'accessing class hierarchy'! withAllSuperclasses "Answer an OrderedCollection of the receiver and the receiver's superclasses. The first element is the receiver, followed by its superclass; the last element is Object." | temp | temp := self allSuperclasses. temp addFirst: self. ^ temp! ! !Behavior methodsFor: 'accessing instances and variables'! allClassVarNames "Answer a Set of the names of the receiver's and the receiver's ancestor's class variables." ^superclass allClassVarNames! ! !Behavior methodsFor: 'accessing instances and variables'! allInstVarNames "Answer an Array of the names of the receiver's instance variables. The Array ordering is the order in which the variables are stored and accessed by the interpreter." | vars | superclass == nil ifTrue: [vars := self instVarNames copy] "Guarantee a copy is answered." ifFalse: [vars := superclass allInstVarNames , self instVarNames]. ^vars! ! !Behavior methodsFor: 'accessing instances and variables' stamp: 'MarcusDenker 10/17/2009 16:49'! allInstances "Answer a collection of all current instances of the receiver." | all inst next | all := OrderedCollection new. inst := self someInstance. [inst == nil] whileFalse: [ next := inst nextInstance. inst == all ifFalse: [all add: inst]. inst := next]. ^ all asArray! ! !Behavior methodsFor: 'accessing instances and variables' stamp: 'tpr 5/30/2003 13:04'! allSharedPools "Answer a Set of the names of the pools (Dictionaries or SharedPool subclasses) that the receiver and the receiver's ancestors share." ^superclass allSharedPools! ! !Behavior methodsFor: 'accessing instances and variables' stamp: 'di 6/20/97 10:51'! allSubInstances "Answer a list of all current instances of the receiver and all of its subclasses." | aCollection | aCollection := OrderedCollection new. self allSubInstancesDo: [:x | x == aCollection ifFalse: [aCollection add: x]]. ^ aCollection! ! !Behavior methodsFor: 'accessing instances and variables' stamp: 'ajh 10/17/2002 11:03'! allowsSubInstVars "Classes that allow instances to change classes among its subclasses will want to override this and return false, so inst vars are not accidentally added to its subclasses." ^ true! ! !Behavior methodsFor: 'accessing instances and variables'! classVarNames "Answer a Set of the receiver's class variable names." ^Set new! ! !Behavior methodsFor: 'accessing instances and variables' stamp: 'sw 5/21/2001 22:51'! inspectAllInstances "Inpsect all instances of the receiver. 1/26/96 sw" | all allSize prefix | all := self allInstances. (allSize := all size) == 0 ifTrue: [^ self inform: 'There are no instances of ', self name]. prefix := allSize == 1 ifTrue: ['The lone instance'] ifFalse: ['The ', allSize printString, ' instances']. all asArray inspectWithLabel: (prefix, ' of ', self name)! ! !Behavior methodsFor: 'accessing instances and variables' stamp: 'sw 5/21/2001 22:51'! inspectSubInstances "Inspect all instances of the receiver and all its subclasses. CAUTION - don't do this for something as generic as Object!! 1/26/96 sw" | all allSize prefix | all := self allSubInstances. (allSize := all size) == 0 ifTrue: [^ self inform: 'There are no instances of ', self name, ' or any of its subclasses']. prefix := allSize == 1 ifTrue: ['The lone instance'] ifFalse: ['The ', allSize printString, ' instances']. all asArray inspectWithLabel: (prefix, ' of ', self name, ' & its subclasses')! ! !Behavior methodsFor: 'accessing instances and variables'! instVarNames "Answer an Array of the instance variable names. Behaviors must make up fake local instance variable names because Behaviors have instance variables for the purpose of compiling methods, but these are not named instance variables." | mySize superSize | mySize := self instSize. superSize := superclass == nil ifTrue: [0] ifFalse: [superclass instSize]. mySize = superSize ifTrue: [^#()]. ^(superSize + 1 to: mySize) collect: [:i | 'inst' , i printString]! ! !Behavior methodsFor: 'accessing instances and variables'! instanceCount "Answer the number of instances of the receiver that are currently in use." | count | count := 0. self allInstancesDo: [:x | count := count + 1]. ^count! ! !Behavior methodsFor: 'accessing instances and variables'! sharedPools "Answer a Set of the names of the pools (Dictionaries) that the receiver shares. 9/12/96 tk sharedPools have an order now" ^ OrderedCollection new! ! !Behavior methodsFor: 'accessing instances and variables'! someInstance "Primitive. Answer the first instance in the enumeration of all instances of the receiver. Fails if there are none. Essential. See Object documentation whatIsAPrimitive." ^nil! ! !Behavior methodsFor: 'accessing instances and variables'! subclassInstVarNames "Answer a Set of the names of the receiver's subclasses' instance variables." | vars | vars := Set new. self allSubclasses do: [:aSubclass | vars addAll: aSubclass instVarNames]. ^vars! ! !Behavior methodsFor: 'accessing method dictionary'! >> selector "Answer the compiled method associated with the argument, selector (a Symbol), a message selector in the receiver's method dictionary. If the selector is not in the dictionary, create an error notification." ^self compiledMethodAt: selector ! ! !Behavior methodsFor: 'accessing method dictionary'! addSelector: selector withMethod: compiledMethod ^ self addSelector: selector withMethod: compiledMethod notifying: nil! ! !Behavior methodsFor: 'accessing method dictionary'! addSelector: selector withMethod: compiledMethod notifying: requestor ^ self addSelectorSilently: selector withMethod: compiledMethod! ! !Behavior methodsFor: 'accessing method dictionary'! addSelectorSilently: selector withMethod: compiledMethod self methodDictAddSelectorSilently: selector withMethod: compiledMethod. self registerLocalSelector: selector! ! !Behavior methodsFor: 'accessing method dictionary' stamp: 'kph 8/27/2008 22:31'! allSelectors "Answer all selectors understood by instances of the receiver" ^ self allSelectorsBelow: nil! ! !Behavior methodsFor: 'accessing method dictionary' stamp: 'sd 1/28/2009 14:29'! allSelectorsAbove ^ self allSelectorsAboveUntil: ProtoObject ! ! !Behavior methodsFor: 'accessing method dictionary' stamp: 'sd 1/28/2009 14:28'! allSelectorsAboveUntil: aRootClass | coll | coll := IdentitySet new. (self allSuperclassesIncluding: aRootClass) do: [:aClass | aClass selectorsDo: [ :sel | coll add: sel ]]. ^ coll ! ! !Behavior methodsFor: 'accessing method dictionary' stamp: 'dc 9/28/2008 15:54'! allSelectorsBelow: topClass | coll | coll := IdentitySet new. self withAllSuperclassesDo: [:aClass | aClass = topClass ifTrue: [^ coll ] ifFalse: [aClass selectorsDo: [ :sel | coll add: sel ]]]. ^ coll ! ! !Behavior methodsFor: 'accessing method dictionary' stamp: 'al 6/12/2006 10:48'! basicLocalSelectors "Direct accessor for the instance variable localSelectors. Because of hardcoded ivar indexes of Behavior and Class in the VM, Class and Metaclass declare the needed ivar and override this method as an accessor. By returning nil instead of declaring this method as a subclass responsibility, Behavior can be instantiated for creating anonymous classes." ^nil! ! !Behavior methodsFor: 'accessing method dictionary' stamp: 'al 3/25/2006 13:17'! basicLocalSelectors: aSetOrNil self subclassResponsibility ! ! !Behavior methodsFor: 'accessing method dictionary'! changeRecordsAt: selector "Return a list of ChangeRecords for all versions of the method at selector. Source code can be retrieved by sending string to any one. Return nil if the method is absent." "(Pen changeRecordsAt: #go:) collect: [:cRec | cRec string]" ^ChangeSet scanVersionsOf: (self compiledMethodAt: selector ifAbsent: [^ nil]) class: self meta: self isMeta category: (self whichCategoryIncludesSelector: selector) selector: selector.! ! !Behavior methodsFor: 'accessing method dictionary' stamp: 'mga 3/20/2005 11:11'! commentsAt: selector "Answer a string representing the first comment in the method associated with selector. Return an empty string if the relevant source file is not available, or if the method's source code does not contain a comment. Not smart enough to bypass quotes in string constants, but does map doubled quote into a single quote." ^self commentsIn: (self sourceCodeAt: selector) asString. "Behavior commentsAt: #commentsAt:"! ! !Behavior methodsFor: 'accessing method dictionary' stamp: 'mga 3/21/2005 10:53'! commentsIn: sourceString | commentStart nextQuotePos someComments aPos | ('*"*' match: sourceString) ifFalse: [^#()]. someComments:= OrderedCollection new. sourceString size == 0 ifTrue: [^ someComments]. aPos:=1. nextQuotePos:= 0. [commentStart := sourceString findString: '"' startingAt: aPos. nextQuotePos:= self nextQuotePosIn: sourceString startingFrom: commentStart. (commentStart ~= 0 and: [nextQuotePos >commentStart])] whileTrue: [ commentStart ~= nextQuotePos ifTrue: [ someComments add: ((sourceString copyFrom: commentStart + 1 to: nextQuotePos - 1) copyReplaceAll: '""' with: '"').]. aPos := nextQuotePos+1]. ^someComments! ! !Behavior methodsFor: 'accessing method dictionary'! compiledMethodAt: selector "Answer the compiled method associated with the argument, selector (a Symbol), a message selector in the receiver's method dictionary. If the selector is not in the dictionary, create an error notification." ^ self methodDict at: selector! ! !Behavior methodsFor: 'accessing method dictionary'! compiledMethodAt: selector ifAbsent: aBlock "Answer the compiled method associated with the argument, selector (a Symbol), a message selector in the receiver's method dictionary. If the selector is not in the dictionary, return the value of aBlock" ^ self methodDict at: selector ifAbsent: [aBlock value]! ! !Behavior methodsFor: 'accessing method dictionary'! compress "Compact the method dictionary of the receiver." self methodDict rehash! ! !Behavior methodsFor: 'accessing method dictionary'! compressedSourceCodeAt: selector "(Paragraph compressedSourceCodeAt: #displayLines:affectedRectangle:) size 721 1921 Paragraph selectors inject: 0 into: [:tot :sel | tot + (Paragraph compressedSourceCodeAt: sel) size] 13606 31450" | rawText parse | rawText := (self sourceCodeAt: selector) asString. parse := self compilerClass new parse: rawText in: self notifying: nil. ^ rawText compressWithTable: ((selector keywords , parse tempNames , self instVarNames , #(self super ifTrue: ifFalse:) , ((0 to: 7) collect: [:i | String streamContents: [:s | s cr. i timesRepeat: [s tab]]]) , (self compiledMethodAt: selector) literalStrings) asSortedCollection: [:a :b | a size > b size])! ! !Behavior methodsFor: 'accessing method dictionary'! deregisterLocalSelector: aSymbol self basicLocalSelectors notNil ifTrue: [ self basicLocalSelectors remove: aSymbol ifAbsent: []]! ! !Behavior methodsFor: 'accessing method dictionary'! firstCommentAt: selector "Answer a string representing the first comment in the method associated with selector. Return an empty string if the relevant source file is not available, or if the method's source code does not contain a comment. Not smart enough to bypass quotes in string constants, but does map doubled quote into a single quote." |someComments| someComments := self commentsAt: selector. ^someComments isEmpty ifTrue: [''] ifFalse: [someComments first] "Behavior firstCommentAt: #firstCommentAt:"! ! !Behavior methodsFor: 'accessing method dictionary' stamp: 'damiencassou 5/30/2008 10:56'! firstPrecodeCommentFor: selector "If there is a comment in the source code at the given selector that preceeds the body of the method, return it here, else return nil" "Behavior firstPrecodeCommentFor: #firstPrecodeCommentFor:" | parser source tree | (#(#Comment #Definition #Hierarchy ) includes: selector) ifTrue: [ "Not really a selector" ^ nil ]. source := self sourceCodeAt: selector asSymbol ifAbsent: [ ^ nil ]. parser := self parserClass new. tree := parser parse: source readStream class: self noPattern: false context: nil notifying: nil ifFail: [ ^ nil ]. ^ (tree comment ifNil: [ ^ nil ]) first! ! !Behavior methodsFor: 'accessing method dictionary'! "popeye" formalHeaderPartsFor: "olive oil" aSelector "RELAX!! The warning you may have just seen about possibly having a bad source file does not apply here, because this method *intends* to have its source code start with a comment. This method returns a collection giving the parts in the formal declaration for aSelector. This parse is in support of schemes in which adjutant properties of a method can be declared via special comments secreted in the formal header The result will have 3 elements for a simple, argumentless selector. 5 elements for a single-argument selector 9 elements for a two-argument selector 13 elements for a three-argument, selector etc... The syntactic elements are: 1 comment preceding initial selector fragment 2 first selector fragment 3 comment following first selector fragment (nil if selector has no arguments) ---------------------- (ends here for, e.g., #copy) 4 first formal argument 5 comment following first formal argument (nil if selector has only one argument) ---------------------- (ends here for, e.g., #copyFrom:) 6 second keyword 7 comment following second keyword 8 second formal argument 9 comment following second formal argument (nil if selector has only two arguments) ---------------------- (ends here for, e.g., #copyFrom:to:) Any nil element signifies an absent comment. NOTE: The comment following the final formal argument is *not* successfully retrieved by this method in its current form, though it can be obtained, if needed, by other means (e.g. calling #firstPrecodeCommentFor:). Thus, the *final* element in the structure returned by this method is always going to be nil." ^ Scanner new scanMessageParts: (self methodHeaderFor: aSelector) " Behavior class formalHeaderPartsFor: #formalHeaderPartsFor: " ! ! !Behavior methodsFor: 'accessing method dictionary'! formalParametersAt: aSelector "Return the names of the arguments used in this method." | source parser message list params | source := self sourceCodeAt: aSelector ifAbsent: [^ #()]. "for now" (parser := self parserClass new) parseSelector: source. message := source copyFrom: 1 to: (parser endOfLastToken min: source size). list := message string findTokens: Character separators. params := OrderedCollection new. list withIndexDo: [:token :ind | ind even ifTrue: [params addLast: token]]. ^ params! ! !Behavior methodsFor: 'accessing method dictionary' stamp: 'di 1/2/1999 15:45'! lookupSelector: selector "Look up the given selector in my methodDictionary. Return the corresponding method if found. Otherwise chase the superclass chain and try again. Return nil if no method is found." | lookupClass | lookupClass := self. [lookupClass == nil] whileFalse: [(lookupClass includesSelector: selector) ifTrue: [^ lookupClass compiledMethodAt: selector]. lookupClass := lookupClass superclass]. ^ nil! ! !Behavior methodsFor: 'accessing method dictionary' stamp: 'dvf 9/27/2005 17:08'! methodDict: aDictionary methodDict := aDictionary! ! !Behavior methodsFor: 'accessing method dictionary'! methodDictionary "Convenience" ^self methodDict! ! !Behavior methodsFor: 'accessing method dictionary'! methodDictionary: aDictionary self methodDict: aDictionary! ! !Behavior methodsFor: 'accessing method dictionary'! methodHeaderFor: selector "Answer the string corresponding to the method header for the given selector" | sourceString parser | sourceString := self ultimateSourceCodeAt: selector ifAbsent: [self standardMethodHeaderFor: selector]. (parser := self parserClass new) parseSelector: sourceString. ^ sourceString asString copyFrom: 1 to: (parser endOfLastToken min: sourceString size) "Behavior methodHeaderFor: #methodHeaderFor: " ! ! !Behavior methodsFor: 'accessing method dictionary'! methodsDo: aBlock "Evaluate aBlock for all the compiled methods in my method dictionary." ^ self methodDict valuesDo: aBlock! ! !Behavior methodsFor: 'accessing method dictionary' stamp: 'mga 3/21/2005 12:04'! nextQuotePosIn: sourceString startingFrom: commentStart | pos nextQuotePos | pos := commentStart + 1. [((nextQuotePos := sourceString findString: '"' startingAt: pos) == (sourceString findString: '""' startingAt: pos)) and: [nextQuotePos ~= 0]] whileTrue: [pos := nextQuotePos + 2]. ^nextQuotePos! ! !Behavior methodsFor: 'accessing method dictionary'! precodeCommentOrInheritedCommentFor: selector "Answer a string representing the first comment in the method associated with selector, considering however only comments that occur before the beginning of the actual code. If the version recorded in the receiver is uncommented, look up the inheritance chain. Return nil if none found." | aSuper aComment | ^ (aComment := self firstPrecodeCommentFor: selector) isEmptyOrNil ifTrue: [(self == Behavior or: [superclass == nil or: [(aSuper := superclass whichClassIncludesSelector: selector) == nil]]) ifFalse: [aSuper precodeCommentOrInheritedCommentFor: selector] "ActorState precodeCommentOrInheritedCommentFor: #printOn:"] ifFalse: [aComment]! ! !Behavior methodsFor: 'accessing method dictionary'! registerLocalSelector: aSymbol self basicLocalSelectors notNil ifTrue: [ self basicLocalSelectors add: aSymbol]! ! !Behavior methodsFor: 'accessing method dictionary'! removeSelector: aSelector "Assuming that the argument, selector (a Symbol), is a message selector in my method dictionary, remove it and its method. If the method to remove will be replaced by a method from my trait composition, the current method does not have to be removed because we mark it as non-local. If it is not identical to the actual method from the trait it will be replaced automatically by #noteChangedSelectors:. This is useful to avoid bootstrapping problems when moving methods to a trait (e.g., from TPureBehavior to TMethodDictionaryBehavior). Manual moving (implementing the method in the trait and then remove it from the class) does not work if the methods themselves are used for this process (such as compiledMethodAt:, includesLocalSelector: or addTraitSelector:withMethod:)" | changeFromLocalToTraitMethod | changeFromLocalToTraitMethod := (self includesLocalSelector: aSelector) and: [self hasTraitComposition] and: [self traitComposition includesMethod: aSelector]. changeFromLocalToTraitMethod ifFalse: [self basicRemoveSelector: aSelector] ifTrue: [self ensureLocalSelectors]. self deregisterLocalSelector: aSelector. self noteChangedSelectors: (Array with: aSelector) ! ! !Behavior methodsFor: 'accessing method dictionary'! removeSelectorSilently: selector "Remove selector without sending system change notifications" ^ SystemChangeNotifier uniqueInstance doSilently: [self removeSelector: selector].! ! !Behavior methodsFor: 'accessing method dictionary' stamp: 'di 3/27/1999 13:02'! rootStubInImageSegment: imageSegment ^ ImageSegmentRootStub new xxSuperclass: superclass format: format segment: imageSegment! ! !Behavior methodsFor: 'accessing method dictionary'! selectors "Answer a Set of all the message selectors specified in the receiver's method dictionary." ^ self methodDict keys! ! !Behavior methodsFor: 'accessing method dictionary'! selectorsAndMethodsDo: aBlock "Evaluate selectorBlock for all the message selectors in my method dictionary." ^ self methodDict keysAndValuesDo: aBlock! ! !Behavior methodsFor: 'accessing method dictionary'! selectorsDo: selectorBlock "Evaluate selectorBlock for all the message selectors in my method dictionary." ^ self methodDict keysDo: selectorBlock! ! !Behavior methodsFor: 'accessing method dictionary' stamp: 'md 1/2/2006 18:56'! selectorsWithArgs: numberOfArgs "Return all selectors defined in this class that take this number of arguments" ^ self selectors select: [:selector | selector numArgs = numberOfArgs]! ! !Behavior methodsFor: 'accessing method dictionary'! sourceCodeAt: selector ^ (self methodDict at: selector) getSourceFor: selector in: self! ! !Behavior methodsFor: 'accessing method dictionary'! sourceCodeAt: selector ifAbsent: aBlock ^ (self methodDict at: selector ifAbsent: [^ aBlock value]) getSourceFor: selector in: self! ! !Behavior methodsFor: 'accessing method dictionary'! sourceMethodAt: selector "Answer the paragraph corresponding to the source code for the argument." ^(self sourceCodeAt: selector) asText makeSelectorBoldIn: self! ! !Behavior methodsFor: 'accessing method dictionary'! sourceMethodAt: selector ifAbsent: aBlock "Answer the paragraph corresponding to the source code for the argument." ^ (self sourceCodeAt: selector ifAbsent: [^ aBlock value]) asText makeSelectorBoldIn: self! ! !Behavior methodsFor: 'accessing method dictionary'! standardMethodHeaderFor: aSelector | args | args := (1 to: aSelector numArgs) collect:[:i| 'arg', i printString]. args size = 0 ifTrue:[^aSelector asString]. args size = 1 ifTrue:[^aSelector,' arg1']. ^String streamContents:[:s| (aSelector findTokens:':') with: args do:[:tok :arg| s nextPutAll: tok; nextPutAll:': '; nextPutAll: arg; nextPutAll:' '. ]. ]. ! ! !Behavior methodsFor: 'accessing method dictionary'! supermostPrecodeCommentFor: selector "Answer a string representing the precode comment in the most distant superclass's implementation of the selector. Return nil if none found." | aSuper superComment | (self == Behavior or: [superclass == nil or: [(aSuper := superclass whichClassIncludesSelector: selector) == nil]]) ifFalse: ["There is a super implementor" superComment := aSuper supermostPrecodeCommentFor: selector]. ^ superComment ifNil: [self firstPrecodeCommentFor: selector "ActorState supermostPrecodeCommentFor: #printOn:"]! ! !Behavior methodsFor: 'accessing method dictionary' stamp: 'al 12/6/2004 11:36'! ultimateSourceCodeAt: selector ifAbsent: aBlock "Return the source code at selector, deferring to superclass if necessary" ^ self sourceCodeAt: selector ifAbsent: [superclass ifNil: [aBlock value] ifNotNil: [superclass ultimateSourceCodeAt: selector ifAbsent: aBlock]]! ! !Behavior methodsFor: 'accessing method dictionary' stamp: 'sd 11/19/2004 15:18'! zapAllMethods "Remove all methods in this class which is assumed to be obsolete" methodDict := self emptyMethodDictionary. self class isMeta ifTrue: [self class zapAllMethods]! ! !Behavior methodsFor: 'adding/removing methods'! basicAddSelector: selector withMethod: compiledMethod "Add the message selector with the corresponding compiled method to the receiver's method dictionary. Do this without sending system change notifications" | oldMethodOrNil | oldMethodOrNil := self lookupSelector: selector. self methodDict at: selector put: compiledMethod. compiledMethod methodClass: self. compiledMethod selector: selector. "Now flush Squeak's method cache, either by selector or by method" oldMethodOrNil ifNotNil: [oldMethodOrNil flushCache]. selector flushCache.! ! !Behavior methodsFor: 'adding/removing methods'! localSelectors "Return a set of selectors defined locally. The instance variable is lazily initialized. If it is nil then there are no non-local selectors" ^ self basicLocalSelectors isNil ifTrue: [self selectors] ifFalse: [self basicLocalSelectors].! ! !Behavior methodsFor: 'adding/removing methods'! methodDictAddSelectorSilently: selector withMethod: compiledMethod self basicAddSelector: selector withMethod: compiledMethod! ! !Behavior methodsFor: 'compiling'! binding ^ nil -> self! ! !Behavior methodsFor: 'compiling'! compile: code "Compile the argument, code, as source code in the context of the receiver. Create an error notification if the code can not be compiled. The argument is either a string or an object that converts to a string or a PositionableStream on an object that converts to a string." ^self compile: code notifying: nil! ! !Behavior methodsFor: 'compiling'! compile: code classified: category notifying: requestor trailer: bytes ifFail: failBlock "Compile code without logging the source in the changes file" | methodNode | methodNode := self compilerClass new compile: code in: self classified: category notifying: requestor ifFail: failBlock. ^ CompiledMethodWithNode generateMethodFromNode: methodNode trailer: bytes.! ! !Behavior methodsFor: 'compiling'! compile: code notifying: requestor "Compile the argument, code, as source code in the context of the receiver and insEtall the result in the receiver's method dictionary. The second argument, requestor, is to be notified if an error occurs. The argument code is either a string or an object that converts to a string or a PositionableStream. This method also saves the source code." | methodAndNode | methodAndNode := self compile: code "a Text" classified: nil notifying: requestor trailer: self defaultMethodTrailer ifFail: [^nil]. methodAndNode method putSource: code fromParseNode: methodAndNode node inFile: 2 withPreamble: [:f | f cr; nextPut: $!!; nextChunkPut: 'Behavior method'; cr]. self addSelector: methodAndNode selector withMethod: methodAndNode method notifying: requestor. ^ methodAndNode selector! ! !Behavior methodsFor: 'compiling'! compileAll ^ self compileAllFrom: self! ! !Behavior methodsFor: 'compiling'! compileAllFrom: oldClass "Compile all the methods in the receiver's method dictionary. This validates sourceCode and variable references and forces all methods to use the current bytecode set" "ar 7/10/1999: Use oldClass selectors not self selectors" oldClass selectorsDo: [:sel | self recompile: sel from: oldClass]. self environment currentProjectDo: [:proj | proj compileAllIsolated: self from: oldClass].! ! !Behavior methodsFor: 'compiling'! decompile: selector "Find the compiled code associated with the argument, selector, as a message selector in the receiver's method dictionary and decompile it. Answer the resulting source code as a string. Create an error notification if the selector is not in the receiver's method dictionary." ^self decompilerClass new decompile: selector in: self! ! !Behavior methodsFor: 'compiling'! defaultMethodTrailer ^ #(0 0 0 0)! ! !Behavior methodsFor: 'compiling' stamp: 'eem 5/13/2008 09:50'! instVarNamesAndOffsetsDo: aBinaryBlock "This is part of the interface between the compiler and a class's instance or field names. The class should enumerate aBinaryBlock with the instance variable name strings and their integer offsets. The order is important. Names evaluated later will override the same names occurring earlier." "Nothing to do here; ClassDescription introduces named instance variables" ^self! ! !Behavior methodsFor: 'compiling'! recompile: selector "Compile the method associated with selector in the receiver's method dictionary." ^self recompile: selector from: self! ! !Behavior methodsFor: 'compiling'! recompile: selector from: oldClass "Compile the method associated with selector in the receiver's method dictionary." "ar 7/10/1999: Use oldClass compiledMethodAt: not self compiledMethodAt:" | method trailer methodNode | method := oldClass compiledMethodAt: selector. trailer := method trailer. methodNode := self compilerClass new compile: (oldClass sourceCodeAt: selector) in: self notifying: nil ifFail: [^ self]. "Assume OK after proceed from SyntaxError" selector == methodNode selector ifFalse: [self error: 'selector changed!!']. self basicAddSelector: selector withMethod: (methodNode generate: trailer). ! ! !Behavior methodsFor: 'compiling'! recompileChanges "Compile all the methods that are in the changes file. This validates sourceCode and variable references and forces methods to use the current bytecode set" self selectorsDo: [:sel | (self compiledMethodAt: sel) fileIndex > 1 ifTrue: [self recompile: sel from: self]]! ! !Behavior methodsFor: 'compiling'! recompileNonResidentMethod: method atSelector: selector from: oldClass "Recompile the method supplied in the context of this class." | trailer methodNode | trailer := method trailer. methodNode := self compilerClass new compile: (method getSourceFor: selector in: oldClass) in: self notifying: nil ifFail: ["We're in deep doo-doo if this fails (syntax error). Presumably the user will correct something and proceed, thus installing the result in this methodDict. We must retrieve that new method, and restore the original (or remove) and then return the method we retrieved." ^ self error: 'see comment']. selector == methodNode selector ifFalse: [self error: 'selector changed!!']. ^ methodNode generate: trailer ! ! !Behavior methodsFor: 'compiling' stamp: 'eem 6/19/2008 09:08'! variablesAndOffsetsDo: aBinaryBlock "This is the interface between the compiler and a class's instance or field names. The class should enumerate aBinaryBlock with the field definitions (with nil offsets) followed by the instance variable name strings and their integer offsets (1-relative). The order is important; names evaluated later will override the same names occurring earlier." "Only need to do instance variables here. CProtoObject introduces field definitions." self instVarNamesAndOffsetsDo: aBinaryBlock! ! !Behavior methodsFor: 'copying'! copy "Answer a copy of the receiver without a list of subclasses." | myCopy | myCopy := self shallowCopy. ^myCopy methodDictionary: self copyOfMethodDictionary! ! !Behavior methodsFor: 'copying'! copyOfMethodDictionary "Return a copy of the receiver's method dictionary" ^ self methodDict copy! ! !Behavior methodsFor: 'copying'! deepCopy "Classes should only be shallowCopied or made anew." ^ self shallowCopy! ! !Behavior methodsFor: 'enumerating' stamp: 'apb 7/13/2004 00:40'! allInstancesDo: aBlock "Evaluate the argument, aBlock, for each of the current instances of the receiver. Because aBlock might change the class of inst (for example, using become:), it is essential to compute next before aBlock value: inst." | inst next | self == UndefinedObject ifTrue: [^ aBlock value: nil]. inst := self someInstance. [inst == nil] whileFalse: [ next := inst nextInstance. aBlock value: inst. inst := next]! ! !Behavior methodsFor: 'enumerating' stamp: 'tk 11/12/1999 11:36'! allInstancesEverywhereDo: aBlock "Evaluate the argument, aBlock, for each of the current instances of the receiver. Including those in ImageSegments that are out on the disk. Bring each in briefly." self == UndefinedObject ifTrue: [^ aBlock value: nil]. self allInstancesDo: aBlock. "Now iterate over instances in segments that are out on the disk." ImageSegment allSubInstancesDo: [:seg | seg allInstancesOf: self do: aBlock]. ! ! !Behavior methodsFor: 'enumerating' stamp: 'di 6/20/97 10:50'! allSubInstancesDo: aBlock "Evaluate the argument, aBlock, for each of the current instances of the receiver and all its subclasses." self allInstancesDo: aBlock. self allSubclassesDo: [:sub | sub allInstancesDo: aBlock]! ! !Behavior methodsFor: 'enumerating'! allSubclassesDo: aBlock "Evaluate the argument, aBlock, for each of the receiver's subclasses." self subclassesDo: [:cl | aBlock value: cl. cl allSubclassesDo: aBlock]! ! !Behavior methodsFor: 'enumerating' stamp: 'tk 8/18/1999 17:38'! allSubclassesDoGently: aBlock "Evaluate the argument, aBlock, for each of the receiver's subclasses." self subclassesDoGently: [:cl | cl isInMemory ifTrue: [ aBlock value: cl. cl allSubclassesDoGently: aBlock]]! ! !Behavior methodsFor: 'enumerating'! allSuperclassesDo: aBlock "Evaluate the argument, aBlock, for each of the receiver's superclasses." superclass == nil ifFalse: [aBlock value: superclass. superclass allSuperclassesDo: aBlock]! ! !Behavior methodsFor: 'enumerating'! selectSubclasses: aBlock "Evaluate the argument, aBlock, with each of the receiver's (next level) subclasses as its argument. Collect into a Set only those subclasses for which aBlock evaluates to true. In addition, evaluate aBlock for the subclasses of each of these successful subclasses and collect into the set those for which aBlock evaluates true. Answer the resulting set." | aSet | aSet := Set new. self allSubclasses do: [:aSubclass | (aBlock value: aSubclass) ifTrue: [aSet add: aSubclass]]. ^aSet! ! !Behavior methodsFor: 'enumerating'! selectSuperclasses: aBlock "Evaluate the argument, aBlock, with the receiver's superclasses as the argument. Collect into an OrderedCollection only those superclasses for which aBlock evaluates to true. In addition, evaluate aBlock for the superclasses of each of these successful superclasses and collect into the OrderedCollection ones for which aBlock evaluates to true. Answer the resulting OrderedCollection." | aSet | aSet := Set new. self allSuperclasses do: [:aSuperclass | (aBlock value: aSuperclass) ifTrue: [aSet add: aSuperclass]]. ^aSet! ! !Behavior methodsFor: 'enumerating'! withAllSubclassesDo: aBlock "Evaluate the argument, aBlock, for the receiver and each of its subclasses." aBlock value: self. self allSubclassesDo: aBlock! ! !Behavior methodsFor: 'enumerating' stamp: 'nk 2/14/2001 12:09'! withAllSuperAndSubclassesDoGently: aBlock self allSuperclassesDo: aBlock. aBlock value: self. self allSubclassesDoGently: aBlock! ! !Behavior methodsFor: 'enumerating' stamp: 'ar 7/11/1999 04:21'! withAllSuperclassesDo: aBlock "Evaluate the argument, aBlock, for each of the receiver's superclasses." aBlock value: self. superclass == nil ifFalse: [superclass withAllSuperclassesDo: aBlock]! ! !Behavior methodsFor: 'initialize-release'! emptyMethodDictionary ^ MethodDictionary new! ! !Behavior methodsFor: 'initialize-release' stamp: 'NS 1/28/2004 11:17'! forgetDoIts "get rid of old DoIt methods" self basicRemoveSelector: #DoIt; basicRemoveSelector: #DoItIn:! ! !Behavior methodsFor: 'initialize-release' stamp: 'alain.plantec 5/28/2009 09:43'! initialize "moved here from the class side's #new" super initialize. superclass := Object. "no longer sending any messages, some of them crash the VM" methodDict := self emptyMethodDictionary. format := Object format! ! !Behavior methodsFor: 'initialize-release' stamp: 'sd 3/28/2003 15:07'! nonObsoleteClass "Attempt to find and return the current version of this obsolete class" | obsName | obsName := self name. [obsName beginsWith: 'AnObsolete'] whileTrue: [obsName := obsName copyFrom: 'AnObsolete' size + 1 to: obsName size]. ^ self environment at: obsName asSymbol! ! !Behavior methodsFor: 'initialize-release'! obsolete "Invalidate and recycle local methods, e.g., zap the method dictionary if can be done safely." self canZapMethodDictionary ifTrue: [self methodDict: self emptyMethodDictionary]. self hasTraitComposition ifTrue: [ self traitComposition traits do: [:each | each removeUser: self]]! ! !Behavior methodsFor: 'initialize-release' stamp: 'al 12/12/2003 20:59'! superclass: aClass methodDictionary: mDict format: fmt "Basic initialization of the receiver. Must only be sent to a new instance; else we would need Object flushCache." superclass := aClass. format := fmt. methodDict := mDict. self traitComposition: nil! ! !Behavior methodsFor: 'instance creation' stamp: 'sd 3/28/2003 15:06'! basicNew "Primitive. Answer an instance of the receiver (which is a class) with no indexable variables. Fail if the class is indexable. Essential. See Object documentation whatIsAPrimitive." self isVariable ifTrue: [ ^ self basicNew: 0 ]. "space must be low" self environment signalLowSpace. ^ self basicNew "retry if user proceeds" ! ! !Behavior methodsFor: 'instance creation' stamp: 'sd 3/28/2003 15:06'! basicNew: sizeRequested "Primitive. Answer an instance of this class with the number of indexable variables specified by the argument, sizeRequested. Fail if this class is not indexable or if the argument is not a positive Integer, or if there is not enough memory available. Essential. See Object documentation whatIsAPrimitive." self isVariable ifFalse: [self error: self printString, ' cannot have variable sized instances']. (sizeRequested isInteger and: [sizeRequested >= 0]) ifTrue: ["arg okay; space must be low." self environment signalLowSpace. ^ self basicNew: sizeRequested "retry if user proceeds"]. self primitiveFailed! ! !Behavior methodsFor: 'instance creation' stamp: 'sw 5/4/2000 20:47'! initializedInstance "Answer an instance of the receiver which in some sense is initialized. In the case of Morphs, this will yield an instance that can be attached to the Hand after having received the same kind of basic initialization that would be obtained from an instance chosen from the 'new morph' menu. Return nil if the receiver is reluctant for some reason to return such a thing" ^ self new! ! !Behavior methodsFor: 'instance creation' stamp: 'Noury Bouraqadi 8/23/2003 14:51'! new "Answer a new initialized instance of the receiver (which is a class) with no indexable variables. Fail if the class is indexable." ^ self basicNew initialize ! ! !Behavior methodsFor: 'instance creation' stamp: 'sd 5/20/2004 11:20'! new: sizeRequested "Answer an initialized instance of this class with the number of indexable variables specified by the argument, sizeRequested." ^ (self basicNew: sizeRequested) initialize ! ! !Behavior methodsFor: 'newcompiler'! parseScope ^ Smalltalk at: #ClassScope ifPresent: [:class | class new class: self]! ! !Behavior methodsFor: 'obsolete subclasses' stamp: 'apb 7/12/2004 23:13'! addObsoleteSubclass: aClass "Weakly remember that aClass was a subclass of the receiver and is now obsolete" | obs | obs := ObsoleteSubclasses at: self ifAbsent:[WeakArray new]. (obs includes: aClass) ifTrue:[^self]. obs := obs copyWithout: nil. obs := obs copyWith: aClass. ObsoleteSubclasses at: self put: obs. ! ! !Behavior methodsFor: 'obsolete subclasses' stamp: 'apb 7/12/2004 23:20'! obsoleteSubclasses "Return all the weakly remembered obsolete subclasses of the receiver" | obs | obs := ObsoleteSubclasses at: self ifAbsent: [^ #()]. ^ obs copyWithout: nil! ! !Behavior methodsFor: 'obsolete subclasses' stamp: 'apb 7/12/2004 23:21'! removeAllObsoleteSubclasses "Remove all the obsolete subclasses of the receiver" ObsoleteSubclasses removeKey: self ifAbsent: []. ! ! !Behavior methodsFor: 'obsolete subclasses' stamp: 'apb 7/12/2004 23:22'! removeObsoleteSubclass: aClass "Remove aClass from the weakly remembered obsolete subclasses" | obs | obs := ObsoleteSubclasses at: self ifAbsent:[^ self]. (obs includes: aClass) ifFalse:[^self]. obs := obs copyWithout: aClass. obs := obs copyWithout: nil. ObsoleteSubclasses at: self put: obs! ! !Behavior methodsFor: 'printing'! defaultNameStemForInstances "Answer a basis for external names for default instances of the receiver. For classees, the class-name itself is a good one." ^ self name! ! !Behavior methodsFor: 'printing'! literalScannedAs: scannedLiteral notifying: requestor "Postprocesses a literal scanned by Scanner scanToken (esp. xLitQuote). If scannedLiteral is not an association, answer it. Else, if it is of the form: nil->#NameOfMetaclass answer nil->theMetaclass, if any has that name, else report an error. Else, if it is of the form: #NameOfGlobalVariable->anythiEng answer the global, class, or pool association with that nameE, if any, else add it to Undeclared a answer the new Association." | key value | (scannedLiteral isVariableBinding) ifFalse: [^ scannedLiteral]. key := scannedLiteral key. value := scannedLiteral value. key isNil ifTrue: "###" [(self bindingOf: value) ifNotNil:[:assoc| (assoc value isKindOf: Behavior) ifTrue: [^ nil->assoc value class]]. requestor notify: 'No such metaclass'. ^false]. (key isSymbol) ifTrue: "##" [(self bindingOf: key) ifNotNil:[:assoc | ^assoc]. Undeclared at: key put: nil. ^Undeclared bindingOf: key]. requestor notify: '## must be followed by a non-local variable name'. ^false " Form literalScannedAs: 14 notifying: nil 14 Form literalScannedAs: #OneBitForm notiEfying: nil OneBitForm Form literalScannedAs: ##OneBitForm notifying: nil OneBitForm->a Form Form literalScannedAs: ##Form notifying: nil Form->Form Form literalScannedAs: ###Form notifying: nil nilE->Form class "! ! !Behavior methodsFor: 'printing'! longPrintOn: aStream "Append to the argument, aStream, the names and values of all of the receiver's instance variables. But, not useful for a class with a method dictionary." aStream nextPutAll: '<>'; cr.! ! !Behavior methodsFor: 'printing'! prettyPrinterClass ^ PrettyPrinting prettyPrinterClassFor: self! ! !Behavior methodsFor: 'printing' stamp: 'PeterHugossonMiller 9/3/2009 00:11'! printHierarchy "Answer a description containing the names and instance variable names of all of the subclasses and superclasses of the receiver." | aStream index | index := 0. aStream := (String new: 16) writeStream. self allSuperclasses reverseDo: [:aClass | aStream crtab: index. index := index + 1. aStream nextPutAll: aClass name. aStream space. aStream print: aClass instVarNames]. aStream cr. self printSubclassesOn: aStream level: index. ^aStream contents! ! !Behavior methodsFor: 'printing'! printOn: aStream "Refer to the comment in Object|printOn:." aStream nextPutAll: 'a descendent of '. superclass printOn: aStream! ! !Behavior methodsFor: 'printing' stamp: 'MPW 1/1/1901 21:56'! printOnStream: aStream "Refer to the comment in Object|printOn:." aStream print: 'a descendent of '; write:superclass.! ! !Behavior methodsFor: 'printing' stamp: 'eem 6/2/2008 11:47'! printWithClosureAnalysisOn: aStream "Refer to the comment in Object|printOn:." aStream nextPutAll: 'a descendent of '. superclass printWithClosureAnalysisOn: aStream! ! !Behavior methodsFor: 'printing'! storeLiteral: aCodeLiteral on: aStream "Store aCodeLiteral on aStream, changing an Association to ##GlobalName or ###MetaclassSoleInstanceName format if appropriate" | key value | (aCodeLiteral isVariableBinding) ifFalse: [aCodeLiteral storeOn: aStream. ^self]. key := aCodeLiteral key. (key isNil and: [(value := aCodeLiteral value) isMemberOf: Metaclass]) ifTrue: [aStream nextPutAll: '###'; nextPutAll: value soleInstance name. ^self]. (key isSymbol and: [(self bindingOf: key) notNil]) ifTrue: [aStream nextPutAll: '##'; nextPutAll: key. ^self]. aCodeLiteral storeOn: aStream! ! !Behavior methodsFor: 'queries' stamp: 'dvf 9/17/2001 00:18'! whichClassDefinesClassVar: aString ^self whichSuperclassSatisfies: [:aClass | (aClass classVarNames collect: [:each | each asString]) includes: aString asString]! ! !Behavior methodsFor: 'queries' stamp: 'dvf 9/17/2001 00:18'! whichClassDefinesInstVar: aString ^self whichSuperclassSatisfies: [:aClass | aClass instVarNames includes: aString]! ! !Behavior methodsFor: 'queries' stamp: 'bh 3/6/2000 00:51'! whichSelectorsAssign: instVarName "Answer a Set of selectors whose methods store into the argument, instVarName, as a named instance variable." ^self whichSelectorsStoreInto: instVarName! ! !Behavior methodsFor: 'queries' stamp: 'bh 3/6/2000 00:52'! whichSelectorsRead: instVarName "Answer a Set of selectors whose methods access the argument, instVarName, as a named instance variable." ^self whichSelectorsAccess: instVarName! ! !Behavior methodsFor: 'queries' stamp: 'dvf 9/17/2001 00:18'! whichSuperclassSatisfies: aBlock (aBlock value: self) ifTrue: [^self]. ^superclass isNil ifTrue: [nil] ifFalse: [superclass whichSuperclassSatisfies: aBlock]! ! !Behavior methodsFor: 'send caches'! clearSendCaches LocalSends current clearOut: self! ! !Behavior methodsFor: 'send caches'! hasRequiredSelectors ^ self requiredSelectors notEmpty! ! !Behavior methodsFor: 'send caches'! requirements ^ self requiredSelectorsCache ifNil: [#()] ifNotNilDo: [:rsc | rsc requirements]! ! !Behavior methodsFor: 'send caches'! sendCaches: aSendCaches ^ self explicitRequirement! ! !Behavior methodsFor: 'send caches'! setRequiredStatusOf: selector to: aBoolean aBoolean ifTrue: [self requiredSelectorsCache addRequirement: selector] ifFalse: [self requiredSelectorsCache removeRequirement: selector].! ! !Behavior methodsFor: 'send caches'! superRequirements ^ self requiredSelectorsCache superRequirements! ! !Behavior methodsFor: 'system startup' stamp: 'ar 11/16/1999 20:15'! shutDown "This message is sent on system shutdown to registered classes" ! ! !Behavior methodsFor: 'system startup' stamp: 'ar 11/16/1999 20:15'! shutDown: quitting "This message is sent on system shutdown to registered classes" ^self shutDown.! ! !Behavior methodsFor: 'system startup' stamp: 'ar 11/16/1999 20:15'! startUp "This message is sent to registered classes when the system is coming up." ! ! !Behavior methodsFor: 'system startup' stamp: 'ar 11/16/1999 20:15'! startUp: resuming "This message is sent to registered classes when the system is coming up." ^self startUp! ! !Behavior methodsFor: 'system startup' stamp: 'tk 10/26/2001 16:06'! startUpFrom: anImageSegment "Override this when a per-instance startUp message needs to be sent. For example, to correct the order of 16-bit non-pointer data when it came from a different endian machine." ^ nil! ! !Behavior methodsFor: 'testing'! canZapMethodDictionary "Return true if it is safe to zap the method dictionary on #obsolete" ^true! ! !Behavior methodsFor: 'testing'! instSize "Answer the number of named instance variables (as opposed to indexed variables) of the receiver." self flag: #instSizeChange. "Smalltalk browseAllCallsOn: #instSizeChange" " NOTE: This code supports the backward-compatible extension to 8 bits of instSize. When we revise the image format, it should become... ^ ((format bitShift: -1) bitAnd: 16rFF) - 1 Note also that every other method in this category will require 2 bits more of right shift after the change. " ^ ((format bitShift: -10) bitAnd: 16rC0) + ((format bitShift: -1) bitAnd: 16r3F) - 1! ! !Behavior methodsFor: 'testing'! instSpec ^ (format bitShift: -7) bitAnd: 16rF! ! !Behavior methodsFor: 'testing' stamp: 'ar 7/9/1999 18:18'! isBehavior "Return true if the receiver is a behavior" ^true! ! !Behavior methodsFor: 'testing'! isBits "Answer whether the receiver contains just bits (not pointers)." ^ self instSpec >= 6! ! !Behavior methodsFor: 'testing'! isBytes "Answer whether the receiver has 8-bit instance variables." ^ self instSpec >= 8! ! !Behavior methodsFor: 'testing'! isFixed "Answer whether the receiver does not have a variable (indexable) part." ^self isVariable not! ! !Behavior methodsFor: 'testing' stamp: 'dvf 9/27/2005 14:57'! isMeta ^ false! ! !Behavior methodsFor: 'testing' stamp: 'ar 7/14/1999 02:38'! isObsolete "Return true if the receiver is obsolete." ^self instanceCount = 0! ! !Behavior methodsFor: 'testing'! isPointers "Answer whether the receiver contains just pointers (not bits)." ^self isBits not! ! !Behavior methodsFor: 'testing'! isVariable "Answer whether the receiver has indexable variables." ^ self instSpec >= 2! ! !Behavior methodsFor: 'testing' stamp: 'ar 3/21/98 02:36'! isWeak "Answer whether the receiver has contains weak references." ^ self instSpec = 4! ! !Behavior methodsFor: 'testing'! isWords "Answer whether the receiver has 16-bit instance variables." ^self isBytes not! ! !Behavior methodsFor: 'testing' stamp: 'sd 3/28/2003 15:07'! shouldNotBeRedefined "Return true if the receiver should not be redefined. The assumption is that compact classes, classes in Smalltalk specialObjects and Behaviors should not be redefined" ^(self environment compactClassesArray includes: self) or:[(self environment specialObjectsArray includes: self) or:[self isKindOf: self]]! ! !Behavior methodsFor: 'testing class hierarchy' stamp: 'ar 3/12/98 12:36'! includesBehavior: aClass ^self == aClass or:[self inheritsFrom: aClass]! ! !Behavior methodsFor: 'testing class hierarchy'! inheritsFrom: aClass "Answer whether the argument, aClass, is on the receiver's superclass chain." | aSuperclass | aSuperclass := superclass. [aSuperclass == nil] whileFalse: [aSuperclass == aClass ifTrue: [^true]. aSuperclass := aSuperclass superclass]. ^false! ! !Behavior methodsFor: 'testing class hierarchy'! kindOfSubclass "Answer a String that is the keyword that describes the receiver's kind of subclass, either a regular subclass, a variableSubclass, a variableByteSubclass, a variableWordSubclass, or a weakSubclass." self isWeak ifTrue: [^ ' weakSubclass: ']. ^ self isVariable ifTrue: [self isBits ifTrue: [self isBytes ifTrue: [ ' variableByteSubclass: '] ifFalse: [ ' variableWordSubclass: ']] ifFalse: [ ' variableSubclass: ']] ifFalse: [ ' subclass: ']! ! !Behavior methodsFor: 'testing method dictionary' stamp: 'al 2/29/2004 14:18'! bindingOf: varName "Answer the binding of some variable resolved in the scope of the receiver" ^superclass bindingOf: varName! ! !Behavior methodsFor: 'testing method dictionary' stamp: 'sd 5/7/2006 09:58'! canPerform: selector "Answer whether the receiver can safely perform to the message whose selector is the argument: it is not an abstract or cancelled method" ^ self classAndMethodFor: selector do: [:c :m | m isProvided] ifAbsent: [false].! ! !Behavior methodsFor: 'testing method dictionary'! canUnderstand: selector "Answer whether the receiver can respond to the message whose selector is the argument. The selector can be in the method dictionary of the receiver's class or any of its superclasses." (self includesSelector: selector) ifTrue: [^true]. superclass == nil ifTrue: [^false]. ^superclass canUnderstand: selector! ! !Behavior methodsFor: 'testing method dictionary' stamp: 'ar 5/18/2003 18:13'! classBindingOf: varName "Answer the binding of some variable resolved in the scope of the receiver's class" ^self bindingOf: varName! ! !Behavior methodsFor: 'testing method dictionary'! hasMethods "Answer whether the receiver has any methods in its method dictionary." ^ self methodDict notEmpty! ! !Behavior methodsFor: 'testing method dictionary'! includesLocalSelector: aSymbol ^self basicLocalSelectors isNil ifTrue: [self includesSelector: aSymbol] ifFalse: [self localSelectors includes: aSymbol]! ! !Behavior methodsFor: 'testing method dictionary'! includesSelector: aSymbol "Answer whether the message whose selector is the argument is in the method dictionary of the receiver's class." ^ self methodDict includesKey: aSymbol! ! !Behavior methodsFor: 'testing method dictionary'! isAliasSelector: aSymbol "Return true if the selector aSymbol is an alias defined in my or in another composition somewhere deeper in the tree of traits compositions." ^(self includesLocalSelector: aSymbol) not and: [self hasTraitComposition] and: [self traitComposition isAliasSelector: aSymbol]! ! !Behavior methodsFor: 'testing method dictionary'! isDisabledSelector: selector ^ self classAndMethodFor: selector do: [:c :m | m isDisabled] ifAbsent: [false]! ! !Behavior methodsFor: 'testing method dictionary'! isLocalAliasSelector: aSymbol "Return true if the selector aSymbol is an alias defined in my trait composition." ^(self includesLocalSelector: aSymbol) not and: [self hasTraitComposition] and: [self traitComposition isLocalAliasSelector: aSymbol]! ! !Behavior methodsFor: 'testing method dictionary'! isProvidedSelector: selector ^ ProvidedSelectors current isSelector: selector providedIn: self ! ! !Behavior methodsFor: 'testing method dictionary' stamp: 'G.C 10/22/2008 09:59'! thoroughWhichSelectorsReferTo: literal special: specialFlag byte: specialByte "Answer a set of selectors whose methods access the argument as a literal. Dives into the compact literal notation, making it slow but thorough " | selectors | selectors := IdentitySet new. self selectorsAndMethodsDo: [ :sel :method | ((method refersToLiteral: literal) or: [ specialFlag and: [ method scanFor: specialByte ] ]) ifTrue: [ selectors add: sel ] ]. ^ selectors! ! !Behavior methodsFor: 'testing method dictionary'! whichClassIncludesSelector: aSymbol "Answer the class on the receiver's superclass chain where the argument, aSymbol (a message selector), will be found. Answer nil if none found." "Rectangle whichClassIncludesSelector: #inspect." (self includesSelector: aSymbol) ifTrue: [^ self]. superclass == nil ifTrue: [^ nil]. ^ superclass whichClassIncludesSelector: aSymbol! ! !Behavior methodsFor: 'testing method dictionary' stamp: 'eem 2/1/2007 14:14'! whichSelectorsAccess: instVarName "Answer a set of selectors whose methods access the argument, instVarName, as a named instance variable." | instVarIndex | instVarIndex := self instVarIndexFor: instVarName ifAbsent: [^IdentitySet new]. ^ self methodDict keys select: [:sel | ((self methodDict at: sel) readsField: instVarIndex) or: [(self methodDict at: sel) writesField: instVarIndex]] "Point whichSelectorsAccess: 'x'."! ! !Behavior methodsFor: 'testing method dictionary'! whichSelectorsReferTo: literal "Answer a Set of selectors whose methods access the argument as a literal." | special byte | special := self environment hasSpecialSelector: literal ifTrueSetByte: [:b | byte := b]. ^self whichSelectorsReferTo: literal special: special byte: byte "Rectangle whichSelectorsReferTo: #+."! ! !Behavior methodsFor: 'testing method dictionary'! whichSelectorsReferTo: literal special: specialFlag byte: specialByte "Answer a set of selectors whose methods access the argument as a literal." | who | who := IdentitySet new. self selectorsAndMethodsDo: [:sel :method | ((method hasLiteral: literal) or: [specialFlag and: [method scanFor: specialByte]]) ifTrue: [((literal isVariableBinding) not or: [method literals allButLast includes: literal]) ifTrue: [who add: sel]]]. ^ who! ! !Behavior methodsFor: 'testing method dictionary' stamp: 'eem 2/1/2007 14:15'! whichSelectorsStoreInto: instVarName "Answer a Set of selectors whose methods access the argument, instVarName, as a named instance variable." | instVarIndex | instVarIndex := self instVarIndexFor: instVarName ifAbsent: [^IdentitySet new]. ^ self methodDict keys select: [:sel | (self methodDict at: sel) writesField: instVarIndex] "Point whichSelectorsStoreInto: 'x'."! ! !Behavior methodsFor: 'traits'! addExclusionOf: aSymbol to: aTrait self setTraitComposition: ( self traitComposition copyWithExclusionOf: aSymbol to: aTrait)! ! !Behavior methodsFor: 'traits'! addToComposition: aTrait self setTraitComposition: (self traitComposition copyTraitExpression add: aTrait; yourself)! ! !Behavior methodsFor: 'traits'! addTraitSelector: aSymbol withMethod: aCompiledMethod "Add aMethod with selector aSymbol to my methodDict. aMethod must not be defined locally." | source methodAndNode | self assert: [(self includesLocalSelector: aSymbol) not]. self ensureLocalSelectors. source := aCompiledMethod getSourceReplacingSelectorWith: aSymbol. methodAndNode := self compile: source classified: nil notifying: nil trailer: #(0 0 0 0) ifFail: [^nil]. methodAndNode method putSource: source fromParseNode: methodAndNode node inFile: 2 withPreamble: [:f | f cr; nextPut: $!!; nextChunkPut: 'Trait method'; cr]. self basicAddSelector: aSymbol withMethod: methodAndNode method! ! !Behavior methodsFor: 'traits'! applyChangesOfNewTraitCompositionReplacing: oldComposition | changedSelectors | changedSelectors := self traitComposition changedSelectorsComparedTo: oldComposition. changedSelectors isEmpty ifFalse: [ self noteChangedSelectors: changedSelectors]. self traitComposition isEmpty ifTrue: [ self purgeLocalSelectors]. ^changedSelectors! ! !Behavior methodsFor: 'traits'! ensureLocalSelectors "Ensures that the instance variable localSelectors is effectively used to maintain the set of local selectors. This method must be called before any non-local selectors are added to the method dictionary!!" self basicLocalSelectors isNil ifTrue: [self basicLocalSelectors: self selectors]! ! !Behavior methodsFor: 'traits'! flattenDown: aTrait | selectors | self assert: [self hasTraitComposition and: [self traitComposition allTraits includes: aTrait]]. selectors := (self traitComposition transformationOfTrait: aTrait) selectors. self basicLocalSelectors: self basicLocalSelectors , selectors. self removeFromComposition: aTrait.! ! !Behavior methodsFor: 'traits'! flattenDownAllTraits self traitComposition allTraits do: [:each | self flattenDown: each]. self assert: [ self traitComposition isEmpty ]. self traitComposition: nil.! ! !Behavior methodsFor: 'traits' stamp: 'al 3/25/2006 12:39'! hasTraitComposition self subclassResponsibility ! ! !Behavior methodsFor: 'traits'! noteChangedSelectors: aCollection "Start update of my methodDict (after changes to traits in traitComposition or after a local method was removed from my methodDict). The argument is a collection of method selectors that may have been changed. Most of the time aCollection only holds one selector. But when there are aliases involved there may be several method changes that have to be propagated to users." | affectedSelectors | affectedSelectors := IdentitySet new. aCollection do: [:selector | affectedSelectors addAll: (self updateMethodDictionarySelector: selector)]. self notifyUsersOfChangedSelectors: affectedSelectors. ^ affectedSelectors! ! !Behavior methodsFor: 'traits'! notifyUsersOfChangedSelector: aSelector self notifyUsersOfChangedSelectors: (Array with: aSelector)! ! !Behavior methodsFor: 'traits'! notifyUsersOfChangedSelectors: aCollection! ! !Behavior methodsFor: 'traits'! purgeLocalSelectors self basicLocalSelectors: nil! ! !Behavior methodsFor: 'traits'! removeAlias: aSymbol of: aTrait self setTraitComposition: ( self traitComposition copyWithoutAlias: aSymbol of: aTrait)! ! !Behavior methodsFor: 'traits'! removeFromComposition: aTrait self setTraitComposition: (self traitComposition copyTraitExpression removeFromComposition: aTrait)! ! !Behavior methodsFor: 'traits'! removeTraitSelector: aSymbol self assert: [(self includesLocalSelector: aSymbol) not]. self basicRemoveSelector: aSymbol! ! !Behavior methodsFor: 'traits'! selfSentSelectorsFromSelectors: interestingSelectors | m result info | result := IdentitySet new. interestingSelectors collect: [:sel | m := self compiledMethodAt: sel ifAbsent: []. m ifNotNil: [info := (SendInfo on: m) collectSends. info selfSentSelectors do: [:sentSelector | result add: sentSelector]]]. ^result! ! !Behavior methodsFor: 'traits'! setTraitComposition: aTraitComposition | oldComposition | (self hasTraitComposition not and: [aTraitComposition isEmpty]) ifTrue: [^self]. aTraitComposition assertValidUser: self. oldComposition := self traitComposition. self traitComposition: aTraitComposition. self applyChangesOfNewTraitCompositionReplacing: oldComposition. oldComposition traits do: [:each | each removeUser: self]. aTraitComposition traits do: [:each | each addUser: self]! ! !Behavior methodsFor: 'traits'! setTraitCompositionFrom: aTraitExpression ^ self setTraitComposition: aTraitExpression asTraitComposition! ! !Behavior methodsFor: 'traits' stamp: 'al 3/25/2006 12:36'! traitComposition self subclassResponsibility! ! !Behavior methodsFor: 'traits' stamp: 'al 3/25/2006 12:39'! traitComposition: aTraitComposition self subclassResponsibility ! ! !Behavior methodsFor: 'traits'! traitCompositionIncludes: aTrait ^self == aTrait or: [self hasTraitComposition and: [self traitComposition allTraits includes: aTrait]]! ! !Behavior methodsFor: 'traits'! traitCompositionString ^self hasTraitComposition ifTrue: [self traitComposition asString] ifFalse: ['{}']! ! !Behavior methodsFor: 'traits'! traitOrClassOfSelector: aSymbol "Return the trait or the class which originally defines the method aSymbol or return self if locally defined or if it is a conflict marker method. This is primarly used by Debugger to determin the behavior in which a recompiled method should be put. If a conflict method is recompiled it should be put into the class, thus return self. Also see TraitComposition>>traitProvidingSelector:" ((self includesLocalSelector: aSymbol) or: [ self hasTraitComposition not]) ifTrue: [^self]. ^(self traitComposition traitProvidingSelector: aSymbol) ifNil: [self]! ! !Behavior methodsFor: 'traits'! traitTransformations ^ self traitComposition transformations ! ! !Behavior methodsFor: 'traits'! traits "Returns a collection of all traits used by the receiver" ^ self traitComposition traits! ! !Behavior methodsFor: 'traits'! traitsProvidingSelector: aSymbol | result | result := OrderedCollection new. self hasTraitComposition ifFalse: [^result]. (self traitComposition methodDescriptionsForSelector: aSymbol) do: [:methodDescription | methodDescription selector = aSymbol ifTrue: [ result addAll: (methodDescription locatedMethods collect: [:each | each location])]]. ^result! ! !Behavior methodsFor: 'traits'! updateMethodDictionarySelector: aSymbol "A method with selector aSymbol in myself or my traitComposition has been changed. Do the appropriate update to my methodDict (remove or update method) and return all affected selectors of me so that my useres get notified." | effectiveMethod modifiedSelectors descriptions selector | modifiedSelectors := IdentitySet new. descriptions := self hasTraitComposition ifTrue: [ self traitComposition methodDescriptionsForSelector: aSymbol ] ifFalse: [ #() ]. descriptions do: [:methodDescription | selector := methodDescription selector. (self includesLocalSelector: selector) ifFalse: [ methodDescription isEmpty ifTrue: [ self removeTraitSelector: selector. modifiedSelectors add: selector] ifFalse: [ effectiveMethod := methodDescription effectiveMethod. self addTraitSelector: selector withMethod: effectiveMethod. modifiedSelectors add: selector]]]. ^modifiedSelectors! ! !Behavior methodsFor: 'user interface' stamp: 'md 8/27/2005 17:18'! allLocalCallsOn: aSymbol "Answer a SortedCollection of all the methods that call on aSymbol, anywhere in my class hierarchy." | aSet special byte cls | aSet := Set new. cls := self theNonMetaClass. special := self environment hasSpecialSelector: aSymbol ifTrueSetByte: [:b | byte := b ]. cls withAllSuperAndSubclassesDoGently: [ :class | (class whichSelectorsReferTo: aSymbol special: special byte: byte) do: [:sel | sel isDoIt ifFalse: [aSet add: class name , ' ', sel]]]. cls class withAllSuperAndSubclassesDoGently: [ :class | (class whichSelectorsReferTo: aSymbol special: special byte: byte) do: [:sel | sel isDoIt ifFalse: [aSet add: class name , ' ', sel]]]. ^aSet! ! !Behavior methodsFor: 'user interface' stamp: 'marcus.denker 9/29/2008 15:17'! allUnreferencedInstanceVariables "Return a list of the instance variables known to the receiver which are not referenced in the receiver or any of its subclasses OR superclasses" ^ self allInstVarNames reject: [:ivn | | definingClass | definingClass := self classThatDefinesInstanceVariable: ivn. definingClass withAllSubclasses anySatisfy: [:class | (class whichSelectorsAccess: ivn asSymbol) notEmpty]]! ! !Behavior methodsFor: 'user interface'! crossReference "Answer an Array of arrays of size 2 whose first element is a message selector in the receiver's method dictionary and whose second element is a set of all message selectors in the method dictionary whose methods send a message with that selector. Subclasses are not included." ^self selectors asSortedCollection asArray collect: [:x | Array with: (String with: Character cr), x with: (self whichSelectorsReferTo: x)] "Point crossReference."! ! !Behavior methodsFor: 'user interface' stamp: 'marcus.denker 9/29/2008 13:01'! unreferencedInstanceVariables "Return a list of the instance variables defined in the receiver which are not referenced in the receiver or any of its subclasses." ^ self instVarNames reject: [:ivn | self withAllSubclasses anySatisfy: [:class | (class whichSelectorsAccess: ivn) notEmpty]]! ! !Behavior methodsFor: 'user interface' stamp: 'RAA 5/28/2001 12:00'! withAllSubAndSuperclassesDo: aBlock self withAllSubclassesDo: aBlock. self allSuperclassesDo: aBlock. ! ! !Behavior methodsFor: 'private'! basicRemoveSelector: selector "Assuming that the argument, selector (a Symbol), is a message selector in my method dictionary, remove it and its method." | oldMethod | oldMethod := self methodDict at: selector ifAbsent: [^ self]. self methodDict removeKey: selector. "Now flush Squeak's method cache, either by selector or by method" oldMethod flushCache. selector flushCache! ! !Behavior methodsFor: 'private' stamp: 'sd 3/28/2003 15:06'! becomeCompact "Here are the restrictions on compact classes in order for export segments to work: A compact class index may not be reused. If a class was compact in a release of Squeak, no other class may use that index. The class might not be compact later, and there should be nil in its place in the array." | cct index | self isWeak ifTrue:[^ self halt: 'You must not make a weak class compact']. cct := self environment compactClassesArray. (self indexIfCompact > 0 or: [cct includes: self]) ifTrue: [^ self halt: self name , 'is already compact']. index := cct indexOf: nil ifAbsent: [^ self halt: 'compact class table is full']. "Install this class in the compact class table" cct at: index put: self. "Update instspec so future instances will be compact" format := format + (index bitShift: 11). "Make up new instances and become old ones into them" self updateInstancesFrom: self. "Purge any old instances" Smalltalk garbageCollect.! ! !Behavior methodsFor: 'private' stamp: 'sd 3/28/2003 15:06'! becomeCompactSimplyAt: index "Make me compact, but don't update the instances. For importing segments." "Here are the restrictions on compact classes in order for export segments to work: A compact class index may not be reused. If a class was compact in a release of Squeak, no other class may use that index. The class might not be compact later, and there should be nil in its place in the array." | cct | self isWeak ifTrue:[^ self halt: 'You must not make a weak class compact']. cct := self environment compactClassesArray. (self indexIfCompact > 0 or: [cct includes: self]) ifTrue: [^ self halt: self name , 'is already compact']. (cct at: index) ifNotNil: [^ self halt: 'compact table slot already in use']. "Install this class in the compact class table" cct at: index put: self. "Update instspec so future instances will be compact" format := format + (index bitShift: 11). "Caller must convert the instances" ! ! !Behavior methodsFor: 'private' stamp: 'sd 3/28/2003 15:06'! becomeUncompact | cct index | cct := self environment compactClassesArray. (index := self indexIfCompact) = 0 ifTrue: [^ self]. (cct includes: self) ifFalse: [^ self halt "inconsistent state"]. "Update instspec so future instances will not be compact" format := format - (index bitShift: 11). "Make up new instances and become old ones into them" self updateInstancesFrom: self. "Make sure there are no compact ones left around" Smalltalk garbageCollect. "Remove this class from the compact class table" cct at: index put: nil. ! ! !Behavior methodsFor: 'private'! flushCache "Tell the interpreter to remove the contents of its method lookup cache, if it has one. Essential. See Object documentation whatIsAPrimitive." self primitiveFailed! ! !Behavior methodsFor: 'private'! indexIfCompact "If these 5 bits are non-zero, then instances of this class will be compact. It is crucial that there be an entry in Smalltalk compactClassesArray for any class so optimized. See the msgs becomeCompact and becomeUncompact." ^ (format bitShift: -11) bitAnd: 16r1F " Smalltalk compactClassesArray doWithIndex: [:c :i | c == nil ifFalse: [c indexIfCompact = i ifFalse: [self halt]]] "! ! !Behavior methodsFor: 'private' stamp: 'sd 11/19/2004 15:13'! setFormat: aFormatInstanceDescription "only use this method with extreme care since it modifies the format of the class ie a description of the number of instance variables and whether the class is compact, variable sized" format := aFormatInstanceDescription ! ! !Behavior methodsFor: 'private'! spaceUsed "Answer a rough estimate of number of bytes used by this class and its metaclass. Does not include space used by class variables." | space | space := 0. self selectorsDo: [:sel | | method | space := space + 16. "dict and org'n space" method := self compiledMethodAt: sel. space := space + (method size + 6 "hdr + avg pad"). method literalsDo: [:lit | (lit isMemberOf: Array) ifTrue: [space := space + ((lit size + 1) * 4)]. (lit isMemberOf: Float) ifTrue: [space := space + 12]. (lit isMemberOf: ByteString) ifTrue: [space := space + (lit size + 6)]. (lit isMemberOf: LargeNegativeInteger) ifTrue: [space := space + ((lit size + 1) * 4)]. (lit isMemberOf: LargePositiveInteger) ifTrue: [space := space + ((lit size + 1) * 4)]]]. ^ space! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Behavior class uses: TPureBehavior classTrait instanceVariableNames: ''! !Behavior class methodsFor: 'class initialization' stamp: 'apb 7/12/2004 23:23'! flushObsoleteSubclasses "Behavior flushObsoleteSubclasses" ObsoleteSubclasses finalizeValues.! ! !Behavior class methodsFor: 'class initialization' stamp: 'apb 7/12/2004 23:51'! initialize "Behavior initialize" "Never called for real" ObsoleteSubclasses ifNil: [self initializeObsoleteSubclasses] ifNotNil: [| newDict | newDict := WeakKeyToCollectionDictionary newFrom: ObsoleteSubclasses. newDict rehash. ObsoleteSubclasses := newDict]! ! !Behavior class methodsFor: 'class initialization' stamp: 'apb 7/12/2004 23:46'! initializeObsoleteSubclasses ObsoleteSubclasses := WeakKeyToCollectionDictionary new.! ! !Behavior class methodsFor: 'testing' stamp: 'dvf 9/27/2005 16:12'! canZapMethodDictionary "Return false since zapping the method dictionary of Behavior class or its subclasses will cause the system to fail." ^false! ! TestCase subclass: #BehaviorTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'KernelTests-Classes'! !BehaviorTest methodsFor: 'tests' stamp: 'dc 9/28/2008 16:46'! testAllSelectors self assert: ProtoObject allSelectors = ProtoObject selectors. self assert: Object allSelectors = (Object selectors union: ProtoObject selectors). self assert: (Object allSelectorsBelow: ProtoObject) = (Object selectors).! ! !BehaviorTest methodsFor: 'tests' stamp: 'sd 1/28/2009 14:32'! testAllSelectorsAbove "self debug: #testAllSelectorsAbove" |sels | sels := Morph allSelectorsAbove. self deny: (sels includes: #submorphs). self deny: (sels includes: #submorphs). self assert: (sels includes: #clearHaltOnce). self assert: (sels includes: #cannotInterpret: ) ! ! !BehaviorTest methodsFor: 'tests' stamp: 'sd 1/28/2009 14:31'! testAllSelectorsAboveUntil "self debug: #testAllSelectorsAboveUntil" |sels | sels := Morph allSelectorsAboveUntil: Object.. self deny: (sels includes: #submorphs). self deny: (sels includes: #submorphs). self assert: (sels includes: #clearHaltOnce). self deny: (sels includes: #cannotInterpret: ) ! ! !BehaviorTest methodsFor: 'tests' stamp: 'sd 3/14/2004 18:11'! testBehaviorSubclasses "self run: #testBehaviorSubclasses" | b b2 | b := Behavior new. b superclass: OrderedCollection. b methodDictionary: MethodDictionary new. self shouldnt: [b subclasses ] raise: Error. self shouldnt: [b withAllSubclasses] raise: Error. self shouldnt: [b allSubclasses] raise: Error. b2 := Behavior new. b2 superclass: b. b2 methodDictionary: MethodDictionary new. self assert: (b subclasses includes: b2). self assert: (b withAllSubclasses includes: b).! ! !BehaviorTest methodsFor: 'tests' stamp: 'sd 11/19/2004 15:38'! testBehaviornewnewShouldNotCrash Behavior new new. "still not working correctly but at least does not crash the image" ! ! !BehaviorTest methodsFor: 'tests' stamp: 'marcus.denker 9/14/2008 21:14'! testBinding self assert: Object binding value = Object. self assert: Object binding key = #Object. self assert: Object class binding value = Object class. "returns nil for Metaclasses... like Encoder>>#associationFor:" self assert: Object class binding key isNil.! ! !BehaviorTest methodsFor: 'tests' stamp: 'ar 9/27/2005 21:43'! testChange "self debug: #testChange" | behavior model | behavior := Behavior new. behavior superclass: Model. behavior setFormat: Model format. model := Model new. model primitiveChangeClassTo: behavior new. behavior compile: 'thisIsATest ^ 2'. self assert: model thisIsATest = 2. self should: [Model new thisIsATest] raise: MessageNotUnderstood. ! ! !BehaviorTest methodsFor: 'tests' stamp: 'sd 1/28/2009 14:25'! testallSuperclassesIncluding "self debug: #testallSuperclassesIncluding" |cls | cls := ArrayedCollection allSuperclassesIncluding: Collection. self deny: (cls includes: ArrayedCollection). self deny: (cls includes: Object). self assert: (cls includes: Collection). self assert: (cls includes: SequenceableCollection). ! ! !BehaviorTest methodsFor: 'tests - testing method dictionary' stamp: 'marcus.denker 9/29/2008 15:11'! testWhichSelectorsAccess self assert: ((Point whichSelectorsAccess: 'x') includes: #x). self deny: ((Point whichSelectorsAccess: 'y') includes: #x).! ! LineSegment subclass: #Bezier2Segment instanceVariableNames: 'via' classVariableNames: '' poolDictionaries: '' category: 'Balloon-Geometry'! !Bezier2Segment commentStamp: '' prior: 0! This class represents a quadratic bezier segment between two points Instance variables: via The additional control point (OFF the curve)! !Bezier2Segment methodsFor: 'accessing' stamp: 'ar 11/2/1998 12:14'! bounds "Return the bounds containing the receiver" ^super bounds encompass: via! ! !Bezier2Segment methodsFor: 'accessing' stamp: 'ar 6/8/2003 00:07'! degree ^2! ! !Bezier2Segment methodsFor: 'accessing' stamp: 'ar 11/2/1998 12:14'! via "Return the control point" ^via! ! !Bezier2Segment methodsFor: 'bezier clipping' stamp: 'ar 6/7/2003 23:45'! bezierClipHeight: dir | dirX dirY uMin uMax dx dy u | dirX := dir x. dirY := dir y. uMin := 0.0. uMax := (dirX * dirX) + (dirY * dirY). dx := via x - start x. dy := via y - start y. u := (dirX * dx) + (dirY * dy). u < uMin ifTrue:[uMin := u]. u > uMax ifTrue:[uMax := u]. ^uMin@uMax! ! !Bezier2Segment methodsFor: 'converting' stamp: 'ar 6/8/2003 04:19'! asBezier2Points: error ^Array with: start with: via with: end! ! !Bezier2Segment methodsFor: 'converting' stamp: 'ar 11/2/1998 12:17'! asBezier2Segment "Represent the receiver as quadratic bezier segment" ^self! ! !Bezier2Segment methodsFor: 'converting' stamp: 'ar 6/7/2003 21:05'! asBezier3Segment "Represent the receiver as cubic bezier segment" ^Bezier3Segment from: start via: 2*via+start / 3.0 and: 2*via+end / 3.0 to: end! ! !Bezier2Segment methodsFor: 'converting' stamp: 'ar 11/2/1998 12:18'! asIntegerSegment "Convert the receiver into integer representation" ^self species from: start asIntegerPoint to: end asIntegerPoint via: via asIntegerPoint! ! !Bezier2Segment methodsFor: 'converting' stamp: 'ar 6/7/2003 20:58'! asTangentSegment ^LineSegment from: via-start to: end-via! ! !Bezier2Segment methodsFor: 'initialize' stamp: 'ar 11/2/1998 12:13'! from: startPoint to: endPoint "Initialize the receiver as straight line" start := startPoint. end := endPoint. via := (start + end) // 2.! ! !Bezier2Segment methodsFor: 'initialize' stamp: 'ar 11/2/1998 12:13'! from: startPoint to: endPoint via: viaPoint "Initialize the receiver" start := startPoint. end := endPoint. via := viaPoint.! ! !Bezier2Segment methodsFor: 'initialize' stamp: 'ar 6/7/2003 22:37'! from: startPoint to: endPoint withMidPoint: pointOnCurve "Initialize the receiver with the pointOnCurve assumed at the parametric value 0.5" start := startPoint. end := endPoint. "Compute via" via := (pointOnCurve * 2) - (start + end * 0.5).! ! !Bezier2Segment methodsFor: 'initialize' stamp: 'ar 6/6/2003 03:03'! from: startPoint to: endPoint withMidPoint: pointOnCurve at: parameter "Initialize the receiver with the pointOnCurve at the given parametric value" | t1 t2 t3 | start := startPoint. end := endPoint. "Compute via" t1 := (1.0 - parameter) squared. t2 := 1.0 / (2 * parameter * (1.0 - parameter)). t3 := parameter squared. via := (pointOnCurve - (start * t1) - (end * t3)) * t2! ! !Bezier2Segment methodsFor: 'initialize' stamp: 'ar 6/7/2003 00:09'! initializeFrom: controlPoints controlPoints size = 3 ifFalse:[self error:'Wrong number of control points']. start := controlPoints at: 1. via := controlPoints at: 2. end := controlPoints at: 3.! ! !Bezier2Segment methodsFor: 'printing' stamp: 'ar 11/2/1998 12:18'! printOn: aStream "Print the receiver on aStream" aStream nextPutAll: self class name; nextPutAll:' from: '; print: start; nextPutAll: ' via: '; print: via; nextPutAll: ' to: '; print: end; space.! ! !Bezier2Segment methodsFor: 'printing' stamp: 'MPW 1/1/1901 21:59'! printOnStream: aStream aStream print: self class name; print:'from: '; write: start; print:'via: '; write: via; print:'to: '; write: end; print:' '.! ! !Bezier2Segment methodsFor: 'testing' stamp: 'ar 11/2/1998 12:15'! hasZeroLength "Return true if the receiver has zero length" ^start = end and:[start = via]! ! !Bezier2Segment methodsFor: 'testing' stamp: 'ar 11/2/1998 12:15'! isBezier2Segment "Return true if the receiver is a quadratic bezier segment" ^true! ! !Bezier2Segment methodsFor: 'testing' stamp: 'ar 11/2/1998 12:15'! isStraight "Return true if the receiver represents a straight line" ^(self tangentAtStart crossProduct: self tangentAtEnd) = 0! ! !Bezier2Segment methodsFor: 'vector functions' stamp: 'ar 6/7/2003 00:08'! controlPoints ^{start. via. end}! ! !Bezier2Segment methodsFor: 'vector functions' stamp: 'ar 6/7/2003 23:39'! controlPointsDo: aBlock aBlock value: start; value: via; value: end! ! !Bezier2Segment methodsFor: 'vector functions' stamp: 'ar 6/8/2003 00:08'! curveFrom: param1 to: param2 "Return a new curve from param1 to param2" | newStart newEnd newVia tan1 tan2 d1 d2 | tan1 := via - start. tan2 := end - via. param1 <= 0.0 ifTrue:[ newStart := start. ] ifFalse:[ d1 := tan1 * param1 + start. d2 := tan2 * param1 + via. newStart := (d2 - d1) * param1 + d1 ]. param2 >= 1.0 ifTrue:[ newEnd := end. ] ifFalse:[ d1 := tan1 * param2 + start. d2 := tan2 * param2 + via. newEnd := (d2 - d1) * param2 + d1. ]. tan2 := (tan2 - tan1 * param1 + tan1) * (param2 - param1). newVia := newStart + tan2. ^self clone from: newStart to: newEnd via: newVia.! ! !Bezier2Segment methodsFor: 'vector functions' stamp: 'ar 11/2/1998 12:15'! length "Return the length of the receiver" "Note: Overestimates the length" ^(start dist: via) + (via dist: end)! ! !Bezier2Segment methodsFor: 'vector functions' stamp: 'ar 11/6/1998 23:39'! lineSegmentsDo: aBlock "Evaluate aBlock with the receiver's line segments" "Note: We could use forward differencing here." | steps last deltaStep t next | steps := 1 max: (self length // 10). "Assume 10 pixels per step" last := start. deltaStep := 1.0 / steps asFloat. t := deltaStep. 1 to: steps do:[:i| next := self valueAt: t. aBlock value: last value: next. last := next. t := t + deltaStep].! ! !Bezier2Segment methodsFor: 'vector functions' stamp: 'ar 6/7/2003 17:21'! lineSegments: steps do: aBlock "Evaluate aBlock with the receiver's line segments" "Note: We could use forward differencing here." | last deltaStep t next | last := start. deltaStep := 1.0 / steps asFloat. t := deltaStep. 1 to: steps do:[:i| next := self valueAt: t. aBlock value: last value: next. last := next. t := t + deltaStep].! ! !Bezier2Segment methodsFor: 'vector functions' stamp: 'ar 6/7/2003 00:04'! outlineSegment: width | delta newStart newEnd param newMid | delta := self tangentAtStart normalized * width. delta := delta y @ delta x negated. newStart := start + delta. delta := self tangentAtEnd normalized * width. delta := delta y @ delta x negated. newEnd := end + delta. param := 0.5. "self tangentAtStart r / (self tangentAtStart r + self tangentAtEnd r)." delta := (self tangentAt: param) normalized * width. delta := delta y @ delta x negated. newMid := (self valueAt: param) + delta. ^self class from: newStart to: newEnd withMidPoint: newMid at: param! ! !Bezier2Segment methodsFor: 'vector functions' stamp: 'ar 6/9/2003 03:43'! parameterAtExtremeX "Note: Only valid for non-monoton receivers" ^self parameterAtExtreme: 0.0@1.0. ! ! !Bezier2Segment methodsFor: 'vector functions' stamp: 'ar 6/9/2003 03:43'! parameterAtExtremeY "Note: Only valid for non-monoton receivers" ^self parameterAtExtreme: 1.0@0.0. ! ! !Bezier2Segment methodsFor: 'vector functions' stamp: 'ar 6/9/2003 03:43'! parameterAtExtreme: tangentDirection "Compute the parameter value at which the tangent reaches tangentDirection. We need to find the parameter value t at which the following holds ((t * dir + in) crossProduct: tangentDirection) = 0. Since this is pretty ugly we use the normal direction rather than the tangent and compute the equivalent relation using the dot product as ((t * dir + in) dotProduct: nrm) = 0. Reformulation yields ((t * dir x + in x) * nrm x) + ((t * dir y + in y) * nrm y) = 0. (t * dir x * nrm x) + (in x * nrm x) + (t * dir y * nrm y) + (in y * nrm y) = 0. (t * dir x * nrm x) + (t * dir y * nrm y) = 0 - ((in x * nrm x) + (in y * nrm y)). (in x * nrm x) + (in y * nrm y) t = 0 - --------------------------------------- (dir x * nrm x) + (dir y * nrm y) And that's that. Note that we can get rid of the negation by computing 'dir' the other way around (e.g., in the above it would read '-dir') which is trivial to do. Note also that the above does not generalize easily beyond 2D since its not clear how to express the 'normal direction' of a tangent plane. " | inX inY dirX dirY nrmX nrmY | "Compute in" inX := via x - start x. inY := via y - start y. "Compute -dir" dirX := inX - (end x - via x). dirY := inY - (end y - via y). "Compute nrm" nrmX := tangentDirection y. nrmY := 0 - tangentDirection x. "Compute result" ^((inX * nrmX) + (inY * nrmY)) / ((dirX * nrmX) + (dirY * nrmY))! ! !Bezier2Segment methodsFor: 'vector functions' stamp: 'nk 12/27/2003 13:00'! roundTo: quantum super roundTo: quantum. via := via roundTo: quantum. ! ! !Bezier2Segment methodsFor: 'vector functions' stamp: 'ar 6/8/2003 00:54'! tangentAtMid "Return the tangent at the given parametric value along the receiver" | in out | in := self tangentAtStart. out := self tangentAtEnd. ^in + out * 0.5! ! !Bezier2Segment methodsFor: 'vector functions' stamp: 'ar 11/2/1998 12:16'! tangentAt: parameter "Return the tangent at the given parametric value along the receiver" | in out | in := self tangentAtStart. out := self tangentAtEnd. ^in + (out - in * parameter)! ! !Bezier2Segment methodsFor: 'vector functions' stamp: 'ar 11/2/1998 12:16'! tangentAtEnd "Return the tangent for the last point" ^end - via! ! !Bezier2Segment methodsFor: 'vector functions' stamp: 'ar 11/2/1998 12:16'! tangentAtStart "Return the tangent for the first point" ^via - start! ! !Bezier2Segment methodsFor: 'vector functions' stamp: 'ar 11/2/1998 12:17'! valueAt: parameter "Evaluate the receiver at the given parametric value" "Return the point at the parametric value t: p(t) = (1-t)^2 * p1 + 2*t*(1-t) * p2 + t^2 * p3. " | t1 t2 t3 | t1 := (1.0 - parameter) squared. t2 := 2 * parameter * (1.0 - parameter). t3 := parameter squared. ^(start * t1) + (via * t2) + (end * t3)! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Bezier2Segment class instanceVariableNames: ''! !Bezier2Segment class methodsFor: 'instance creation' stamp: 'ar 11/1/1998 21:14'! from: startPoint to: endPoint via: viaPoint ^self new from: startPoint to: endPoint via: viaPoint! ! !Bezier2Segment class methodsFor: 'instance creation' stamp: 'ar 11/1/1998 21:30'! from: startPoint to: endPoint withMidPoint: pointOnCurve ^self new from: startPoint to: endPoint withMidPoint: pointOnCurve! ! !Bezier2Segment class methodsFor: 'instance creation' stamp: 'ar 11/1/1998 21:32'! from: startPoint to: endPoint withMidPoint: pointOnCurve at: parameter ^self new from: startPoint to: endPoint withMidPoint: pointOnCurve at: parameter! ! !Bezier2Segment class methodsFor: 'instance creation' stamp: 'ar 11/1/1998 21:30'! from: startPoint via: viaPoint to: endPoint ^self new from: startPoint to: endPoint via: viaPoint! ! !Bezier2Segment class methodsFor: 'instance creation' stamp: 'ar 11/1/1998 21:32'! from: startPoint withMidPoint: pointOnCurve at: parameter to: endPoint ^self new from: startPoint to: endPoint withMidPoint: pointOnCurve at: parameter! ! !Bezier2Segment class methodsFor: 'instance creation' stamp: 'ar 11/1/1998 21:30'! from: startPoint withMidPoint: pointOnCurve to: endPoint ^self new from: startPoint to: endPoint withMidPoint: pointOnCurve! ! !Bezier2Segment class methodsFor: 'utilities' stamp: 'ar 6/7/2003 18:33'! makeEllipseSegments: aRectangle "Answer a set of bezier segments approximating an ellipsoid fitting the given rectangle. This method creates eight bezier segments (two for each quadrant) approximating the oval." "EXAMPLE: This example draws an oval with a red border and overlays the approximating bezier segments on top of the oval (drawn in black), thus giving an impression of how closely the bezier resembles the oval. Change the rectangle to see how accurate the approximation is for various radii of the oval. | rect | rect := 100@100 extent: 1200@500. Display getCanvas fillOval: rect color: Color yellow borderWidth: 1 borderColor: Color red. (Bezier2Segment makeEllipseSegments: rect) do:[:seg| seg lineSegmentsDo:[:last :next| Display getCanvas line: last to: next width: 1 color: Color black]]. " "EXAMPLE: | minRadius maxRadius | maxRadius := 300. minRadius := 20. maxRadius to: minRadius by: -10 do:[:rad| | rect | rect := 400@400 - rad corner: 400@400 + rad. Display getCanvas fillOval: rect color: Color yellow borderWidth: 1 borderColor: Color red. (Bezier2Segment makeEllipseSegments: rect) do:[:seg| seg lineSegmentsDo:[:last :next| Display getCanvas line: last to: next width: 1 color: Color black]]]. " | nrm topCenter leftCenter rightCenter bottomCenter dir scale seg1a topRight seg1b seg2a bottomRight seg2b center bottomLeft topLeft seg3a seg3b seg4a seg4b | dir := aRectangle width * 0.5. nrm := aRectangle height * 0.5. "Compute the eight control points on the oval" scale := 0.7071067811865475. "45 degreesToRadians cos = 45 degreesToRadians sin = 2 sqrt / 2" center := aRectangle origin + aRectangle corner * 0.5. topCenter := aRectangle topCenter. rightCenter := aRectangle rightCenter. leftCenter := aRectangle leftCenter. bottomCenter := aRectangle bottomCenter. topRight := (center x + (dir * scale)) @ (center y - (nrm * scale)). bottomRight := (center x + (dir * scale)) @ (center y + (nrm * scale)). bottomLeft := (center x - (dir * scale)) @ (center y + (nrm * scale)). topLeft := (center x - (dir * scale)) @ (center y - (nrm * scale)). scale := 0.414213562373095. "2 sqrt - 1" dir := (dir * scale) @ 0. nrm := 0 @ (nrm * scale). seg1a := self from: topCenter via: topCenter + dir to: topRight. seg1b := self from: topRight via: rightCenter - nrm to: rightCenter. seg2a := self from: rightCenter via: rightCenter + nrm to: bottomRight. seg2b := self from: bottomRight via: bottomCenter + dir to: bottomCenter. seg3a := self from: bottomCenter via: bottomCenter - dir to: bottomLeft. seg3b := self from: bottomLeft via: leftCenter + nrm to: leftCenter. seg4a := self from: leftCenter via: leftCenter - nrm to: topLeft. seg4b := self from: topLeft via: topCenter - dir to: topCenter. ^{seg1a. seg1b. seg2a. seg2b. seg3a. seg3b. seg4a. seg4b}! ! LineSegment subclass: #Bezier3Segment instanceVariableNames: 'via1 via2' classVariableNames: '' poolDictionaries: '' category: 'Balloon-Geometry'! !Bezier3Segment commentStamp: '' prior: 0! This class represents a cubic bezier segment between two points Instance variables: via1, via2 The additional control points (OFF the curve)! !Bezier3Segment methodsFor: 'accessing' stamp: 'DSM 10/15/1999 15:20'! bounds ^ ((super bounds encompassing: via1) encompassing: via2)! ! !Bezier3Segment methodsFor: 'accessing' stamp: 'ar 6/8/2003 00:07'! degree ^3! ! !Bezier3Segment methodsFor: 'accessing' stamp: 'ar 6/6/2003 21:59'! length "Answer a gross approximation of the length of the receiver" ^(start dist: via1) + (via1 dist: via2) + (via2 dist: end)! ! !Bezier3Segment methodsFor: 'accessing' stamp: 'DSM 10/15/1999 15:01'! valueAt: t | a b c d | "| p1 p2 p3 | p1 := start interpolateTo: via1 at: t. p2 := via1 interpolateTo: via2 at: t. p3 := via2 interpolateTo: end at: t. p1 := p1 interpolateTo: p2 at: t. p2 := p2 interpolateTo: p3 at: t. ^ p1 interpolateTo: p2 at: t" a := (start negated) + (3 * via1) - (3 * via2) + (end). b := (3 * start) - (6 * via1) + (3 * via2). c := (3 * start negated) + (3 * via1). d := start. ^ ((a * t + b) * t + c) * t + d ! ! !Bezier3Segment methodsFor: 'accessing' stamp: 'ar 6/6/2003 22:37'! via1 ^via1! ! !Bezier3Segment methodsFor: 'accessing' stamp: 'DSM 10/14/1999 15:31'! via1: aPoint via1 := aPoint! ! !Bezier3Segment methodsFor: 'accessing' stamp: 'ar 6/6/2003 22:37'! via2 ^via2! ! !Bezier3Segment methodsFor: 'accessing' stamp: 'DSM 10/14/1999 15:31'! via2: aPoint via2 := aPoint! ! !Bezier3Segment methodsFor: 'bezier clipping' stamp: 'ar 6/7/2003 23:45'! bezierClipHeight: dir "Check if the argument overlaps the receiver somewhere along the line from start to end. Optimized for speed." | u dirX dirY dx dy uMin uMax | dirX := dir x. dirY := dir y. uMin := 0.0. uMax := (dirX * dirX) + (dirY * dirY). dx := via1 x - start x. dy := via1 y - start y. u := (dirX * dx) + (dirY * dy). u < uMin ifTrue:[uMin := u]. u > uMax ifTrue:[uMax := u]. dx := via2 x - start x. dy := via2 y - start y. u := (dirX * dx) + (dirY * dy). u < uMin ifTrue:[uMin := u]. u > uMax ifTrue:[uMax := u]. ^uMin@uMax! ! !Bezier3Segment methodsFor: 'converting' stamp: 'ar 6/7/2003 21:07'! asBezier2Points: error "Demote a cubic bezier to a set of approximating quadratic beziers. Should convert to forward differencing someday" | curves pts step prev index a b f | curves := self bezier2SegmentCount: error. pts := Array new: curves * 3. step := 1.0 / (curves * 2). prev := start. 1 to: curves do: [ :c | index := 3*c. a := pts at: index-2 put: prev. b := (self valueAt: (c*2-1)*step). f := pts at: index put: (self valueAt: (c*2)*step). pts at: index-1 put: (4 * b - a - f) / 2. prev := pts at: index. ]. ^ pts. ! ! !Bezier3Segment methodsFor: 'converting' stamp: 'ar 6/7/2003 21:07'! asBezier2Segments "Demote a cubic bezier to a set of approximating quadratic beziers." ^self asBezier2Segments: 0.5! ! !Bezier3Segment methodsFor: 'converting' stamp: 'ar 6/6/2003 22:23'! asBezierShape "Demote a cubic bezier to a set of approximating quadratic beziers." ^self asBezierShape: 0.5! ! !Bezier3Segment methodsFor: 'converting' stamp: 'ar 6/7/2003 21:09'! asBezierShape: error "Demote a cubic bezier to a set of approximating quadratic beziers. Should convert to forward differencing someday" ^(self asBezier2Points: error) asPointArray.! ! !Bezier3Segment methodsFor: 'converting' stamp: 'DSM 10/15/1999 15:45'! asPointArray | p | p := PointArray new: 4. p at: 1 put: start. p at: 2 put: via1. p at: 3 put: via2. p at: 4 put: end. ^ p! ! !Bezier3Segment methodsFor: 'converting' stamp: 'ar 6/7/2003 20:58'! asTangentSegment ^Bezier2Segment from: via1-start via: via2-via1 to: end-via2! ! !Bezier3Segment methodsFor: 'converting' stamp: 'DSM 3/10/2000 12:10'! bezier2SegmentCount: pixelError "Compute the number of quadratic bezier segments needed to approximate this cubic with no more than a specified error" | a | a := (start x negated @ start y negated) + (3 * via1) - (3 * via2) + (end). ^ (((a r / (20.0 * pixelError)) raisedTo: 0.333333) ceiling) max: 1. ! ! !Bezier3Segment methodsFor: 'initialization' stamp: 'DSM 10/14/1999 15:33'! from: aPoint1 via: aPoint2 and: aPoint3 to: aPoint4 start := aPoint1. via1 := aPoint2. via2 := aPoint3. end := aPoint4! ! !Bezier3Segment methodsFor: 'initialization' stamp: 'ar 6/7/2003 00:09'! initializeFrom: controlPoints controlPoints size = 4 ifFalse:[self error:'Wrong number of control points']. start := controlPoints at: 1. via1 := controlPoints at: 2. via2 := controlPoints at: 3. end := controlPoints at: 4.! ! !Bezier3Segment methodsFor: 'vector functions' stamp: 'ar 6/7/2003 00:08'! controlPoints ^{start. via1. via2. end}! ! !Bezier3Segment methodsFor: 'vector functions' stamp: 'ar 6/7/2003 23:39'! controlPointsDo: aBlock aBlock value: start; value: via1; value: via2; value: end! ! !Bezier3Segment methodsFor: 'vector functions' stamp: 'ar 6/6/2003 21:52'! lineSegmentsDo: aBlock "Evaluate aBlock with the receiver's line segments" "Note: We could use forward differencing here." | steps last deltaStep t next | steps := 1 max: (self length // 10). "Assume 10 pixels per step" last := start. deltaStep := 1.0 / steps asFloat. t := deltaStep. 1 to: steps do:[:i| next := self valueAt: t. aBlock value: last value: next. last := next. t := t + deltaStep].! ! !Bezier3Segment methodsFor: 'vector functions' stamp: 'ar 6/7/2003 17:21'! lineSegments: steps do: aBlock "Evaluate aBlock with the receiver's line segments" "Note: We could use forward differencing here." | last deltaStep t next | last := start. deltaStep := 1.0 / steps asFloat. t := deltaStep. 1 to: steps do:[:i| next := self valueAt: t. aBlock value: last value: next. last := next. t := t + deltaStep].! ! !Bezier3Segment methodsFor: 'vector functions' stamp: 'ar 6/7/2003 00:04'! outlineSegment: width | tan1 nrm1 tan2 nrm2 newStart newVia1 newEnd newVia2 dist | tan1 := (via1 - start) normalized. nrm1 := tan1 * width. nrm1 := nrm1 y @ nrm1 x negated. tan2 := (end - via2) normalized. nrm2 := tan2 * width. nrm2 := nrm2 y @ nrm2 x negated. newStart := start + nrm1. newEnd := end + nrm2. dist := (newStart dist: newEnd) * 0.3. newVia1 := newStart + (tan1 * dist). newVia2 := newEnd - (tan2 * dist). ^self class from: newStart via: newVia1 and: newVia2 to: newEnd. ! ! !Bezier3Segment methodsFor: 'vector functions' stamp: 'ar 6/6/2003 22:02'! tangentAtEnd ^end - via2! ! !Bezier3Segment methodsFor: 'vector functions' stamp: 'ar 6/8/2003 00:56'! tangentAtMid | tan1 tan2 tan3 | tan1 := via1 - start. tan2 := via2 - via1. tan3 := end - via2. ^(tan1 + (2*tan2) + tan3) * 0.25 ! ! !Bezier3Segment methodsFor: 'vector functions' stamp: 'ar 6/6/2003 22:01'! tangentAtStart ^via1 - start! ! !Bezier3Segment methodsFor: 'vector functions' stamp: 'ar 6/7/2003 19:25'! tangentAt: parameter | tan1 tan2 tan3 t1 t2 t3 | tan1 := via1 - start. tan2 := via2 - via1. tan3 := end - via2. t1 := (1.0 - parameter) squared. t2 := 2 * parameter * (1.0 - parameter). t3 := parameter squared. ^(tan1 * t1) + (tan2 * t2) + (tan3 * t3)! ! !Bezier3Segment methodsFor: 'private' stamp: 'DSM 10/14/1999 16:25'! bezier2SegmentCount "Compute the number of quadratic bezier segments needed to approximate this cubic with less than a 1-pixel error" ^ self bezier2SegmentCount: 1.0! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Bezier3Segment class instanceVariableNames: ''! !Bezier3Segment class methodsFor: 'examples' stamp: 'DSM 10/15/1999 15:49'! example1 | c | c := Bezier3Segment new from: 0@0 via: 0@100 and: 100@0 to: 100@100. ^ c asBezierShape! ! !Bezier3Segment class methodsFor: 'examples' stamp: 'DSM 10/15/1999 16:00'! example2 "draws a cubic bezier on the screen" | c canvas | c := Bezier3Segment new from: 0 @ 0 via: 0 @ 100 and: 100 @ 0 to: 100 @ 100. canvas := BalloonCanvas on: Display. canvas aaLevel: 4. canvas drawBezier3Shape: c asPointArray color: Color transparent borderWidth: 1 borderColor: Color black! ! !Bezier3Segment class methodsFor: 'instance creation' stamp: 'DSM 10/15/1999 15:23'! from: p1 to: p2 ^ self new from: p1 via: (p1 interpolateTo: p2 at: 0.3333) and: (p1 interpolateTo: p2 at: 0.66667) to: p2! ! !Bezier3Segment class methodsFor: 'instance creation' stamp: 'DSM 10/15/1999 15:24'! from: p1 via: p2 and: p3 to: p4 ^ self new from: p1 via: p2 and: p3 to: p4! ! !Bezier3Segment class methodsFor: 'utilities' stamp: 'DSM 10/15/1999 16:06'! convertBezier3ToBezier2: vertices | pa pts index c | pts := OrderedCollection new. 1 to: vertices size // 4 do: [:i | index := i * 4 - 3. c := Bezier3Segment new from: (vertices at: index) via: (vertices at: index + 1) and: (vertices at: index + 2) to: (vertices at: index + 3). pts addAll: c asBezierShape]. pa := PointArray new: pts size. pts withIndexDo: [:p :i | pa at: i put: p ]. ^ pa! ! !Bezier3Segment class methodsFor: 'utilities' stamp: 'ar 6/8/2003 03:25'! makeEllipseSegments: aRectangle "Answer a set of bezier segments approximating an ellipsoid fitting the given rectangle. This method creates four bezier segments (one for each quadrant) approximating the oval." "EXAMPLE: This example draws an oval with a red border and overlays the approximating bezier segments on top of the oval (drawn in black), thus giving an impression of how closely the bezier resembles the oval. Change the rectangle to see how accurate the approximation is for various radii of the oval. | rect | rect := 100@100 extent: 500@200. Display getCanvas fillOval: rect color: Color yellow borderWidth: 1 borderColor: Color red. (Bezier3Segment makeEllipseSegments: rect) do:[:seg| seg lineSegmentsDo:[:last :next| Display getCanvas line: last to: next width: 1 color: Color black]]. " "EXAMPLE: | minRadius maxRadius | maxRadius := 300. minRadius := 20. maxRadius to: minRadius by: -10 do:[:rad| | rect | rect := 400@400 - rad corner: 400@400 + rad. Display getCanvas fillOval: rect color: Color yellow borderWidth: 1 borderColor: Color red. (Bezier3Segment makeEllipseSegments: rect) do:[:seg| seg lineSegmentsDo:[:last :next| Display getCanvas line: last to: next width: 1 color: Color black]]]. " ^self makeEllipseSegments: aRectangle count: 4! ! !Bezier3Segment class methodsFor: 'utilities' stamp: 'eem 6/11/2008 16:08'! makeEllipseSegments: aRectangle count: segmentCount "Answer a set of bezier segments approximating an ellipsoid fitting the given rectangle. This method creates segmentCount bezier segments (one for each quadrant) approximating the oval." | count angle center scale | center := aRectangle origin + aRectangle corner * 0.5. scale := aRectangle extent * 0.5. count := segmentCount max: 2. "need at least two segments" angle := 360.0 / count. ^(1 to: count) collect:[:i| | seg | seg := self makeUnitPieSegmentFrom: i-1*angle to: i*angle. self controlPoints: (seg controlPoints collect:[:pt| pt * scale + center]) ].! ! !Bezier3Segment class methodsFor: 'utilities' stamp: 'ar 6/8/2003 03:53'! makePieSegments: aRectangle from: angle1 to: angle2 "Create a series of cubic bezier segments for the oval inscribed in aRectangle between angle1 and angle2. The segments are oriented clockwise, to get counter-clockwise segments simply switch angle1 and angle2." angle2 < angle1 ifTrue:[ "ccw segments" ^(self makePieSegments: aRectangle from: angle2 to: angle1) reversed collect:[:seg| seg reversed] ]. "Split up segments if larger than 120 degrees" angle2 - angle1 > 120 ifTrue:["subdivide" | midAngle | midAngle := angle1 + angle2 * 0.5. ^(self makePieSegments: aRectangle from: angle1 to: midAngle), (self makePieSegments: aRectangle from: midAngle to: angle2). ]. "Create actual pie segment" ^self makePieSegment: aRectangle from: angle1 to: angle2 ! ! !Bezier3Segment class methodsFor: 'utilities' stamp: 'ar 6/8/2003 03:26'! makePieSegment: aRectangle from: angle1 to: angle2 "Create a single pie segment for the oval inscribed in aRectangle between angle1 and angle2. If angle1 is less than angle2 this method creates a CW pie segment, otherwise it creates a CCW pie segment." | seg center scale | angle1 > angle2 ifTrue:["ccw" ^(self makePieSegment: aRectangle from: angle2 to: angle1) reversed ]. "create a unit circle pie segment from angle1 to angle2" seg := self makeUnitPieSegmentFrom: angle1 to: angle2. "scale the segment to fit aRectangle" center := aRectangle origin + aRectangle corner * 0.5. scale := aRectangle extent * 0.5. ^self controlPoints: (seg controlPoints collect:[:pt| pt * scale + center])! ! !Bezier3Segment class methodsFor: 'utilities' stamp: 'ar 6/8/2003 03:59'! makeUnitPieSegmentFrom: angle1 to: angle2 "Create a clockwise unit pie segment from angle1 to angle2, that is a pie segment for a circle centered at zero with radius one. Note: This method can be used to create at most a quarter circle." | pt1 pt2 rad1 rad2 | rad1 := angle1 degreesToRadians. rad2 := angle2 degreesToRadians. pt1 := rad1 sin @ rad1 cos negated. pt2 := rad2 sin @ rad2 cos negated. ^self makeUnitPieSegmentWith: pt1 and: pt2! ! !Bezier3Segment class methodsFor: 'utilities' stamp: 'ar 6/8/2003 04:45'! makeUnitPieSegmentWith: point1 and: point2 "Create a clockwise unit pie segment from point1 to point2, that is a pie segment for a circle centered at zero with radius one." | pt1 pt2 dir1 dir2 mid length scale cp1 cp2 pt3 magic | "point1 and point2 are the points on the unit circle for accuracy (or broken input), renormalize them." pt1 := point1 normalized. pt2 := point2 normalized. "compute the normal vectors - those are tangent directions for the bezier" dir1 := pt1 y negated @ pt1 x. dir2 := pt2 y negated @ pt2 x. "Okay, now that we have the points and tangents on the unit circle, let's do the magic. For fitting a cubic bezier onto a circle section we know that we want the end points be on the circle and the tangents to point towards the right direction (both of which we have in the above). What we do NOT know is how to scale the tangents so that midpoint of the bezier is exactly on the circle. The good news is that there is a linear relation between the length of the tangent vectors and the distance of the midpoint from the circle's origin. The bad news is that I don't know how to derive it analytically. So what I do here is simply sampling the bezier twice (not really - the first sample is free) and then to compute the distance from the sample." "The first sample is just between the two points on the curve" mid := pt1 + pt2 * 0.5. "The second sample will be taken from the curve with coincident control points at the intersection of dir1 and dir2, which simplifies significantly with a little understanding about trigonometry, since the angle formed between mid, pt1 and the intersection is the same as between the center, pt1 and mid." length := mid r. "length is not only the distance from the center of the unit circle but also the sine of the angle between the circle's center, pt1 and mid (since center is at zero and pt1 has unit length). Therefore, to scale dir1 to the intersection with dir2 we can use mid's distance from pt1 and simply divide it by the sine value." scale := (mid dist: pt1). length > 0.0 ifTrue:[ scale := scale / length]. "now sample the cubic bezier (optimized version for coincident control points)" cp1 := pt1 + (dir1 * (scale * 0.75)). cp2 := pt2 - (dir2 * (scale * 0.75)). pt3 := cp1 + cp2 * 0.5. "compute the magic constant" scale := (pt3 - mid) r / scale. magic := 1.0 - length / scale. "and finally answer the pie segment" ^self from: pt1 via: pt1 + (dir1 * magic) and: pt2 - (dir2 * magic) to: pt2! ! Object subclass: #BitBlt instanceVariableNames: 'destForm sourceForm halftoneForm combinationRule destX destY width height sourceX sourceY clipX clipY clipWidth clipHeight colorMap' classVariableNames: 'CachedFontColorMaps ColorConvertingMaps' poolDictionaries: '' category: 'Graphics-Primitives'! !BitBlt commentStamp: '' prior: 0! I represent a block transfer (BLT) of pixels into a rectangle (destX, destY, width, height) of the destinationForm. The source of pixels may be a similar rectangle (at sourceX, sourceY) in the sourceForm, or a constant color, currently called halftoneForm. If both are specified, their pixel values are combined with a logical AND function prior to transfer. In any case, the pixels from the source are combined with those of the destination by as specified by the combinationRule. The combination rule whose value is 0 through 15 programs the transfer to produce 1 or 0 according to its 4-bit representation as follows: 8: if source is 0 and destination is 0 4: if source is 0 and destination is 1 2: if source is 1 and destination is 0 1: if source is 1 and destination is 1. At each pixel the corresponding bits of the source and destination pixel values determine one of these conditions; if the combination rule has a 1 in the corresponding bit position, then the new destination value will be 1, otherwise it will be zero. Forms may be of different depths, see the comment in class Form. In addition to the original 16 combination rules, this BitBlt supports 16 fails (to simulate paint bits) 17 fails (to simulate erase bits) 18 sourceWord + destinationWord 19 sourceWord - destinationWord 20 rgbAdd: sourceWord with: destinationWord. Sum of color components 21 rgbSub: sourceWord with: destinationWord. Difference of color components 22 OLDrgbDiff: sourceWord with: destinationWord. Sum of abs of differences in components 23 OLDtallyIntoMap: destinationWord. Tallies pixValues into a colorMap these old versions don't do bitwise dest clipping. Use 32 and 33 now. 24 alphaBlend: sourceWord with: destinationWord. 32-bit source and dest only 25 pixPaint: sourceWord with: destinationWord. Wherever the sourceForm is non-zero, it replaces the destination. Can be used with a 1-bit source color mapped to (0, FFFFFFFF), and a fillColor to fill the dest with that color wherever the source is 1. 26 pixMask: sourceWord with: destinationWord. Like pixPaint, but fills with 0. 27 rgbMax: sourceWord with: destinationWord. Max of each color component. 28 rgbMin: sourceWord with: destinationWord. Min of each color component. 29 rgbMin: sourceWord bitInvert32 with: destinationWord. Min with (max-source) 30 alphaBlendConst: sourceWord with: destinationWord. alpha is an arg. works in 16 bits. 31 alphaPaintConst: sourceWord with: destinationWord. alpha is an arg. works in 16 bits. 32 rgbDiff: sourceWord with: destinationWord. Sum of abs of differences in components 33 tallyIntoMap: destinationWord. Tallies pixValues into a colorMap 34 alphaBlendScaled: srcWord with: dstWord. Alpha blend of scaled srcWord and destWord. The color specified by halftoneForm may be either a Color or a Pattern. A Color is converted to a pixelValue for the depth of the destinationForm. If a Pattern, BitBlt will simply interpret its bitmap as an array of Color pixelValues. BitBlt aligns the first element of this array with the top scanline of the destinationForm, the second with the second, and so on, cycling through the color array as necessary. Within each scan line the 32-bit value is repeated from left to right across the form. If the value repeats on pixels boudaries, the effect will be a constant color; if not, it will produce a halftone that repeats on 32-bit boundaries. Any transfer specified is further clipped by the specified rectangle (clipX, clipY, clipWidth, clipHeight), and also by the bounds of the source and destination forms. To make a small Form repeat and fill a big form, use an InfiniteForm as the source. To write on a form and leave with both transparent and opapue areas, use a MaskedForm as the source. Pixels from a source to a destination whose pixels have a different depth are converted based on the optional colorMap. If colorMap is nil, then conversion to more bits is done by filling the new high-order bits with zero, and conversion to fewer bits is done by truncating the lost high-order bits. The colorMap, if specified, must be a either word array (ie Bitmap) with 2^n elements, where n is the pixel depth of the source, or a fully specified ColorMap which may contain a lookup table (ie Bitmap) and/or four separate masks and shifts which are applied to the pixels. For every source pixel, BitBlt will first perform masking and shifting and then index the lookup table, and select the corresponding pixelValue and mask it to the destination pixel size before storing. When blitting from a 32 or 16 bit deep Form to one 8 bits or less, the default is truncation. This will produce very strange colors, since truncation of the high bits does not produce the nearest encoded color. Supply a 512 long colorMap, and red, green, and blue will be shifted down to 3 bits each, and mapped. The message copybits...stdColors will use the best map to the standard colors for destinations of depths 8, 4, 2 and 1. Two other sized of colorMaps are allowed, 4096 (4 bits per color) and 32786 (five bits per color). Normal blits between 16 and 32 bit forms truncates or pads the colors automatically to provide the best preservation of colors. Colors can be remapped at the same depth. Sometimes a Form is in terms of colors that are not the standard colors for this depth, for example in a GIF file. Convert the Form to a MaskedForm and send colorMap: the list of colors that the picture is in terms of. MaskedForm will use the colorMap when copying to the display or another Form. (Note also that a Form can be copied to itself, and transformed in the process, if a non-nil colorMap is supplied.)! !BitBlt methodsFor: '*FreeType-addition' stamp: 'tween 8/1/2006 17:52'! combinationRule "Answer the receiver's combinationRule" ^combinationRule! ! !BitBlt methodsFor: '*FreeType-addition' stamp: 'tween 7/28/2006 17:54'! copyBitsColor: argbColorSmallInteger alpha: argbAlphaSmallInteger gammaTable: gammaByteArray ungammaTable: ungammaByteArray "This entry point to BitBlt supplies an extra argument to specify the fore color argb value for operation 41. This is split into an alpha value and an rgb value, so that both can be passed as smallIntegers to the primitive. rgbColorInteger must be a smallInteger between 0 and 16rFFFFFF. alpha must be a smallInteger between 0 and 16rFF." "Check for compressed source, destination or halftone forms" ((sourceForm isForm) and: [sourceForm unhibernate]) ifTrue: [^ self copyBitsColor: argbColorSmallInteger alpha: argbAlphaSmallInteger gammaTable: gammaByteArray ungammaTable: ungammaByteArray]. ((destForm isForm) and: [destForm unhibernate ]) ifTrue: [^ self copyBitsColor: argbColorSmallInteger alpha: argbAlphaSmallInteger gammaTable: gammaByteArray ungammaTable: ungammaByteArray]. ((halftoneForm isForm) and: [halftoneForm unhibernate]) ifTrue: [^ self copyBitsColor: argbColorSmallInteger alpha: argbAlphaSmallInteger gammaTable: gammaByteArray ungammaTable: ungammaByteArray]. self primitiveFailed "Later do nicer error recovery -- share copyBits recovery"! ! !BitBlt methodsFor: '*FreeType-addition' stamp: 'tween 4/4/2007 20:59'! installFreeTypeFont: aFreeTypeFont foregroundColor: foregroundColor backgroundColor: backgroundColor "Set up the parameters. Since the glyphs in a TTCFont is 32bit depth form, it tries to use rule=34 to get better AA result if possible." (FreeTypeSettings current bitBltSubPixelAvailable and: [destForm depth >= 8]) ifTrue:[ self combinationRule: 41. destForm depth = 8 ifTrue:[self colorMap: (self cachedFontColormapFrom: 32 to: destForm depth)] ifFalse:[self colorMap: nil]] ifFalse:[ "use combination rule 34 when rule 41 is not available in the BitBlt plugin, or the destination form depth <= 8" destForm depth <= 8 ifTrue: [ self colorMap: (self cachedFontColormapFrom: 32 to: destForm depth). self combinationRule: Form paint.] ifFalse: [ self colorMap: nil. self combinationRule: 34]]. halftoneForm := nil. sourceX := sourceY := 0. height := aFreeTypeFont height. ! ! !BitBlt methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! clipBy: aRectangle | aPoint right bottom | right := clipX + clipWidth. bottom := clipY + clipHeight. aPoint := aRectangle origin. aPoint x > clipX ifTrue: [ clipX := aPoint x ]. aPoint y > clipY ifTrue: [ clipY := aPoint y ]. aPoint := aRectangle corner. aPoint x < right ifTrue: [ right := aPoint x ]. aPoint y < bottom ifTrue: [ bottom := aPoint y ]. clipWidth := right - clipX. clipHeight := bottom - clipY. clipWidth < 0 ifTrue: [ clipWidth := 0 ]. clipHeight < 0 ifTrue: [ clipHeight := 0 ]! ! !BitBlt methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! clipByX1: x1 y1: y1 x2: x2 y2: y2 | right bottom | right := clipX + clipWidth. bottom := clipY + clipHeight. x1 > clipX ifTrue: [ clipX := x1 ]. y1 > clipY ifTrue: [ clipY := y1 ]. x2 < right ifTrue: [ right := x2 ]. y2 < bottom ifTrue: [ bottom := y2 ]. clipWidth := right - clipX. clipHeight := bottom - clipY. clipWidth < 0 ifTrue: [ clipWidth := 0 ]. clipHeight < 0 ifTrue: [ clipHeight := 0 ]! ! !BitBlt methodsFor: 'accessing' stamp: 'ar 5/17/2000 18:58'! clipHeight ^clipHeight! ! !BitBlt methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! clipHeight: anInteger "Set the receiver's clipping area height to be the argument, anInteger." clipHeight := anInteger! ! !BitBlt methodsFor: 'accessing'! clipRect "Answer the receiver's clipping area rectangle." ^clipX @ clipY extent: clipWidth @ clipHeight! ! !BitBlt methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! clipRect: aRectangle "Set the receiver's clipping area rectangle to be the argument, aRectangle." clipX := aRectangle left truncated. clipY := aRectangle top truncated. clipWidth := aRectangle right truncated - clipX. clipHeight := aRectangle bottom truncated - clipY! ! !BitBlt methodsFor: 'accessing' stamp: 'ar 5/17/2000 18:58'! clipWidth ^clipWidth! ! !BitBlt methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! clipWidth: anInteger "Set the receiver's clipping area width to be the argument, anInteger." clipWidth := anInteger! ! !BitBlt methodsFor: 'accessing' stamp: 'ar 5/17/2000 18:58'! clipX ^clipX! ! !BitBlt methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! clipX: anInteger "Set the receiver's clipping area top left x coordinate to be the argument, anInteger." clipX := anInteger! ! !BitBlt methodsFor: 'accessing' stamp: 'ar 5/17/2000 18:58'! clipY ^clipY! ! !BitBlt methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! clipY: anInteger "Set the receiver's clipping area top left y coordinate to be the argument, anInteger." clipY := anInteger! ! !BitBlt methodsFor: 'accessing' stamp: 'tk 8/15/2001 10:56'! color "Return the current fill color as a Color. Gives the wrong answer if the halftoneForm is a complex pattern of more than one word." halftoneForm ifNil: [^ Color black]. ^ Color colorFromPixelValue: halftoneForm first depth: destForm depth! ! !BitBlt methodsFor: 'accessing'! colorMap ^ colorMap! ! !BitBlt methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! colorMap: map "See last part of BitBlt comment. 6/18/96 tk" colorMap := map! ! !BitBlt methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! combinationRule: anInteger "Set the receiver's combination rule to be the argument, anInteger, a number in the range 0-15." combinationRule := anInteger! ! !BitBlt methodsFor: 'accessing'! destForm ^ destForm! ! !BitBlt methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! destOrigin: aPoint "Set the receiver's destination top left coordinates to be those of the argument, aPoint." destX := aPoint x. destY := aPoint y! ! !BitBlt methodsFor: 'accessing' stamp: 'tk 3/19/97'! destRect "The rectangle we are about to blit to or just blitted to. " ^ destX @ destY extent: width @ height! ! !BitBlt methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! destRect: aRectangle "Set the receiver's destination form top left coordinates to be the origin of the argument, aRectangle, and set the width and height of the receiver's destination form to be the width and height of aRectangle." destX := aRectangle left. destY := aRectangle top. width := aRectangle width. height := aRectangle height! ! !BitBlt methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! destX: anInteger "Set the top left x coordinate of the receiver's destination form to be the argument, anInteger." destX := anInteger! ! !BitBlt methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! destX: x destY: y width: w height: h "Combined init message saves 3 sends from DisplayScanner" destX := x. destY := y. width := w. height := h! ! !BitBlt methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! destY: anInteger "Set the top left y coordinate of the receiver's destination form to be the argument, anInteger." destY := anInteger! ! !BitBlt methodsFor: 'accessing'! fillColor ^ halftoneForm! ! !BitBlt methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! fillColor: aColorOrPattern "The destForm will be filled with this color or pattern of colors. May be an old Color, a new type Color, a Bitmap (see BitBlt comment), a Pattern, or a Form. 6/18/96 tk" aColorOrPattern == nil ifTrue: [ halftoneForm := nil. ^ self ]. destForm == nil ifTrue: [ self error: 'Must set destForm first' ]. halftoneForm := destForm bitPatternFor: aColorOrPattern! ! !BitBlt methodsFor: 'accessing' stamp: 'tbn 9/14/2004 20:38'! halftoneForm "Returns the receivers half tone form. See class commment." ^halftoneForm! ! !BitBlt methodsFor: 'accessing' stamp: 'tbn 9/14/2004 20:39'! halftoneForm: aBitmap "Sets the receivers half tone form. See class commment." halftoneForm := aBitmap ! ! !BitBlt methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! height: anInteger "Set the receiver's destination form height to be the argument, anInteger." height := anInteger! ! !BitBlt methodsFor: 'accessing'! sourceForm ^ sourceForm! ! !BitBlt methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! sourceForm: aForm "Set the receiver's source form to be the argument, aForm." sourceForm := aForm! ! !BitBlt methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! sourceOrigin: aPoint "Set the receiver's source form coordinates to be those of the argument, aPoint." sourceX := aPoint x. sourceY := aPoint y! ! !BitBlt methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! sourceRect: aRectangle "Set the receiver's source form top left x and y, width and height to be the top left coordinate and extent of the argument, aRectangle." sourceX := aRectangle left. sourceY := aRectangle top. width := aRectangle width. height := aRectangle height! ! !BitBlt methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! sourceX: anInteger "Set the receiver's source form top left x to be the argument, anInteger." sourceX := anInteger! ! !BitBlt methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! sourceY: anInteger "Set the receiver's source form top left y to be the argument, anInteger." sourceY := anInteger! ! !BitBlt methodsFor: 'accessing' stamp: 'ar 5/25/2000 19:39'! tallyMap "Return the map used for tallying pixels" ^colorMap! ! !BitBlt methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! tallyMap: aBitmap "Install the map used for tallying pixels" colorMap := aBitmap! ! !BitBlt methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! width: anInteger "Set the receiver's destination form width to be the argument, anInteger." width := anInteger! ! !BitBlt methodsFor: 'copying' stamp: 'jmv 8/4/2009 16:29'! basicDisplayString: aString from: startIndex to: stopIndex at: aPoint strikeFont: font kern: kernDelta destY := aPoint y. destX := aPoint x. "the following are not really needed, but theBitBlt primitive will fail if not set" sourceX ifNil: [sourceX := 100]. width ifNil: [width := 100]. self primDisplayString: aString from: startIndex to: stopIndex map: font characterToGlyphMap xTable: font xTable kern: kernDelta. ^ destX@destY. ! ! !BitBlt methodsFor: 'copying' stamp: 'lr 7/4/2009 10:42'! copy: destRectangle from: sourcePt in: srcForm | destOrigin | sourceForm := srcForm. halftoneForm := nil. combinationRule := 3. "store" destOrigin := destRectangle origin. destX := destOrigin x. destY := destOrigin y. sourceX := sourcePt x. sourceY := sourcePt y. width := destRectangle width. height := destRectangle height. self copyBits! ! !BitBlt methodsFor: 'copying' stamp: 'lr 7/4/2009 10:42'! copy: destRectangle from: sourcePt in: srcForm fillColor: hf rule: rule "Specify a Color to fill, not a Form. 6/18/96 tk" | destOrigin | sourceForm := srcForm. self fillColor: hf. "sets halftoneForm" combinationRule := rule. destOrigin := destRectangle origin. destX := destOrigin x. destY := destOrigin y. sourceX := sourcePt x. sourceY := sourcePt y. width := destRectangle width. height := destRectangle height. srcForm == nil ifFalse: [ colorMap := srcForm colormapIfNeededFor: destForm ]. ^ self copyBits! ! !BitBlt methodsFor: 'copying' stamp: 'lr 7/4/2009 10:42'! copy: destRectangle from: sourcePt in: srcForm halftoneForm: hf rule: rule | destOrigin | sourceForm := srcForm. self fillColor: hf. "sets halftoneForm" combinationRule := rule. destOrigin := destRectangle origin. destX := destOrigin x. destY := destOrigin y. sourceX := sourcePt x. sourceY := sourcePt y. width := destRectangle width. height := destRectangle height. self copyBits! ! !BitBlt methodsFor: 'copying' stamp: 'lr 7/4/2009 10:42'! copyBits "Primitive. Perform the movement of bits from the source form to the destination form. Fail if any variables are not of the right type (Integer, Float, or Form) or if the combination rule is not implemented. In addition to the original 16 combination rules, this BitBlt supports 16 fail (to simulate paint) 17 fail (to simulate mask) 18 sourceWord + destinationWord 19 sourceWord - destinationWord 20 rgbAdd: sourceWord with: destinationWord 21 rgbSub: sourceWord with: destinationWord 22 rgbDiff: sourceWord with: destinationWord 23 tallyIntoMap: destinationWord 24 alphaBlend: sourceWord with: destinationWord 25 pixPaint: sourceWord with: destinationWord 26 pixMask: sourceWord with: destinationWord 27 rgbMax: sourceWord with: destinationWord 28 rgbMin: sourceWord with: destinationWord 29 rgbMin: sourceWord bitInvert32 with: destinationWord " "Check for compressed source, destination or halftone forms" (combinationRule >= 30 and: [ combinationRule <= 31 ]) ifTrue: [ "No alpha specified -- re-run with alpha = 1.0" ^ self copyBitsTranslucent: 255 ]. (sourceForm isForm and: [ sourceForm unhibernate ]) ifTrue: [ ^ self copyBits ]. (destForm isForm and: [ destForm unhibernate ]) ifTrue: [ ^ self copyBits ]. (halftoneForm isForm and: [ halftoneForm unhibernate ]) ifTrue: [ ^ self copyBits ]. "Check for unimplmented rules" combinationRule = Form oldPaint ifTrue: [ ^ self paintBits ]. combinationRule = Form oldErase1bitShape ifTrue: [ ^ self eraseBits ]. "Check if BitBlt doesn't support full color maps" (colorMap notNil and: [ colorMap isColormap ]) ifTrue: [ colorMap := colorMap colors. ^ self copyBits ]. "Check if clipping gots us way out of range" self clipRange ifTrue: [ self roundVariables. ^ self copyBitsAgain ]. self error: 'Bad BitBlt arg (Fraction?); proceed to convert.'. "Convert all numeric parameters to integers and try again." self roundVariables. ^ self copyBitsAgain! ! !BitBlt methodsFor: 'copying' stamp: 'nk 4/17/2004 19:42'! copyBitsTranslucent: factor "This entry point to BitBlt supplies an extra argument to specify translucency for operations 30 and 31. The argument must be an integer between 0 and 255." "Check for compressed source, destination or halftone forms" ((sourceForm isForm) and: [sourceForm unhibernate]) ifTrue: [^ self copyBitsTranslucent: factor]. ((destForm isForm) and: [destForm unhibernate]) ifTrue: [^ self copyBitsTranslucent: factor]. ((halftoneForm isForm) and: [halftoneForm unhibernate]) ifTrue: [^ self copyBitsTranslucent: factor]. self primitiveFailed "Later do nicer error recovery -- share copyBits recovery"! ! !BitBlt methodsFor: 'copying' stamp: 'ar 5/14/2001 23:32'! copyForm: srcForm to: destPt rule: rule ^ self copyForm: srcForm to: destPt rule: rule colorMap: (srcForm colormapIfNeededFor: destForm)! ! !BitBlt methodsFor: 'copying' stamp: 'lr 7/4/2009 10:42'! copyForm: srcForm to: destPt rule: rule color: color sourceForm := srcForm. halftoneForm := color. combinationRule := rule. destX := destPt x + sourceForm offset x. destY := destPt y + sourceForm offset y. sourceX := 0. sourceY := 0. width := sourceForm width. height := sourceForm height. self copyBits! ! !BitBlt methodsFor: 'copying' stamp: 'lr 7/4/2009 10:42'! copyForm: srcForm to: destPt rule: rule colorMap: map sourceForm := srcForm. halftoneForm := nil. combinationRule := rule. destX := destPt x + sourceForm offset x. destY := destPt y + sourceForm offset y. sourceX := 0. sourceY := 0. width := sourceForm width. height := sourceForm height. colorMap := map. self copyBits! ! !BitBlt methodsFor: 'copying' stamp: 'lr 7/4/2009 10:42'! copyForm: srcForm to: destPt rule: rule fillColor: color sourceForm := srcForm. self fillColor: color. "sets halftoneForm" combinationRule := rule. destX := destPt x + sourceForm offset x. destY := destPt y + sourceForm offset y. sourceX := 0. sourceY := 0. width := sourceForm width. height := sourceForm height. self copyBits! ! !BitBlt methodsFor: 'copying' stamp: 'lr 7/4/2009 10:42'! copyFrom: sourceRectangle in: srcForm to: destPt | sourceOrigin | sourceForm := srcForm. halftoneForm := nil. combinationRule := 3. "store" destX := destPt x. destY := destPt y. sourceOrigin := sourceRectangle origin. sourceX := sourceOrigin x. sourceY := sourceOrigin y. width := sourceRectangle width. height := sourceRectangle height. colorMap := srcForm colormapIfNeededFor: destForm. self copyBits! ! !BitBlt methodsFor: 'copying' stamp: 'JuanVuletich 8/22/2009 23:39'! displayString: aString from: startIndex to: stopIndex at: aPoint strikeFont: font kern: kernDelta "If required, do a second pass with new rule and colorMap. This happens when #installStrikeFont:foregroundColor:backgroundColor: sets rule 37 (rgbMul). the desired effect is to do two bitblt calls. The first one is with rule 37 and special colormap. The second one is rule 34, with a colormap for applying the requested foreground color. This two together do component alpha blending, i.e. alpha blend red, green and blue separatedly. This is needed for arbitrary color over abitrary background text with subpixel AA." | answer prevRule secondPassMap | "If combinationRule is rgbMul, we might need the special two-pass technique for component alpha blending. If not, do it simply" combinationRule = 37 "rgbMul" ifFalse: [ ^self basicDisplayString: aString from: startIndex to: stopIndex at: aPoint strikeFont: font kern: kernDelta ]. "We need to do a second pass. The colormap set is for use in the second pass." secondPassMap := colorMap. colorMap := sourceForm depth ~= destForm depth ifTrue: [ self cachedFontColormapFrom: sourceForm depth to: destForm depth ]. answer := self basicDisplayString: aString from: startIndex to: stopIndex at: aPoint strikeFont: font kern: kernDelta. colorMap := secondPassMap. secondPassMap ifNotNil: [ prevRule := combinationRule. combinationRule := 20. "rgbAdd" self basicDisplayString: aString from: startIndex to: stopIndex at: aPoint strikeFont: font kern: kernDelta. combinationRule := prevRule ]. ^answer! ! !BitBlt methodsFor: 'copying' stamp: 'lr 7/4/2009 10:42'! fill: destRect fillColor: grayForm rule: rule "Fill with a Color, not a Form. 6/18/96 tk" sourceForm := nil. self fillColor: grayForm. "sets halftoneForm" combinationRule := rule. destX := destRect left. destY := destRect top. sourceX := 0. sourceY := 0. width := destRect width. height := destRect height. self copyBits! ! !BitBlt methodsFor: 'copying' stamp: 'lr 7/4/2009 10:42'! pixelAt: aPoint "Assumes this BitBlt has been set up specially (see the init message, BitBlt bitPeekerFromForm:. Returns the pixel at aPoint." sourceX := aPoint x. sourceY := aPoint y. destForm unhibernate. "before poking" destForm bits at: 1 put: 0. "Just to be sure" self copyBits. ^ destForm bits at: 1! ! !BitBlt methodsFor: 'copying' stamp: 'lr 7/4/2009 10:42'! pixelAt: aPoint put: pixelValue "Assumes this BitBlt has been set up specially (see the init message, BitBlt bitPokerToForm:. Overwrites the pixel at aPoint." destX := aPoint x. destY := aPoint y. sourceForm unhibernate. "before poking" sourceForm bits at: 1 put: pixelValue. self copyBits " | bb | bb _ (BitBlt bitPokerToForm: Display). [Sensor anyButtonPressed] whileFalse: [bb pixelAt: Sensor cursorPoint put: 55] "! ! !BitBlt methodsFor: 'line drawing'! drawFrom: startPoint to: stopPoint ^ self drawFrom: startPoint to: stopPoint withFirstPoint: true! ! !BitBlt methodsFor: 'line drawing' stamp: 'lr 7/4/2009 10:42'! drawFrom: startPoint to: stopPoint withFirstPoint: drawFirstPoint "Draw a line whose end points are startPoint and stopPoint. The line is formed by repeatedly calling copyBits at every point along the line. If drawFirstPoint is false, then omit the first point so as not to overstrike at line junctions." "Always draw down, or at least left-to-right" | offset point1 point2 forwards | forwards := (startPoint y = stopPoint y and: [ startPoint x < stopPoint x ]) or: [ startPoint y < stopPoint y ]. forwards ifTrue: [ point1 := startPoint. point2 := stopPoint ] ifFalse: [ point1 := stopPoint. point2 := startPoint ]. sourceForm == nil ifTrue: [ destX := point1 x. destY := point1 y ] ifFalse: [ width := sourceForm width. height := sourceForm height. offset := sourceForm offset. destX := (point1 x + offset x) rounded. destY := (point1 y + offset y) rounded ]. "Note that if not forwards, then the first point is the last and vice versa. We agree to always paint stopPoint, and to optionally paint startPoint." (drawFirstPoint or: [ forwards == false "ie this is stopPoint" ]) ifTrue: [ self copyBits ]. self drawLoopX: (point2 x - point1 x) rounded Y: (point2 y - point1 y) rounded. (drawFirstPoint or: [ "ie this is stopPoint" forwards ]) ifTrue: [ self copyBits ]! ! !BitBlt methodsFor: 'line drawing' stamp: 'lr 7/4/2009 10:42'! drawLoopX: xDelta Y: yDelta "Primitive. Implements the Bresenham plotting algorithm (IBM Systems Journal, Vol. 4 No. 1, 1965). It chooses a principal direction, and maintains a potential, P. When P's sign changes, it is time to move in the minor direction as well. This particular version does not write the first and last points, so that these can be called for as needed in client code. Optional. See Object documentation whatIsAPrimitive." | dx dy px py P | dx := xDelta sign. dy := yDelta sign. px := yDelta abs. py := xDelta abs. "self copyBits." py > px ifTrue: [ "more horizontal" P := py // 2. 1 to: py do: [ :i | destX := destX + dx. (P := P - px) < 0 ifTrue: [ destY := destY + dy. P := P + py ]. i < py ifTrue: [ self copyBits ] ] ] ifFalse: [ "more vertical" P := px // 2. 1 to: px do: [ :i | destY := destY + dy. (P := P - py) < 0 ifTrue: [ destX := destX + dx. P := P + px ]. i < px ifTrue: [ self copyBits ] ] ]! ! !BitBlt methodsFor: 'text display' stamp: 'ar 10/24/2005 21:49'! displayString: aString from: startIndex to: stopIndex at: aPoint kern: kernDelta baselineY: baselineY font: aFont "Double dispatch into the font. This method is present so that other-than-bitblt entities can be used by CharacterScanner and friends to display text." ^ aFont displayString: aString on: self from: startIndex to: stopIndex at: aPoint kern: kernDelta baselineY: baselineY! ! !BitBlt methodsFor: 'text display' stamp: 'ar 10/25/2005 01:12'! displayString: aString from: startIndex to: stopIndex at: aPoint kern: kernDelta font: aFont "Double dispatch into the font. This method is present so that other-than-bitblt entities can be used by CharacterScanner and friends to display text." ^ aFont displayString: aString on: self from: startIndex to: stopIndex at: aPoint kern: kernDelta! ! !BitBlt methodsFor: 'text display' stamp: 'ar 10/24/2005 21:48'! installFont: aFont foregroundColor: foregroundColor backgroundColor: backgroundColor "Double dispatch into the font. This method is present so that other-than-bitblt entities can be used by CharacterScanner and friends to display text." ^aFont installOn: self foregroundColor: foregroundColor backgroundColor: backgroundColor! ! !BitBlt methodsFor: 'private' stamp: 'lr 7/4/2009 10:42'! cachedFontColormapFrom: sourceDepth to: destDepth "Modified from computeColormapFrom:to:." | srcIndex map | CachedFontColorMaps class == Array ifFalse: [ CachedFontColorMaps := (1 to: 9) collect: [ :i | Array new: 32 ] ]. srcIndex := sourceDepth. sourceDepth > 8 ifTrue: [ srcIndex := 9 ]. (map := (CachedFontColorMaps at: srcIndex) at: destDepth) ~~ nil ifTrue: [ ^ map ]. map := (Color cachedColormapFrom: sourceDepth to: destDepth) copy. (CachedFontColorMaps at: srcIndex) at: destDepth put: map. ^ map! ! !BitBlt methodsFor: 'private' stamp: 'lr 7/4/2009 10:42'! clipRange "clip and adjust source origin and extent appropriately" "first in x" "fill in the lazy state if needed" | sx sy dx dy bbW bbH | destX ifNil: [ destX := 0 ]. destY ifNil: [ destY := 0 ]. width ifNil: [ width := destForm width ]. height ifNil: [ height := destForm height ]. sourceX ifNil: [ sourceX := 0 ]. sourceY ifNil: [ sourceY := 0 ]. clipX ifNil: [ clipX := 0 ]. clipY ifNil: [ clipY := 0 ]. clipWidth ifNil: [ clipWidth := destForm width ]. clipHeight ifNil: [ clipHeight := destForm height ]. destX >= clipX ifTrue: [ sx := sourceX. dx := destX. bbW := width ] ifFalse: [ sx := sourceX + (clipX - destX). bbW := width - (clipX - destX). dx := clipX ]. dx + bbW > (clipX + clipWidth) ifTrue: [ bbW := bbW - (dx + bbW - (clipX + clipWidth)) ]. "then in y" destY >= clipY ifTrue: [ sy := sourceY. dy := destY. bbH := height ] ifFalse: [ sy := sourceY + clipY - destY. bbH := height - (clipY - destY). dy := clipY ]. dy + bbH > (clipY + clipHeight) ifTrue: [ bbH := bbH - (dy + bbH - (clipY + clipHeight)) ]. sourceForm ifNotNil: [ sx < 0 ifTrue: [ dx := dx - sx. bbW := bbW + sx. sx := 0 ]. sx + bbW > sourceForm width ifTrue: [ bbW := bbW - (sx + bbW - sourceForm width) ]. sy < 0 ifTrue: [ dy := dy - sy. bbH := bbH + sy. sy := 0 ]. sy + bbH > sourceForm height ifTrue: [ bbH := bbH - (sy + bbH - sourceForm height) ] ]. (bbW <= 0 or: [ bbH <= 0 ]) ifTrue: [ sourceX := sourceY := destX := destY := clipX := clipY := width := height := 0. ^ true ]. (sx = sourceX and: [ sy = sourceY and: [ dx = destX and: [ dy = destY and: [ bbW = width and: [ bbH = height ] ] ] ] ]) ifTrue: [ ^ false ]. sourceX := sx. sourceY := sy. destX := dx. destY := dy. width := bbW. height := bbH. ^ true! ! !BitBlt methodsFor: 'private' stamp: 'StephaneDucasse 10/17/2009 17:15'! colorConvertingMap: targetColor from: sourceDepth to: destDepth keepSubPixelAA: keepSubPix | srcIndex map mapsForSource mapsForSourceAndDest | ColorConvertingMaps class == Array ifFalse: [ ColorConvertingMaps := (1 to: 10) collect: [ :i | Array new: 32 ] ]. srcIndex := sourceDepth. sourceDepth > 8 ifTrue: [ srcIndex := keepSubPix ifTrue: [ 9 ] ifFalse: [ 10 ] ]. mapsForSource := ColorConvertingMaps at: srcIndex. (mapsForSourceAndDest := mapsForSource at: destDepth) isNil ifTrue: [ mapsForSourceAndDest := mapsForSource at: destDepth put: Dictionary new ]. map := mapsForSourceAndDest at: targetColor ifAbsentPut: [ Color computeColorConvertingMap: targetColor from: sourceDepth to: destDepth keepSubPixelAA: keepSubPix ]. ^ map! ! !BitBlt methodsFor: 'private' stamp: 'ar 2/2/2001 15:09'! copyBitsAgain "Primitive. See BitBlt|copyBits, also a Primitive. Essential. See Object documentation whatIsAPrimitive." self primitiveFailed! ! !BitBlt methodsFor: 'private' stamp: 'lr 7/4/2009 10:42'! copyBitsFrom: x0 to: x1 at: y destX := x0. destY := y. sourceX := x0. width := x1 - x0. self copyBits! ! !BitBlt methodsFor: 'private' stamp: 'lr 7/4/2009 10:42'! eraseBits "Perform the erase operation, which puts 0's in the destination wherever the source (which is assumed to be just 1 bit deep) has a 1. This requires the colorMap to be set in order to AND all 1's into the destFrom pixels regardless of their size." | oldMask oldMap | oldMask := halftoneForm. halftoneForm := nil. oldMap := colorMap. self colorMap: (Bitmap with: 0 with: 4294967295). combinationRule := Form erase. self copyBits. "Erase the dest wherever the source is 1" halftoneForm := oldMask. "already converted to a Bitmap" colorMap := oldMap! ! !BitBlt methodsFor: 'private' stamp: 'ar 5/26/2000 16:38'! getPluginName "Private. Return the name of the plugin representing BitBlt. Used for dynamically switching between different BB representations only." ^'BitBltPlugin'! ! !BitBlt methodsFor: 'private' stamp: 'jmv 9/7/2009 09:27'! installStrikeFont: aStrikeFont foregroundColor: foregroundColor backgroundColor: backgroundColor | lastSourceDepth targetColor | sourceForm ifNotNil:[lastSourceDepth := sourceForm depth]. sourceForm := aStrikeFont glyphs. "Ignore any halftone pattern since we use a color map approach here" halftoneForm := nil. sourceY := 0. height := aStrikeFont height. sourceForm depth = 1 ifTrue: [ self combinationRule: Form paint. (colorMap notNil and:[lastSourceDepth = sourceForm depth]) ifFalse: [ "Set up color map for a different source depth (color font)" "Uses caching for reasonable efficiency" colorMap := self cachedFontColormapFrom: sourceForm depth to: destForm depth. colorMap at: 1 put: (destForm pixelValueFor: backgroundColor)]. colorMap at: 2 put: (destForm pixelValueFor: foregroundColor). ] ifFalse: [ (Preferences subPixelRenderFonts and: [ foregroundColor = Color black or: [ Preferences subPixelRenderColorFonts ]]) ifTrue: [ destForm depth > 8 ifTrue: [ "rgbMul is equivalent to component alpha blend if text is black (only faster, hehe)" self combinationRule: 37. "RGBMul" colorMap := (destForm depth = 32 or: [ (foregroundColor = Color black) not ]) ifTrue: [ "rgbMul / rgbAdd IS component alpha blend for any color of text (neat trick, eh!!)" "This colorMap is to be used on the second pass with rule 20 (rgbAdd) See #displayString:from:to:at:strikeFont:kern:" "Note: In 32bpp we always need the second pass, as the source could have transparent pixels, and we need to add to the alpha channel" self colorConvertingMap: foregroundColor from: sourceForm depth to: destForm depth keepSubPixelAA: true]] ifFalse: [ self combinationRule: 25. "Paint" targetColor := foregroundColor = Color black ifFalse: [ foregroundColor ]. colorMap := self colorConvertingMap: targetColor from: sourceForm depth to: destForm depth keepSubPixelAA: true] ] ifFalse: [ "Do not use rule 34 for 16bpp display. TTCFont uses it, but it builds a glyphs cache for each color used!!" self combinationRule: (destForm depth = 32 ifTrue: [34 "alphaBlendScaled"] ifFalse: [25 "Paint"]). colorMap := self colorConvertingMap: foregroundColor from: sourceForm depth to: destForm depth keepSubPixelAA: false ] ].! ! !BitBlt methodsFor: 'private' stamp: 'lr 7/4/2009 10:42'! installTTCFont: aTTCFont foregroundColor: foregroundColor backgroundColor: backgroundColor "Set up the parameters. Since the glyphs in a TTCFont is 32bit depth form, it tries to use rule=34 to get better AA result if possible." aTTCFont depth = 32 ifTrue: [ destForm depth <= 8 ifTrue: [ self colorMap: (self cachedFontColormapFrom: aTTCFont depth to: destForm depth). self combinationRule: Form paint ] ifFalse: [ self colorMap: nil. self combinationRule: 34 ]. halftoneForm := nil. sourceY := 0. height := aTTCFont height ]! ! !BitBlt methodsFor: 'private' stamp: 'lr 7/4/2009 10:42'! paintBits "Perform the paint operation, which requires two calls to BitBlt." | color oldMap saveRule | sourceForm depth = 1 ifFalse: [ ^ self halt: 'paint operation is only defined for 1-bit deep sourceForms' ]. saveRule := combinationRule. color := halftoneForm. halftoneForm := nil. oldMap := colorMap. "Map 1's to ALL ones, not just one" self colorMap: (Bitmap with: 0 with: 4294967295). combinationRule := Form erase. self copyBits. "Erase the dest wherever the source is 1" halftoneForm := color. combinationRule := Form under. self copyBits. "then OR, with whatever color, into the hole" colorMap := oldMap. combinationRule := saveRule " | dot | dot _ Form dotOfSize: 32. ((BitBlt destForm: Display sourceForm: dot fillColor: Color lightGray combinationRule: Form paint destOrigin: Sensor cursorPoint sourceOrigin: 0@0 extent: dot extent clipRect: Display boundingBox) colorMap: (Bitmap with: 0 with: 16rFFFFFFFF)) copyBits"! ! !BitBlt methodsFor: 'private' stamp: 'lr 7/4/2009 10:42'! primDisplayString: aString from: startIndex to: stopIndex map: glyphMap xTable: xTable kern: kernDelta | ascii | startIndex to: stopIndex do: [ :charIndex | ascii := (aString at: charIndex) asciiValue. sourceX := xTable at: ascii + 1. width := (xTable at: ascii + 2) - sourceX. self copyBits. destX := destX + width + kernDelta ]! ! !BitBlt methodsFor: 'private' stamp: 'lr 7/4/2009 10:42'! roundVariables | maxVal minVal | maxVal := SmallInteger maxVal. minVal := SmallInteger minVal. destX := destX asInteger min: maxVal max: minVal. destY := destY asInteger min: maxVal max: minVal. width := width asInteger min: maxVal max: minVal. height := height asInteger min: maxVal max: minVal. sourceX := sourceX asInteger min: maxVal max: minVal. sourceY := sourceY asInteger min: maxVal max: minVal. clipX := clipX asInteger min: maxVal max: minVal. clipY := clipY asInteger min: maxVal max: minVal. clipWidth := clipWidth asInteger min: maxVal max: minVal. clipHeight := clipHeight asInteger min: maxVal max: minVal! ! !BitBlt methodsFor: 'private' stamp: 'lr 7/4/2009 10:42'! setDestForm: df | bb | bb := df boundingBox. destForm := df. clipX := bb left. clipY := bb top. clipWidth := bb width. clipHeight := bb height! ! !BitBlt methodsFor: 'private' stamp: 'lr 7/4/2009 10:42'! setDestForm: df sourceForm: sf fillColor: hf combinationRule: cr destOrigin: destOrigin sourceOrigin: sourceOrigin extent: extent clipRect: clipRect | aPoint | destForm := df. sourceForm := sf. self fillColor: hf. "sets halftoneForm" combinationRule := cr. destX := destOrigin x. destY := destOrigin y. sourceX := sourceOrigin x. sourceY := sourceOrigin y. width := extent x. height := extent y. aPoint := clipRect origin. clipX := aPoint x. clipY := aPoint y. aPoint := clipRect corner. clipWidth := aPoint x - clipX. clipHeight := aPoint y - clipY. sourceForm == nil ifFalse: [ colorMap := sourceForm colormapIfNeededFor: destForm ]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! BitBlt class instanceVariableNames: ''! !BitBlt class methodsFor: 'benchmarks' stamp: 'PeterHugossonMiller 9/3/2009 00:12'! benchDiffsFrom: before to: afterwards "Given two outputs of BitBlt>>benchmark show the relative improvements." | old new log oldLine newLine oldVal newVal improvement | log := String new writeStream. old := before readStream. new := afterwards readStream. [ old atEnd or: [ new atEnd ] ] whileFalse: [ oldLine := old upTo: Character cr. newLine := new upTo: Character cr. (oldLine includes: Character tab) ifTrue: [ oldLine := oldLine readStream. newLine := newLine readStream. Transcript cr; show: (oldLine upTo: Character tab); tab. log cr; nextPutAll: (newLine upTo: Character tab); tab. [ oldLine skipSeparators. newLine skipSeparators. oldLine atEnd ] whileFalse: [ oldVal := Integer readFrom: oldLine. newVal := Integer readFrom: newLine. improvement := oldVal asFloat / newVal asFloat roundTo: 0.01. Transcript show: improvement printString; tab; tab. log print: improvement; tab; tab ] ] ifFalse: [ Transcript cr; show: oldLine. log cr; nextPutAll: oldLine ] ]. ^ log contents! ! !BitBlt class methodsFor: 'benchmarks' stamp: 'PeterHugossonMiller 9/3/2009 00:13'! benchmark "BitBlt benchmark" "Run a benchmark on different combinations rules, source/destination depths and BitBlt modes. Note: This benchmark doesn't give you any 'absolute' value - it is intended only for benchmarking improvements in the bitblt code and nothing else. Attention: *this*may*take*a*while*" | bb source dest destRect log t | log := String new writeStream. destRect := 0 @ 0 extent: 600 @ 600. "Form paint/Form over - the most common rules" #(25 3 ) do: [ :rule | Transcript cr; show: '---- Combination rule: ' , rule printString , ' ----'. log cr; nextPutAll: '---- Combination rule: ' , rule printString , ' ----'. #(1 2 4 8 16 32 ) do: [ :destDepth | dest := nil. dest := Form extent: destRect extent depth: destDepth. Transcript cr. log cr. #(1 2 4 8 16 32 ) do: [ :sourceDepth | Transcript cr; show: sourceDepth printString , ' => ' , destDepth printString. log cr; nextPutAll: sourceDepth printString , ' => ' , destDepth printString. source := nil. bb := nil. source := Form extent: destRect extent depth: sourceDepth. source getCanvas fillOval: dest boundingBox color: Color yellow borderWidth: 30 borderColor: Color black. bb := WarpBlt toForm: dest. bb sourceForm: source. bb sourceRect: source boundingBox. bb destRect: dest boundingBox. bb colorMap: (source colormapIfNeededFor: dest). bb combinationRule: rule. "Measure speed of copyBits" t := Time millisecondsToRun: [ bb copyBits ]. Transcript tab; show: t printString. log tab; nextPutAll: t printString. bb sourceForm: source destRect: source boundingBox. "Measure speed of 1x1 warpBits" bb cellSize: 1. t := Time millisecondsToRun: [ bb warpBits ]. Transcript tab; show: t printString. log tab; nextPutAll: t printString. "Measure speed of 2x2 warpBits" bb cellSize: 2. t := Time millisecondsToRun: [ bb warpBits ]. Transcript tab; show: t printString. log tab; nextPutAll: t printString. "Measure speed of 3x3 warpBits" bb cellSize: 3. t := Time millisecondsToRun: [ bb warpBits ]. Transcript tab; show: t printString. log tab; nextPutAll: t printString ] ] ]. ^ log contents! ! !BitBlt class methodsFor: 'benchmarks' stamp: 'PeterHugossonMiller 9/3/2009 00:14'! benchmark2 "BitBlt benchmark" "Run a benchmark on different combinations rules, source/destination depths and BitBlt modes. Note: This benchmark doesn't give you any 'absolute' value - it is intended only for benchmarking improvements in the bitblt code and nothing else. Attention: *this*may*take*a*while*" | bb source dest destRect log t | log := String new writeStream. destRect := 0 @ 0 extent: 600 @ 600. "Form paint/Form over - the most common rules" #(25 3 ) do: [ :rule | Transcript cr; show: '---- Combination rule: ' , rule printString , ' ----'. log cr; nextPutAll: '---- Combination rule: ' , rule printString , ' ----'. #(1 2 4 8 16 32 ) do: [ :destDepth | dest := nil. dest := Form extent: destRect extent depth: destDepth. Transcript cr. log cr. #(1 2 4 8 16 32 ) do: [ :sourceDepth | Transcript cr; show: sourceDepth printString , ' => ' , destDepth printString. log cr; nextPutAll: sourceDepth printString , ' => ' , destDepth printString. source := nil. bb := nil. source := Form extent: destRect extent depth: sourceDepth. source getCanvas fillOval: dest boundingBox color: Color yellow borderWidth: 30 borderColor: Color black. bb := WarpBlt toForm: dest. bb sourceForm: source. bb sourceRect: source boundingBox. bb destRect: dest boundingBox. bb colorMap: (source colormapIfNeededFor: dest). bb combinationRule: rule. "Measure speed of copyBits" t := Time millisecondsToRun: [ 1 to: 10 do: [ :i | bb copyBits ] ]. Transcript tab; show: t printString. log tab; nextPutAll: t printString. bb sourceForm: source destRect: source boundingBox. "Measure speed of 1x1 warpBits" bb cellSize: 1. t := Time millisecondsToRun: [ 1 to: 4 do: [ :i | bb warpBits ] ]. Transcript tab; show: t printString. log tab; nextPutAll: t printString. "Measure speed of 2x2 warpBits" bb cellSize: 2. t := Time millisecondsToRun: [ bb warpBits ]. Transcript tab; show: t printString. log tab; nextPutAll: t printString. "Measure speed of 3x3 warpBits" bb cellSize: 3. t := Time millisecondsToRun: [ bb warpBits ]. Transcript tab; show: t printString. log tab; nextPutAll: t printString ] ] ]. ^ log contents! ! !BitBlt class methodsFor: 'benchmarks' stamp: 'PeterHugossonMiller 9/3/2009 00:14'! benchmark3 "BitBlt benchmark" "Run a benchmark on different combinations rules, source/destination depths and BitBlt modes. Note: This benchmark doesn't give you any 'absolute' value - it is intended only for benchmarking improvements in the bitblt code and nothing else. Attention: *this*may*take*a*while*" | bb source dest destRect log t | log := String new writeStream. destRect := 0 @ 0 extent: 600 @ 600. "Form paint/Form over - the most common rules" #(25 3 ) do: [ :rule | Transcript cr; show: '---- Combination rule: ' , rule printString , ' ----'. log cr; nextPutAll: '---- Combination rule: ' , rule printString , ' ----'. #(1 2 4 8 16 32 ) do: [ :destDepth | dest := nil. dest := Form extent: destRect extent depth: destDepth. Transcript cr. log cr. #(1 2 4 8 16 32 ) do: [ :sourceDepth | Transcript cr; show: sourceDepth printString , ' => ' , destDepth printString. log cr; nextPutAll: sourceDepth printString , ' => ' , destDepth printString. source := nil. bb := nil. source := Form extent: destRect extent depth: sourceDepth. source getCanvas fillOval: dest boundingBox color: Color yellow borderWidth: 30 borderColor: Color black. bb := WarpBlt toForm: dest. bb sourceForm: source. bb sourceRect: source boundingBox. bb destRect: dest boundingBox. bb colorMap: (source colormapIfNeededFor: dest). bb combinationRule: rule. "Measure speed of copyBits" t := Time millisecondsToRun: [ 1 to: 10 do: [ :i | bb copyBits ] ]. Transcript tab; show: t printString. log tab; nextPutAll: t printString. bb sourceForm: source destRect: source boundingBox. "Measure speed of 1x1 warpBits" bb cellSize: 1. t := Time millisecondsToRun: [ 1 to: 4 do: [ :i | bb warpBits ] ]. Transcript tab; show: t printString. log tab; nextPutAll: t printString. "Measure speed of 2x2 warpBits" bb cellSize: 2. t := Time millisecondsToRun: [ bb warpBits ]. Transcript tab; show: t printString. log tab; nextPutAll: t printString. "Measure speed of 3x3 warpBits" bb cellSize: 3. t := Time millisecondsToRun: [ bb warpBits ]. Transcript tab; show: t printString. log tab; nextPutAll: t printString ] ] ]. ^ log contents! ! !BitBlt class methodsFor: 'examples' stamp: 'lr 7/4/2009 10:42'! alphaBlendDemo "To run this demo, use... Display restoreAfter: [BitBlt alphaBlendDemo] Displays 10 alphas, then lets you paint. Option-Click to stop painting." "This code exhibits alpha blending in any display depth by performing the blend in an off-screen buffer with 32-bit pixels, and then copying the result back onto the screen with an appropriate color map. - tk 3/10/97" "This version uses a sliding buffer for painting that keeps pixels in 32 bits as long as they are in the buffer, so as not to lose info by converting down to display resolution and back up to 32 bits at each operation. - di 3/15/97" "compute color maps if needed" | brush buff dispToBuff buffToDisplay mapDto32 map32toD prevP p brushToBuff theta buffRect buffSize buffToBuff brushRect delta newBuffRect updateRect | Display depth <= 8 ifTrue: [ mapDto32 := Color cachedColormapFrom: Display depth to: 32. map32toD := Color cachedColormapFrom: 32 to: Display depth ]. "display 10 different alphas, across top of screen" buff := Form extent: 500 @ 50 depth: 32. dispToBuff := BitBlt toForm: buff. dispToBuff colorMap: mapDto32. dispToBuff copyFrom: (50 @ 10 extent: 500 @ 50) in: Display to: 0 @ 0. 1 to: 10 do: [ :i | dispToBuff fill: ((50 * (i - 1)) @ 0 extent: 50 @ 50) fillColor: (Color red alpha: i / 10) rule: Form blend ]. buffToDisplay := BitBlt toForm: Display. buffToDisplay colorMap: map32toD. buffToDisplay copyFrom: buff boundingBox in: buff to: 50 @ 10. "Create a brush with radially varying alpha" brush := Form extent: 30 @ 30 depth: 32. 1 to: 5 do: [ :i | brush fillShape: (Form dotOfSize: brush width * (6 - i) // 5) fillColor: (Color red alpha: 0.02 * i - 0.01) at: brush extent // 2 ]. "Now paint with the brush using alpha blending." buffSize := 100. buff := Form extent: brush extent + buffSize depth: 32. "Travelling 32-bit buffer" dispToBuff := BitBlt toForm: buff. "This is from Display to buff" dispToBuff colorMap: mapDto32. brushToBuff := BitBlt toForm: buff. "This is from brush to buff" brushToBuff sourceForm: brush; sourceOrigin: 0 @ 0. brushToBuff combinationRule: Form blend. buffToBuff := BitBlt toForm: buff. "This is for slewing the buffer" [ Sensor yellowButtonPressed ] whileFalse: [ prevP := nil. buffRect := Sensor cursorPoint - (buffSize // 2) extent: buff extent. dispToBuff copyFrom: buffRect in: Display to: 0 @ 0. [ Sensor redButtonPressed ] whileTrue: [ "Here is the painting loop" p := Sensor cursorPoint - (brush extent // 2). (prevP == nil or: [ prevP ~= p ]) ifTrue: [ prevP == nil ifTrue: [ prevP := p ]. (p dist: prevP) > buffSize ifTrue: [ "Stroke too long to fit in buffer -- clip to buffer, and next time through will do more of it" theta := (p - prevP) theta. p := (theta cos @ theta sin * buffSize asFloat + prevP) truncated ]. brushRect := p extent: brush extent. (buffRect containsRect: brushRect) ifFalse: [ "Brush is out of buffer region. Scroll the buffer, and fill vacated regions from the display" delta := brushRect amountToTranslateWithin: buffRect. buffToBuff copyFrom: buff boundingBox in: buff to: delta. newBuffRect := buffRect translateBy: delta negated. (newBuffRect areasOutside: buffRect) do: [ :r | dispToBuff copyFrom: r in: Display to: r origin - newBuffRect origin ]. buffRect := newBuffRect ]. "Interpolate from prevP to p..." brushToBuff drawFrom: prevP - buffRect origin to: p - buffRect origin withFirstPoint: false. "Update (only) the altered pixels of the destination" updateRect := (p min: prevP) corner: (p max: prevP) + brush extent. buffToDisplay copy: updateRect from: updateRect origin - buffRect origin in: buff. prevP := p ] ] ]! ! !BitBlt class methodsFor: 'examples' stamp: 'lr 7/4/2009 10:42'! antiAliasDemo "To run this demo, use... Display restoreAfter: [BitBlt antiAliasDemo] Goes immediately into on-screen paint mode. Option-Click to stop painting." "This code exhibits alpha blending in any display depth by performing the blend in an off-screen buffer with 32-bit pixels, and then copying the result back onto the screen with an appropriate color map. - tk 3/10/97" "This version uses a sliding buffer for painting that keeps pixels in 32 bits as long as they are in the buffer, so as not to lose info by converting down to display resolution and back up to 32 bits at each operation. - di 3/15/97" "This version also uses WarpBlt to paint into twice as large a buffer, and then use smoothing when reducing back down to the display. In fact this same routine will now work for 3x3 soothing as well. Remove the statements 'buff displayAt: 0@0' to hide the buffer. - di 3/19/97" "compute color maps if needed" | brush buff dispToBuff buffToDisplay mapDto32 map32toD prevP p brushToBuff theta buffRect buffSize buffToBuff brushRect delta newBuffRect updateRect scale p0 | Display depth <= 8 ifTrue: [ mapDto32 := Color cachedColormapFrom: Display depth to: 32. map32toD := Color cachedColormapFrom: 32 to: Display depth ]. "Create a brush with radially varying alpha" brush := Form extent: 3 @ 3 depth: 32. brush fill: brush boundingBox fillColor: (Color red alpha: 0.05). brush fill: (1 @ 1 extent: 1 @ 1) fillColor: (Color red alpha: 0.2). scale := 2. "Actual drawing happens at this magnification" "Scale brush up for painting in magnified buffer" brush := brush magnify: brush boundingBox by: scale. "Now paint with the brush using alpha blending." buffSize := 100. buff := Form extent: (brush extent + buffSize) * scale depth: 32. "Travelling 32-bit buffer" dispToBuff := (WarpBlt toForm: buff) sourceForm: Display; colorMap: mapDto32; combinationRule: Form over. "From Display to buff - magnify by 2" brushToBuff := (BitBlt toForm: buff) sourceForm: brush; sourceOrigin: 0 @ 0; combinationRule: Form blend. "From brush to buff" buffToDisplay := (WarpBlt toForm: Display) sourceForm: buff; colorMap: map32toD; cellSize: scale; combinationRule: Form over. "From buff to Display - shrink by 2" "...and use smoothing" buffToBuff := BitBlt toForm: buff. "This is for slewing the buffer" [ Sensor yellowButtonPressed ] whileFalse: [ prevP := nil. buffRect := Sensor cursorPoint - (buff extent // scale // 2) extent: buff extent // scale. p0 := buff extent // 2 - (buffRect extent // 2). dispToBuff copyQuad: buffRect innerCorners toRect: buff boundingBox. buff displayAt: 0 @ 0. "** remove to hide sliding buffer **" [ Sensor redButtonPressed ] whileTrue: [ "Here is the painting loop" p := Sensor cursorPoint - buffRect origin + p0. "p, prevP are rel to buff origin" (prevP == nil or: [ prevP ~= p ]) ifTrue: [ prevP == nil ifTrue: [ prevP := p ]. (p dist: prevP) > (buffSize - 1) ifTrue: [ "Stroke too long to fit in buffer -- clip to buffer, and next time through will do more of it" theta := (p - prevP) theta. p := (theta cos @ theta sin * (buffSize - 2) asFloat + prevP) truncated ]. brushRect := p extent: brush extent. ((buff boundingBox insetBy: scale) containsRect: brushRect) ifFalse: [ "Brush is out of buffer region. Scroll the buffer, and fill vacated regions from the display" delta := (brushRect amountToTranslateWithin: (buff boundingBox insetBy: scale)) // scale. buffToBuff copyFrom: buff boundingBox in: buff to: delta * scale. newBuffRect := buffRect translateBy: delta negated. p := p translateBy: delta * scale. prevP := prevP translateBy: delta * scale. (newBuffRect areasOutside: buffRect) do: [ :r | dispToBuff copyQuad: r innerCorners toRect: ((r origin - newBuffRect origin) * scale extent: r extent * scale) ]. buffRect := newBuffRect ]. "Interpolate from prevP to p..." brushToBuff drawFrom: prevP to: p withFirstPoint: false. buff displayAt: 0 @ 0. "** remove to hide sliding buffer **" "Update (only) the altered pixels of the destination" updateRect := (p min: prevP) corner: (p max: prevP) + brush extent. updateRect := updateRect origin // scale * scale corner: (updateRect corner + scale) // scale * scale. buffToDisplay copyQuad: updateRect innerCorners toRect: (updateRect origin // scale + buffRect origin extent: updateRect extent // scale). prevP := p ] ] ]! ! !BitBlt class methodsFor: 'examples' stamp: 'lr 7/4/2009 10:42'! exampleColorMap "BitBlt exampleColorMap" "This example shows what one can do with the fixed part of a color map. The color map, as setup below, rotates the bits of a pixel all the way around. Thus you'll get a (sometime strange looking ;-) animation of colors which will end up exactly the way it looked at the beginning. The example is given to make you understand that the masks and shifts can be used for a lot more than simply color converting pixels. In this example, for instance, we use only two of the four independent shifters." | cc bb | cc := ColorMap masks: { (1 << (Display depth - 1)). "mask out high bit of color component" ((1 << (Display depth - 1)) - 1). "mask all other bits" 0. 0 } shifts: { (1 - Display depth). "shift right to bottom most position" 1. "shift all other pixels one bit left" 0. 0 }. bb := BitBlt toForm: Display. bb sourceForm: Display; combinationRule: 3; colorMap: cc. 1 to: Display depth do: [ :i | bb copyBits. Display forceDisplayUpdate ]! ! !BitBlt class methodsFor: 'examples' stamp: 'lr 7/4/2009 10:42'! exampleOne "This tests BitBlt by displaying the result of all sixteen combination rules that BitBlt is capable of using. (Please see the comment in BitBlt for the meaning of the combination rules). This only works at Display depth of 1. (Rule 15 does not work?)" | path displayDepth | displayDepth := Display depth. Display newDepth: 1. path := Path new. 0 to: 3 do: [ :i | 0 to: 3 do: [ :j | path add: (j * 100) @ (i * 75) ] ]. Display fillWhite. path := path translateBy: 60 @ 40. 1 to: 16 do: [ :index | BitBlt exampleAt: (path at: index) rule: index - 1 fillColor: nil ]. [ Sensor anyButtonPressed ] whileFalse: [ ]. Display newDepth: displayDepth "BitBlt exampleOne"! ! !BitBlt class methodsFor: 'examples' stamp: 'lr 7/4/2009 10:42'! exampleTwo "This is to test painting with a gray tone. It also tests that the seaming with gray patterns is correct in the microcode. Lets you paint for a while and then automatically stops. This only works at Depth of 1." "create a small black Form source as a brush. " | f aBitBlt displayDepth | displayDepth := Display depth. Display newDepth: 1. f := Form extent: 20 @ 20. f fillBlack. "create a BitBlt which will OR gray into the display. " aBitBlt := BitBlt destForm: Display sourceForm: f fillColor: Color gray combinationRule: Form over destOrigin: Sensor cursorPoint sourceOrigin: 0 @ 0 extent: f extent clipRect: Display computeBoundingBox. "paint the gray Form on the screen for a while. " [ Sensor anyButtonPressed ] whileFalse: [ aBitBlt destOrigin: Sensor cursorPoint. aBitBlt copyBits ]. Display newDepth: displayDepth "BitBlt exampleTwo"! ! !BitBlt class methodsFor: 'instance creation' stamp: 'ar 5/28/2000 12:04'! asGrafPort "Return the GrafPort associated with the receiver" ^GrafPort! ! !BitBlt class methodsFor: 'instance creation' stamp: 'lr 7/4/2009 10:42'! bitPeekerFromForm: sourceForm "Answer an instance to be used extract individual pixels from the given Form. The destination for a 1x1 copyBits will be the low order bits of (bits at: 1)." | pixPerWord | pixPerWord := 32 // sourceForm depth. sourceForm unhibernate. ^ self destForm: (Form extent: pixPerWord @ 1 depth: sourceForm depth) sourceForm: sourceForm halftoneForm: nil combinationRule: Form over destOrigin: (pixPerWord - 1) @ 0 sourceOrigin: 0 @ 0 extent: 1 @ 1 clipRect: (0 @ 0 extent: pixPerWord @ 1)! ! !BitBlt class methodsFor: 'instance creation' stamp: 'lr 7/4/2009 10:42'! bitPokerToForm: destForm "Answer an instance to be used for valueAt: aPoint put: pixValue. The source for a 1x1 copyBits will be the low order of (bits at: 1)" | pixPerWord | pixPerWord := 32 // destForm depth. destForm unhibernate. ^ self destForm: destForm sourceForm: (Form extent: pixPerWord @ 1 depth: destForm depth) halftoneForm: nil combinationRule: Form over destOrigin: 0 @ 0 sourceOrigin: (pixPerWord - 1) @ 0 extent: 1 @ 1 clipRect: (0 @ 0 extent: destForm extent)! ! !BitBlt class methodsFor: 'instance creation' stamp: 'ar 5/28/2000 12:00'! current "Return the class currently to be used for BitBlt" ^Display defaultBitBltClass! ! !BitBlt class methodsFor: 'instance creation'! destForm: df sourceForm: sf fillColor: hf combinationRule: cr destOrigin: destOrigin sourceOrigin: sourceOrigin extent: extent clipRect: clipRect "Answer an instance of me with values set according to the arguments." ^ self new setDestForm: df sourceForm: sf fillColor: hf combinationRule: cr destOrigin: destOrigin sourceOrigin: sourceOrigin extent: extent clipRect: clipRect! ! !BitBlt class methodsFor: 'instance creation'! destForm: df sourceForm: sf halftoneForm: hf combinationRule: cr destOrigin: destOrigin sourceOrigin: sourceOrigin extent: extent clipRect: clipRect "Answer an instance of me with values set according to the arguments." ^ self new setDestForm: df sourceForm: sf fillColor: hf combinationRule: cr destOrigin: destOrigin sourceOrigin: sourceOrigin extent: extent clipRect: clipRect! ! !BitBlt class methodsFor: 'instance creation'! toForm: aForm ^ self new setDestForm: aForm! ! !BitBlt class methodsFor: 'private' stamp: 'lr 7/4/2009 10:42'! exampleAt: originPoint rule: rule fillColor: mask "This builds a source and destination form and copies the source to the destination using the specifed rule and mask. It is called from the method named exampleOne. Only works with Display depth of 1" | s d border aBitBlt | border := Form extent: 32 @ 32. border fillBlack. border fill: (1 @ 1 extent: 30 @ 30) fillColor: Color white. s := Form extent: 32 @ 32. s fillWhite. s fillBlack: (7 @ 7 corner: 25 @ 25). d := Form extent: 32 @ 32. d fillWhite. d fillBlack: (0 @ 0 corner: 32 @ 16). s displayOn: Display at: originPoint. border displayOn: Display at: originPoint rule: Form under. d displayOn: Display at: originPoint + (s width @ 0). border displayOn: Display at: originPoint + (s width @ 0) rule: Form under. d displayOn: Display at: originPoint + (s extent // (2 @ 1)). aBitBlt := BitBlt destForm: Display sourceForm: s fillColor: mask combinationRule: rule destOrigin: originPoint + (s extent // (2 @ 1)) sourceOrigin: 0 @ 0 extent: s extent clipRect: Display computeBoundingBox. aBitBlt copyBits. border displayOn: Display at: originPoint + (s extent // (2 @ 1)) rule: Form under "BitBlt exampleAt: 100@100 rule: 0 fillColor: nil"! ! !BitBlt class methodsFor: 'private' stamp: 'StephaneDucasse 10/17/2009 17:15'! recreateColorMaps CachedFontColorMaps := ColorConvertingMaps := nil! ! !BitBlt class methodsFor: 'class initialization' stamp: 'jmv 9/7/2009 09:32'! initialize self recreateColorMaps! ! TestCase subclass: #BitBltClipBugs instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Tests-Bugs'! !BitBltClipBugs methodsFor: 'as yet unclassified' stamp: 'ar 3/8/2003 00:33'! testDrawingWayOutside | f1 bb f2 | f1 := Form extent: 100@100 depth: 1. f2 := Form extent: 100@100 depth: 1. bb := BitBlt toForm: f1. bb combinationRule: 3. bb sourceForm: f2. bb destOrigin: SmallInteger maxVal squared asPoint. bb width: 100; height: 100. self shouldnt:[bb copyBits] raise: Error. ! ! !BitBltClipBugs methodsFor: 'as yet unclassified' stamp: 'ar 3/8/2003 00:33'! testDrawingWayOutside2 | f1 bb f2 | f1 := Form extent: 100@100 depth: 1. f2 := Form extent: 100@100 depth: 1. bb := BitBlt toForm: f1. bb combinationRule: 3. bb sourceForm: f2. bb destOrigin: 0@0. bb width: SmallInteger maxVal squared; height: SmallInteger maxVal squared. self shouldnt:[bb copyBits] raise: Error.! ! !BitBltClipBugs methodsFor: 'as yet unclassified' stamp: 'ar 3/8/2003 00:33'! testDrawingWayOutside3 | f1 bb f2 | f1 := Form extent: 100@100 depth: 1. f2 := Form extent: 100@100 depth: 1. bb := BitBlt toForm: f1. bb combinationRule: 3. bb sourceForm: f2. bb destOrigin: SmallInteger maxVal squared asPoint. bb width: SmallInteger maxVal squared; height: SmallInteger maxVal squared. self shouldnt:[bb copyBits] raise: Error. ! ! !BitBltClipBugs methodsFor: 'as yet unclassified' stamp: 'ar 3/8/2003 00:34'! testDrawingWayOutside4 | f1 bb f2 | f1 := Form extent: 100@100 depth: 1. f2 := Form extent: 100@100 depth: 1. bb := BitBlt toForm: f1. bb combinationRule: 3. bb sourceForm: f2. bb destOrigin: SmallInteger maxVal squared asPoint. bb width: 100; height: 100. bb sourceOrigin: SmallInteger maxVal squared asPoint. self shouldnt:[bb copyBits] raise: Error. ! ! !BitBltClipBugs methodsFor: 'as yet unclassified' stamp: 'ar 3/8/2003 00:34'! testDrawingWayOutside5 | f1 bb f2 | f1 := Form extent: 100@100 depth: 1. f2 := Form extent: 100@100 depth: 1. bb := BitBlt toForm: f1. bb combinationRule: 3. bb sourceForm: f2. bb destOrigin: 0@0. bb width: SmallInteger maxVal squared; height: SmallInteger maxVal squared. bb sourceOrigin: SmallInteger maxVal squared asPoint. self shouldnt:[bb copyBits] raise: Error.! ! !BitBltClipBugs methodsFor: 'as yet unclassified' stamp: 'ar 3/8/2003 00:34'! testDrawingWayOutside6 | f1 bb f2 | f1 := Form extent: 100@100 depth: 1. f2 := Form extent: 100@100 depth: 1. bb := BitBlt toForm: f1. bb combinationRule: 3. bb sourceForm: f2. bb destOrigin: SmallInteger maxVal squared asPoint. bb width: SmallInteger maxVal squared; height: SmallInteger maxVal squared. bb sourceOrigin: SmallInteger maxVal squared asPoint. self shouldnt:[bb copyBits] raise: Error. ! ! !BitBltClipBugs methodsFor: 'as yet unclassified' stamp: 'ar 3/8/2003 00:32'! testFillingWayOutside | f1 bb | f1 := Form extent: 100@100 depth: 1. bb := BitBlt toForm: f1. bb combinationRule: 3. bb fillColor: Color black. bb destOrigin: SmallInteger maxVal squared asPoint. bb width: 100; height: 100. self shouldnt:[bb copyBits] raise: Error. ! ! !BitBltClipBugs methodsFor: 'as yet unclassified' stamp: 'ar 3/8/2003 00:32'! testFillingWayOutside2 | f1 bb | f1 := Form extent: 100@100 depth: 1. bb := BitBlt toForm: f1. bb combinationRule: 3. bb fillColor: Color black. bb destOrigin: 0@0. bb width: SmallInteger maxVal squared; height: SmallInteger maxVal squared. self shouldnt:[bb copyBits] raise: Error.! ! !BitBltClipBugs methodsFor: 'as yet unclassified' stamp: 'ar 3/8/2003 00:32'! testFillingWayOutside3 | f1 bb | f1 := Form extent: 100@100 depth: 1. bb := BitBlt toForm: f1. bb combinationRule: 3. bb fillColor: Color black. bb destOrigin: SmallInteger maxVal squared asPoint. bb width: SmallInteger maxVal squared; height: SmallInteger maxVal squared. self shouldnt:[bb copyBits] raise: Error. ! ! ClassTestCase subclass: #BitBltTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'GraphicsTests-Primitives'! !BitBltTest methodsFor: 'bugs' stamp: 'sd 6/5/2005 10:12'! testAlphaCompositing "self run: #testAlphaCompositing" | bb f1 f2 mixColor result eps | f1 := Form extent: 1@1 depth: 32. f2 := Form extent: 1@1 depth: 32. eps := 0.5 / 255. 0 to: 255 do:[:i| f1 colorAt: 0@0 put: Color blue. mixColor := Color red alpha: i / 255.0. f2 colorAt: 0@0 put: mixColor. mixColor := f2 colorAt: 0@0. bb := BitBlt toForm: f1. bb sourceForm: f2. bb combinationRule: Form blend. bb copyBits. result := f1 colorAt: 0@0. self assert: (result red - mixColor alpha) abs < eps. self assert: (result blue - (1.0 - mixColor alpha)) abs < eps. self assert: result alpha = 1.0. ].! ! !BitBltTest methodsFor: 'bugs' stamp: 'sd 6/5/2005 10:12'! testAlphaCompositing2 "self run: #testAlphaCompositing2" | bb f1 f2 mixColor result eps | f1 := Form extent: 1@1 depth: 32. f2 := Form extent: 1@1 depth: 32. eps := 0.5 / 255. 0 to: 255 do:[:i| f1 colorAt: 0@0 put: Color transparent. mixColor := Color red alpha: i / 255.0. f2 colorAt: 0@0 put: mixColor. mixColor := f2 colorAt: 0@0. bb := BitBlt toForm: f1. bb sourceForm: f2. bb combinationRule: Form blend. bb copyBits. result := f1 colorAt: 0@0. self assert: (result red - mixColor alpha) abs < eps. self assert: result alpha = mixColor alpha. ].! ! !BitBltTest methodsFor: 'bugs' stamp: 'NorbertHartl 6/20/2008 21:37'! testAlphaCompositing2Simulated "self run: #testAlphaCompositing2Simulated" | bb f1 f2 mixColor result eps | Smalltalk at: #BitBltSimulation ifPresent: [:bitblt| f1 := Form extent: 1@1 depth: 32. f2 := Form extent: 1@1 depth: 32. eps := 0.5 / 255. 0 to: 255 do:[:i| f1 colorAt: 0@0 put: Color transparent. mixColor := Color red alpha: i / 255.0. f2 colorAt: 0@0 put: mixColor. mixColor := f2 colorAt: 0@0. bb := BitBlt toForm: f1. bb sourceForm: f2. bb combinationRule: Form blend. result := f1 colorAt: 0@0. self assert: (result red - mixColor alpha) abs < eps. self assert: result alpha = mixColor alpha. ].]! ! !BitBltTest methodsFor: 'bugs' stamp: 'NorbertHartl 6/20/2008 21:37'! testAlphaCompositingSimulated "self run: #testAlphaCompositingSimulated" | bb f1 f2 mixColor result eps | Smalltalk at: #BitBltSimulation ifPresent:[:bitblt| f1 := Form extent: 1@1 depth: 32. f2 := Form extent: 1@1 depth: 32. eps := 0.5 / 255. 0 to: 255 do:[:i| f1 colorAt: 0@0 put: Color blue. mixColor := Color red alpha: i / 255.0. f2 colorAt: 0@0 put: mixColor. mixColor := f2 colorAt: 0@0. bb := BitBlt toForm: f1. bb sourceForm: f2. bb combinationRule: Form blend. result := f1 colorAt: 0@0. self assert: (result red - mixColor alpha) abs < eps. self assert: (result blue - (1.0 - mixColor alpha)) abs < eps. self assert: result alpha = 1.0. ]].! ! !BitBltTest methodsFor: 'bugs' stamp: 'sd 6/5/2005 10:13'! testPeekerUnhibernateBug "self run: #testPeekerUnhibernateBug" | bitBlt | bitBlt := BitBlt bitPeekerFromForm: Display. bitBlt destForm hibernate. self shouldnt:[bitBlt pixelAt: 1@1] raise: Error.! ! !BitBltTest methodsFor: 'bugs' stamp: 'sd 6/5/2005 10:14'! testPokerUnhibernateBug "self run: #testPokerUnhibernateBug" | bitBlt | bitBlt := BitBlt bitPokerToForm: Display. bitBlt sourceForm hibernate. self shouldnt:[bitBlt pixelAt: 1@1 put: 0] raise: Error.! ! ArrayedCollection variableWordSubclass: #Bitmap instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Graphics-Primitives'! !Bitmap commentStamp: '' prior: 0! My instances provide contiguous storage of bits, primarily to hold the graphical data of Forms. Forms and their subclasses provide the additional structural information as to how the bits should be interpreted in two dimensions.! !Bitmap methodsFor: 'accessing' stamp: 'ar 3/3/2001 16:11'! atAllPut: value "Fill the receiver, an indexable bytes or words object, with the given positive integer. The range of possible fill values is [0..255] for byte arrays and [0..(2^32 - 1)] for word arrays." super atAllPut: value.! ! !Bitmap methodsFor: 'accessing'! bitPatternForDepth: depth "The raw call on BitBlt needs a Bitmap to represent this color. I already am Bitmap like. I am already adjusted for a specific depth. Interpret me as an array of (32/depth) Color pixelValues. BitBlt aligns the first element of this array with the top scanline of the destinationForm, the second with the second, and so on, cycling through the color array as necessary. 6/18/96 tk" ^ self! ! !Bitmap methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! byteAt: byteAddress "Extract a byte from a Bitmap. Note that this is a byte address and it is one-order. For repeated use, create an instance of BitBlt and use pixelAt:. See Form pixelAt: 7/1/96 tk" | lowBits | lowBits := byteAddress - 1 bitAnd: 3. ^ ((self at: (byteAddress - 1 - lowBits) // 4 + 1) bitShift: (lowBits - 3) * 8) bitAnd: 255! ! !Bitmap methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! byteAt: byteAddress put: byte "Insert a byte into a Bitmap. Note that this is a byte address and it is one-order. For repeated use, create an instance of BitBlt and use pixelAt:put:. See Form pixelAt:put: 7/1/96 tk" | longWord shift lowBits longAddr | (byte < 0 or: [ byte > 255 ]) ifTrue: [ ^ self errorImproperStore ]. lowBits := byteAddress - 1 bitAnd: 3. longWord := self at: (longAddr := (byteAddress - 1 - lowBits) // 4 + 1). shift := (3 - lowBits) * 8. longWord := longWord - (longWord bitAnd: (255 bitShift: shift)) + (byte bitShift: shift). self at: longAddr put: longWord. ^ byte! ! !Bitmap methodsFor: 'accessing' stamp: 'ar 3/3/2001 16:18'! byteSize ^self size * 4! ! !Bitmap methodsFor: 'accessing' stamp: 'nk 7/30/2004 17:53'! copyFromByteArray: byteArray "This method should work with either byte orderings" | myHack byteHack | myHack := Form new hackBits: self. byteHack := Form new hackBits: byteArray. SmalltalkImage current isLittleEndian ifTrue: [byteHack swapEndianness]. byteHack displayOn: myHack! ! !Bitmap methodsFor: 'accessing' stamp: 'ar 11/2/1998 12:19'! defaultElement "Return the default element of the receiver" ^0! ! !Bitmap methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! integerAt: index "Return the integer at the given index" | word | word := self basicAt: index. word < 1073741823 ifTrue: [ ^ word ]. "Avoid LargeInteger computations" ^ word >= 2147483648 ifTrue: [ "Negative?!!" "word - 16r100000000" (word bitInvert32 + 1) negated ] ifFalse: [ word ]! ! !Bitmap methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! integerAt: index put: anInteger "Store the integer at the given index" | word | anInteger < 0 ifTrue: [ "word _ 16r100000000 + anInteger" word := (anInteger + 1) negated bitInvert32 ] ifFalse: [ word := anInteger ]. self basicAt: index put: word. ^ anInteger! ! !Bitmap methodsFor: 'accessing' stamp: 'tk 3/15/97'! pixelValueForDepth: depth "Self is being used to represent a single color. Answer bits that appear in ONE pixel of this color in a Bitmap of the given depth. The depth must be one of 1, 2, 4, 8, 16, or 32. Returns an integer. First pixel only. " ^ (self at: 1) bitAnd: (1 bitShift: depth) - 1! ! !Bitmap methodsFor: 'accessing'! primFill: aPositiveInteger "Fill the receiver, an indexable bytes or words object, with the given positive integer. The range of possible fill values is [0..255] for byte arrays and [0..(2^32 - 1)] for word arrays." self errorImproperStore.! ! !Bitmap methodsFor: 'accessing'! replaceFrom: start to: stop with: replacement startingAt: repStart "Primitive. This destructively replaces elements from start to stop in the receiver starting at index, repStart, in the collection, replacement. Answer the receiver. Range checks are performed in the primitive only. Optional. See Object documentation whatIsAPrimitive." super replaceFrom: start to: stop with: replacement startingAt: repStart! ! !Bitmap methodsFor: 'as yet unclassified' stamp: 'lr 7/4/2009 10:42'! asByteArray "Faster way to make a byte array from me. copyFromByteArray: makes equal Bitmap." | f bytes hack | f := Form extent: 4 @ self size depth: 8 bits: self. bytes := ByteArray new: self size * 4. hack := Form new hackBits: bytes. SmalltalkImage current isLittleEndian ifTrue: [ hack swapEndianness ]. hack copyBits: f boundingBox from: f at: 0 @ 0 clippingBox: hack boundingBox rule: Form over fillColor: nil map: nil. "f displayOn: hack." ^ bytes! ! !Bitmap methodsFor: 'as yet unclassified' stamp: 'RAA 7/28/2000 21:51'! copy ^self clone! ! !Bitmap methodsFor: 'filing' stamp: 'lr 7/4/2009 10:42'! compress: bm toByteArray: ba "Store a run-coded compression of the receiver into the byteArray ba, and return the last index stored into. ba is assumed to be large enough. The encoding is as follows... S {N D}*. S is the size of the original bitmap, followed by run-coded pairs. N is a run-length * 4 + data code. D, the data, depends on the data code... 0 skip N words, D is absent 1 N words with all 4 bytes = D (1 byte) 2 N words all = D (4 bytes) 3 N words follow in D (4N bytes) S and N are encoded as follows... 0-223 0-223 224-254 (0-30)*256 + next byte (0-7935) 255 next 4 bytes" | size k word j lowByte eqBytes i | self var: #bm declareC: 'int *bm'. self var: #ba declareC: 'unsigned char *ba'. size := bm size. i := self encodeInt: size in: ba at: 1. k := 1. [ k <= size ] whileTrue: [ word := bm at: k. lowByte := word bitAnd: 255. eqBytes := (word >> 8 bitAnd: 255) = lowByte and: [ (word >> 16 bitAnd: 255) = lowByte and: [ (word >> 24 bitAnd: 255) = lowByte ] ]. j := k. [ j < size and: [ word = (bm at: j + 1) ] "scan for = words..." ] whileTrue: [ j := j + 1 ]. j > k ifTrue: [ "We have two or more = words, ending at j" eqBytes ifTrue: [ "Actually words of = bytes" i := self encodeInt: (j - k + 1) * 4 + 1 in: ba at: i. ba at: i put: lowByte. i := i + 1 ] ifFalse: [ i := self encodeInt: (j - k + 1) * 4 + 2 in: ba at: i. i := self encodeBytesOf: word in: ba at: i ]. k := j + 1 ] ifFalse: [ "Check for word of 4 = bytes" eqBytes ifTrue: [ "Note 1 word of 4 = bytes" i := self encodeInt: 1 * 4 + 1 in: ba at: i. ba at: i put: lowByte. i := i + 1. k := k + 1 ] ifFalse: [ "Finally, check for junk" [ j < size and: [ (bm at: j) ~= (bm at: j + 1) ] "scan for ~= words..." ] whileTrue: [ j := j + 1 ]. j = size ifTrue: [ j := j + 1 ]. "We have one or more unmatching words, ending at j-1" i := self encodeInt: (j - k) * 4 + 3 in: ba at: i. k to: j - 1 do: [ :m | i := self encodeBytesOf: (bm at: m) in: ba at: i ]. k := j ] ] ]. ^ i - 1 "number of bytes actually stored" " Space check: | n rawBytes myBytes b | n _ rawBytes _ myBytes _ 0. Form allInstancesDo: [:f | f unhibernate. b _ f bits. n _ n + 1. rawBytes _ rawBytes + (b size*4). myBytes _ myBytes + (b compressToByteArray size). f hibernate]. Array with: n with: rawBytes with: myBytes ColorForms: (116 230324 160318 ) Forms: (113 1887808 1325055 ) Integerity check: Form allInstances do: [:f | f unhibernate. f bits = (Bitmap decompressFromByteArray: f bits compressToByteArray) ifFalse: [self halt]. f hibernate] Speed test: MessageTally spyOn: [Form allInstances do: [:f | Bitmap decompressFromByteArray: f bits compressToByteArray]] "! ! !Bitmap methodsFor: 'filing' stamp: 'lr 7/4/2009 10:42'! compressGZip "just hacking around to see if further compression would help Nebraska" | ba hackwa hackba blt rowsAtATime sourceOrigin rowsRemaining bufferStream gZipStream | bufferStream := RWBinaryOrTextStream on: (ByteArray new: 5000). gZipStream := GZipWriteStream on: bufferStream. ba := nil. rowsAtATime := 20000. "or 80000 bytes" hackwa := Form new hackBits: self. sourceOrigin := 0 @ 0. [ (rowsRemaining := hackwa height - sourceOrigin y) > 0 ] whileTrue: [ rowsAtATime := rowsAtATime min: rowsRemaining. (ba isNil or: [ ba size ~= (rowsAtATime * 4) ]) ifTrue: [ ba := ByteArray new: rowsAtATime * 4. hackba := Form new hackBits: ba. blt := (BitBlt toForm: hackba) sourceForm: hackwa ]. blt combinationRule: Form over; sourceOrigin: sourceOrigin; destX: 0 destY: 0 width: 4 height: rowsAtATime; copyBits. "bufferStream nextPutAll: ba." sourceOrigin := sourceOrigin x @ (sourceOrigin y + rowsAtATime) ]. gZipStream close. ^ bufferStream contents! ! !Bitmap methodsFor: 'filing' stamp: 'lr 7/4/2009 10:42'! compressToByteArray "Return a run-coded compression of this bitmap into a byteArray" "Without skip codes, it is unlikely that the compressed bitmap will be any larger than was the original. The run-code cases are... N >= 1 words of equal bytes: 4N bytes -> 2 bytes (at worst 4 -> 2) N > 1 equal words: 4N bytes -> 5 bytes (at worst 8 -> 5) N > 1 unequal words: 4N bytes -> 4N + M, where M is the number of bytes required to encode the run length. The worst that can happen is that the method begins with unequal words, and than has interspersed occurrences of a word with equal bytes. Thus we require a run-length at the beginning, and after every interspersed word of equal bytes. However, each of these saves 2 bytes, so it must be followed by a run of 1984 (7936//4) or more (for which M jumps from 2 to 5) to add any extra overhead. Therefore the worst case is a series of runs of 1984 or more, with single interspersed words of equal bytes. At each break we save 2 bytes, but add 5. Thus the overhead would be no more than 5 (encoded size) + 2 (first run len) + (S//1984*3)." "NOTE: This code is copied in Form hibernate for reasons given there." | byteArray lastByte | byteArray := ByteArray new: self size * 4 + 7 + (self size // 1984 * 3). lastByte := self compress: self toByteArray: byteArray. ^ byteArray copyFrom: 1 to: lastByte! ! !Bitmap methodsFor: 'filing' stamp: 'lr 7/4/2009 10:42'! decompress: bm fromByteArray: ba at: index "Decompress the body of a byteArray encoded by compressToByteArray (qv)... The format is simply a sequence of run-coded pairs, {N D}*. N is a run-length * 4 + data code. D, the data, depends on the data code... 0 skip N words, D is absent (could be used to skip from one raster line to the next) 1 N words with all 4 bytes = D (1 byte) 2 N words all = D (4 bytes) 3 N words follow in D (4N bytes) S and N are encoded as follows (see decodeIntFrom:)... 0-223 0-223 224-254 (0-30)*256 + next byte (0-7935) 255 next 4 bytes" "NOTE: If fed with garbage, this routine could read past the end of ba, but it should fail before writing past the ned of bm." | i code n anInt data end k pastEnd | self var: #bm declareC: 'int *bm'. self var: #ba declareC: 'unsigned char *ba'. i := index. "byteArray read index" end := ba size. k := 1. "bitmap write index" pastEnd := bm size + 1. [ i <= end ] whileTrue: [ "Decode next run start N" anInt := ba at: i. i := i + 1. anInt <= 223 ifFalse: [ anInt <= 254 ifTrue: [ anInt := (anInt - 224) * 256 + (ba at: i). i := i + 1 ] ifFalse: [ anInt := 0. 1 to: 4 do: [ :j | anInt := (anInt bitShift: 8) + (ba at: i). i := i + 1 ] ] ]. n := anInt >> 2. k + n > pastEnd ifTrue: [ ^ self primitiveFailed ]. code := anInt bitAnd: 3. code = 0 ifTrue: [ "skip" ]. code = 1 ifTrue: [ "n consecutive words of 4 bytes = the following byte" data := ba at: i. i := i + 1. data := data bitOr: (data bitShift: 8). data := data bitOr: (data bitShift: 16). 1 to: n do: [ :j | bm at: k put: data. k := k + 1 ] ]. code = 2 ifTrue: [ "n consecutive words = 4 following bytes" data := 0. 1 to: 4 do: [ :j | data := (data bitShift: 8) bitOr: (ba at: i). i := i + 1 ]. 1 to: n do: [ :j | bm at: k put: data. k := k + 1 ] ]. code = 3 ifTrue: [ "n consecutive words from the data..." 1 to: n do: [ :m | data := 0. 1 to: 4 do: [ :j | data := (data bitShift: 8) bitOr: (ba at: i). i := i + 1 ]. bm at: k put: data. k := k + 1 ] ] ]! ! !Bitmap methodsFor: 'filing' stamp: 'jm 2/15/98 17:27'! encodeBytesOf: anInt in: ba at: i "Copy the integer anInt into byteArray ba at index i, and return the next index" self inline: true. self var: #ba declareC: 'unsigned char *ba'. 0 to: 3 do: [:j | ba at: i+j put: (anInt >> (3-j*8) bitAnd: 16rFF)]. ^ i+4! ! !Bitmap methodsFor: 'filing' stamp: 'lr 7/4/2009 10:42'! encodeInt: int "Encode the integer int as per encodeInt:in:at:, and return it as a ByteArray" | byteArray next | byteArray := ByteArray new: 5. next := self encodeInt: int in: byteArray at: 1. ^ byteArray copyFrom: 1 to: next - 1! ! !Bitmap methodsFor: 'filing' stamp: 'jm 2/15/98 17:26'! encodeInt: anInt in: ba at: i "Encode the integer anInt in byteArray ba at index i, and return the next index. The encoding is as follows... 0-223 0-223 224-254 (0-30)*256 + next byte (0-7935) 255 next 4 bytes" self inline: true. self var: #ba declareC: 'unsigned char *ba'. anInt <= 223 ifTrue: [ba at: i put: anInt. ^ i+1]. anInt <= 7935 ifTrue: [ba at: i put: anInt//256+224. ba at: i+1 put: anInt\\256. ^ i+2]. ba at: i put: 255. ^ self encodeBytesOf: anInt in: ba at: i+1! ! !Bitmap methodsFor: 'filing' stamp: 'PeterHugossonMiller 9/3/2009 00:15'! readCompressedFrom: strm "Decompress an old-style run-coded stream into this bitmap: [0 means end of runs] [n = 1..127] [(n+3) copies of next byte] [n = 128..191] [(n-127) next bytes as is] [n = 192..255] [(n-190) copies of next 4 bytes]" | n byte out outBuff bytes | out := (outBuff := ByteArray new: self size * 4) writeStream. [ (n := strm next) > 0 ] whileTrue: [ (n between: 1 and: 127) ifTrue: [ byte := strm next. 1 to: n + 3 do: [ :i | out nextPut: byte ] ]. (n between: 128 and: 191) ifTrue: [ 1 to: n - 127 do: [ :i | out nextPut: strm next ] ]. (n between: 192 and: 255) ifTrue: [ bytes := (1 to: 4) collect: [ :i | strm next ]. 1 to: n - 190 do: [ :i | bytes do: [ :b | out nextPut: b ] ] ] ]. out position = outBuff size ifFalse: [ self error: 'Decompression size error' ]. "Copy the final byteArray into self" self copyFromByteArray: outBuff! ! !Bitmap methodsFor: 'filing' stamp: 'tk 1/24/2000 22:37'! restoreEndianness "This word object was just read in from a stream. Bitmaps are always compressed and serialized in a machine-independent way. Do not correct the Endianness." "^ self" ! ! !Bitmap methodsFor: 'filing' stamp: 'nk 12/31/2003 16:02'! storeBits: startBit to: stopBit on: aStream "Store my bits as a hex string, breaking the lines every 100 bytes or so to comply with the maximum line length limits of Postscript (255 bytes). " | lineWidth | lineWidth := 0. self do: [:word | startBit to: stopBit by: -4 do: [:shift | aStream nextPut: (word >> shift bitAnd: 15) asHexDigit. lineWidth := lineWidth + 1]. (lineWidth > 100) ifTrue: [aStream cr. lineWidth := 0]]. lineWidth > 0 ifTrue: [ aStream cr ].! ! !Bitmap methodsFor: 'filing' stamp: 'lr 7/4/2009 10:42'! writeOn: aStream "Store the array of bits onto the argument, aStream. A leading byte of 16r80 identifies this as compressed by compressToByteArray (qv)." | b | aStream nextPut: 128. b := self compressToByteArray. aStream nextPutAll: (self encodeInt: b size); nextPutAll: b! ! !Bitmap methodsFor: 'filing' stamp: 'tk 2/19/1999 07:36'! writeUncompressedOn: aStream "Store the array of bits onto the argument, aStream. (leading byte ~= 16r80) identifies this as raw bits (uncompressed)." aStream nextInt32Put: self size. aStream nextPutAll: self ! ! !Bitmap methodsFor: 'initialization' stamp: 'ar 12/23/1999 14:35'! fromByteStream: aStream "Initialize the array of bits by reading integers from the argument, aStream." aStream nextWordsInto: self! ! !Bitmap methodsFor: 'printing' stamp: 'sma 6/1/2000 09:42'! printOn: aStream self printNameOn: aStream. aStream nextPutAll: ' of length '; print: self size! ! !Bitmap methodsFor: 'printing' stamp: 'MPW 1/1/1901 22:00'! printOnStream: aStream aStream print: 'a Bitmap of length '; write:self size. ! ! !Bitmap methodsFor: 'testing' stamp: 'ar 5/25/2000 19:42'! isColormap "Bitmaps were used as color maps for BitBlt. This method allows to recognize real color maps." ^false! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Bitmap class instanceVariableNames: ''! !Bitmap class methodsFor: 'instance creation' stamp: 'lr 7/4/2009 10:42'! decodeIntFrom: s "Decode an integer in stream s as follows... 0-223 0-223 224-254 (0-30)*256 + next byte (0-7935) 255 next 4 bytes " | int | int := s next. int <= 223 ifTrue: [ ^ int ]. int <= 254 ifTrue: [ ^ (int - 224) * 256 + s next ]. int := s next. 1 to: 3 do: [ :j | int := (int bitShift: 8) + s next ]. ^ int! ! !Bitmap class methodsFor: 'instance creation' stamp: 'damiencassou 5/30/2008 14:51'! decompressFromByteArray: byteArray | s bitmap size | s := byteArray readStream. size := self decodeIntFrom: s. bitmap := self new: size. bitmap decompress: bitmap fromByteArray: byteArray at: s position + 1. ^ bitmap! ! !Bitmap class methodsFor: 'instance creation' stamp: 'lr 7/4/2009 10:42'! newFromStream: s | len | s next = 128 ifTrue: [ "New compressed format" len := self decodeIntFrom: s. ^ Bitmap decompressFromByteArray: (s nextInto: (ByteArray new: len)) ]. s skip: -1. len := s nextInt32. len <= 0 ifTrue: [ "Old compressed format" ^ (self new: len negated) readCompressedFrom: s ] ifFalse: [ "Old raw data format" ^ s nextWordsInto: (self new: len) ]! ! !Bitmap class methodsFor: 'utilities' stamp: 'lr 7/4/2009 10:42'! swapBytesIn: aNonPointerThing from: start to: stop "Perform a bigEndian/littleEndian byte reversal of my words. We only intend this for non-pointer arrays. Do nothing if I contain pointers." "The implementation is a hack, but fast for large ranges" | hack blt | hack := Form new hackBits: aNonPointerThing. blt := (BitBlt toForm: hack) sourceForm: hack. blt combinationRule: Form reverse. "XOR" blt sourceY: start - 1; destY: start - 1; height: stop - start + 1; width: 1. blt sourceX: 0; destX: 3; copyBits. "Exchange bytes 0 and 3" blt sourceX: 3; destX: 0; copyBits. blt sourceX: 0; destX: 3; copyBits. blt sourceX: 1; destX: 2; copyBits. "Exchange bytes 1 and 2" blt sourceX: 2; destX: 1; copyBits. blt sourceX: 1; destX: 2; copyBits! ! TestCase subclass: #BitmapBugz instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Tests-Bugs'! !BitmapBugz methodsFor: 'as yet unclassified' stamp: 'ar 8/2/2003 19:21'! testBitmapByteAt | bm | bm := Bitmap new: 1. 1 to: 4 do:[:i| self should:[bm byteAt: i put: 1000] raise: Error. ].! ! OrientedFillStyle subclass: #BitmapFillStyle instanceVariableNames: 'form tileFlag' classVariableNames: '' poolDictionaries: '' category: 'Balloon-Fills'! !BitmapFillStyle commentStamp: '' prior: 0! A BitmapFillStyle fills using any kind of form. Instance variables: form
The form to be used as fill. tileFlag If true, then the form is repeatedly drawn to fill the area.! !BitmapFillStyle methodsFor: '*morphic-balloon' stamp: 'wiz 8/30/2003 16:54'! grabNewGraphicIn: aMorph event: evt "Used by any morph that can be represented by a graphic" | fill | fill := Form fromUser. fill boundingBox area = 0 ifTrue: [^ self]. self form: fill. self direction: fill width @ 0. self normal: 0 @ fill height. aMorph changed! ! !BitmapFillStyle methodsFor: '*morphic-balloon' stamp: 'ar 6/25/1999 11:57'! newForm: aForm forMorph: aMorph self form: aForm. self direction: (aForm width @ 0). self normal: (0 @ aForm height). aMorph changed.! ! !BitmapFillStyle methodsFor: 'accessing' stamp: 'wiz 1/16/2005 20:17'! direction ^direction ifNil:[direction :=( (normal y @ normal x negated) * form width / form height ) rounded]! ! !BitmapFillStyle methodsFor: 'accessing' stamp: 'ar 11/11/1998 22:40'! form ^form! ! !BitmapFillStyle methodsFor: 'accessing' stamp: 'ar 11/11/1998 22:40'! form: aForm form := aForm! ! !BitmapFillStyle methodsFor: 'accessing' stamp: 'wiz 1/16/2005 20:18'! normal ^normal ifNil:[normal := ((direction y negated @ direction x) * form height / form width ) rounded]! ! !BitmapFillStyle methodsFor: 'accessing' stamp: 'ar 11/27/1998 14:37'! tileFlag ^tileFlag! ! !BitmapFillStyle methodsFor: 'accessing' stamp: 'ar 11/27/1998 14:30'! tileFlag: aBoolean tileFlag := aBoolean! ! !BitmapFillStyle methodsFor: 'converting' stamp: 'ar 11/11/1998 22:41'! asColor ^form colorAt: 0@0! ! !BitmapFillStyle methodsFor: 'testing' stamp: 'ar 11/11/1998 22:40'! isBitmapFill ^true! ! !BitmapFillStyle methodsFor: 'testing' stamp: 'ar 11/27/1998 14:37'! isTiled "Return true if the receiver should be repeated if the fill shape is larger than the form" ^tileFlag == true! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! BitmapFillStyle class instanceVariableNames: ''! !BitmapFillStyle class methodsFor: 'instance creation' stamp: 'ar 11/13/1998 20:32'! form: aForm ^self new form: aForm! ! !BitmapFillStyle class methodsFor: 'instance creation' stamp: 'KLC 1/27/2004 13:33'! fromForm: aForm | fs | fs := self form: aForm. fs origin: 0@0. fs direction: aForm width @ 0. fs normal: 0 @ aForm height. fs tileFlag: true. ^fs! ! !BitmapFillStyle class methodsFor: 'instance creation' stamp: 'ar 6/18/1999 07:09'! fromUser | fill | fill := self form: Form fromUser. fill origin: 0@0. fill direction: fill form width @ 0. fill normal: 0 @ fill form height. fill tileFlag: true. "So that we can fill arbitrary objects" ^fill! ! TestCase subclass: #BitmapStreamTests instanceVariableNames: 'random array stream filename' classVariableNames: '' poolDictionaries: '' category: 'Tests-Bugs'! !BitmapStreamTests commentStamp: 'nk 3/7/2004 14:26' prior: 0! This is an incomplete test suite for storing and reading various word- and short-word subclasses of ArrayedCollection. It demonstrates some problems with filing in of certain kinds of arrayed objects, including: ShortPointArray ShortIntegerArray ShortRunArray WordArray MatrixTransform2x3 In 3.6b-5331, I get 8 passed/6 failed/6 errors (not counting the MatrixTransform2x3 tests, which were added later). I ran into problems when trying to read back the SqueakLogo flash character morph, after I'd done a 'save morph to disk' from its debug menu. The words within the ShortPointArrays and ShortRunArrays were reversed. ! !BitmapStreamTests methodsFor: 'running' stamp: 'SergeStinckwich 5/27/2008 22:58'! setUp filename := 'bitmapStreamTest.ref'. random := Random new! ! !BitmapStreamTests methodsFor: 'running' stamp: 'SergeStinckwich 5/27/2008 22:59'! tearDown FileDirectory default deleteFileNamed: filename ifAbsent: []! ! !BitmapStreamTests methodsFor: 'tests-matrixtransform2x3' stamp: 'stephaneducasse 2/3/2006 22:39'! testMatrixTransform2x3WithImageSegment array := MatrixTransform2x3 new. 1 to: 6 do: [ :i | array at: i put: self randomFloat ]. self validateImageSegment ! ! !BitmapStreamTests methodsFor: 'tests-matrixtransform2x3' stamp: 'stephaneducasse 2/3/2006 22:39'! testMatrixTransform2x3WithRefStream array := MatrixTransform2x3 new. 1 to: 6 do: [ :i | array at: i put: self randomFloat ]. self validateRefStream ! ! !BitmapStreamTests methodsFor: 'tests-matrixtransform2x3' stamp: 'stephaneducasse 2/3/2006 22:39'! testMatrixTransform2x3WithRefStreamOnDisk array := MatrixTransform2x3 new. 1 to: 6 do: [ :i | array at: i put: self randomFloat ]. self validateRefStreamOnDisk ! ! !BitmapStreamTests methodsFor: 'tests-matrixtransform2x3' stamp: 'stephaneducasse 2/3/2006 22:39'! testMatrixTransform2x3WithSmartRefStream array := MatrixTransform2x3 new. 1 to: 6 do: [ :i | array at: i put: self randomFloat ]. self validateSmartRefStream ! ! !BitmapStreamTests methodsFor: 'tests-matrixtransform2x3' stamp: 'stephaneducasse 2/3/2006 22:39'! testMatrixTransform2x3WithSmartRefStreamOnDisk array := MatrixTransform2x3 new. 1 to: 6 do: [ :i | array at: i put: self randomFloat ]. self validateSmartRefStreamOnDisk ! ! !BitmapStreamTests methodsFor: 'tests-misc' stamp: 'DouglasBrebner 9/2/2009 19:18'! testOtherClasses #(WordArrayForSegment FloatArray PointArray IntegerArray String ShortPointArray ShortIntegerArray WordArray Array DependentsArray ByteArray Bitmap ColorArray ) do: [:s | | a | a := (Smalltalk at: s) new: 3. self assert: (a basicSize * a bytesPerBasicElement = a byteSize). ] ! ! !BitmapStreamTests methodsFor: 'tests-shortintegerarray' stamp: 'stephaneducasse 2/3/2006 22:39'! testShortIntegerArrayReadRefStream2 |refStrm| refStrm := ReferenceStream on: ((RWBinaryOrTextStream with: (ByteArray withAll: #(20 6 17 83 104 111 114 116 73 110 116 101 103 101 114 65 114 114 97 121 0 0 0 2 0 0 0 1 0 2 0 3))) reset; binary). self assert: (refStrm next = (ShortIntegerArray with: 0 with: 1 with: 2 with: 3)).! ! !BitmapStreamTests methodsFor: 'tests-shortintegerarray' stamp: 'stephaneducasse 2/3/2006 22:39'! testShortIntegerArrayWithImageSegment array := ShortIntegerArray new: 10. 1 to: 10 do: [ :i | array at: i put: self randomShortInt ]. self validateImageSegment ! ! !BitmapStreamTests methodsFor: 'tests-shortintegerarray' stamp: 'stephaneducasse 2/3/2006 22:39'! testShortIntegerArrayWithRefStream array := ShortIntegerArray with: 0 with: 1 with: 2 with: 3. self validateRefStream ! ! !BitmapStreamTests methodsFor: 'tests-shortintegerarray' stamp: 'stephaneducasse 2/3/2006 22:39'! testShortIntegerArrayWithRefStream2 array := ShortIntegerArray with: 0 with: 1 with: 2 with: 3. self validateRefStream. self assert: stream byteStream contents = (ByteArray withAll: #(20 6 17 83 104 111 114 116 73 110 116 101 103 101 114 65 114 114 97 121 0 0 0 2 0 0 0 1 0 2 0 3)) ! ! !BitmapStreamTests methodsFor: 'tests-shortintegerarray' stamp: 'stephaneducasse 2/3/2006 22:39'! testShortIntegerArrayWithRefStreamOnDisk array := ShortIntegerArray new: 10. 1 to: 10 do: [ :i | array at: i put: self randomShortInt ]. self validateRefStreamOnDisk ! ! !BitmapStreamTests methodsFor: 'tests-shortintegerarray' stamp: 'stephaneducasse 2/3/2006 22:39'! testShortIntegerArrayWithSmartRefStream array := ShortIntegerArray new: 10. 1 to: 10 do: [ :i | array at: i put: self randomShortInt ]. self validateSmartRefStream ! ! !BitmapStreamTests methodsFor: 'tests-shortintegerarray' stamp: 'stephaneducasse 2/3/2006 22:39'! testShortIntegerArrayWithSmartRefStream2 array := ShortIntegerArray with: 0 with: 1 with: 2 with: 3. self validateSmartRefStream. self assert: (stream contents asByteArray last: 15) = (ByteArray withAll: #(0 0 0 2 0 0 0 1 0 2 0 3 33 13 13)) ! ! !BitmapStreamTests methodsFor: 'tests-shortintegerarray' stamp: 'stephaneducasse 2/3/2006 22:39'! testShortIntegerArrayWithSmartRefStreamOnDisk array := ShortIntegerArray new: 10. 1 to: 10 do: [ :i | array at: i put: self randomShortInt ]. self validateSmartRefStreamOnDisk ! ! !BitmapStreamTests methodsFor: 'tests-shortpointarray' stamp: 'stephaneducasse 2/3/2006 22:39'! testShortPointArrayWithImageSegment array := ShortPointArray new: 10. 1 to: 10 do: [ :i | array at: i put: self randomShortPoint ]. self validateImageSegment ! ! !BitmapStreamTests methodsFor: 'tests-shortpointarray' stamp: 'stephaneducasse 2/3/2006 22:39'! testShortPointArrayWithRefStream array := ShortPointArray new: 10. 1 to: 10 do: [ :i | array at: i put: self randomShortPoint ]. self validateRefStream ! ! !BitmapStreamTests methodsFor: 'tests-shortpointarray' stamp: 'stephaneducasse 2/3/2006 22:39'! testShortPointArrayWithRefStream2 array := ShortPointArray with: 0@1 with: 2@3. self validateRefStream. self assert: stream byteStream contents = (ByteArray withAll: #(20 6 15 83 104 111 114 116 80 111 105 110 116 65 114 114 97 121 0 0 0 2 0 0 0 1 0 2 0 3 )) ! ! !BitmapStreamTests methodsFor: 'tests-shortpointarray' stamp: 'stephaneducasse 2/3/2006 22:39'! testShortPointArrayWithRefStreamOnDisk array := ShortPointArray new: 10. 1 to: 10 do: [ :i | array at: i put: self randomShortPoint ]. self validateRefStreamOnDisk ! ! !BitmapStreamTests methodsFor: 'tests-shortpointarray' stamp: 'stephaneducasse 2/3/2006 22:39'! testShortPointArrayWithSmartRefStream array := ShortPointArray new: 10. 1 to: 10 do: [ :i | array at: i put: self randomShortPoint ]. self validateSmartRefStream ! ! !BitmapStreamTests methodsFor: 'tests-shortpointarray' stamp: 'stephaneducasse 2/3/2006 22:39'! testShortPointArrayWithSmartRefStream2 array := ShortPointArray with: 0@1 with: 2@3. self validateSmartRefStream. self assert: (stream contents asByteArray last: 15) = (ByteArray withAll: #(0 0 0 2 0 0 0 1 0 2 0 3 33 13 13)) ! ! !BitmapStreamTests methodsFor: 'tests-shortpointarray' stamp: 'stephaneducasse 2/3/2006 22:39'! testShortPointArrayWithSmartRefStreamOnDisk array := ShortPointArray new: 10. 1 to: 10 do: [ :i | array at: i put: self randomShortPoint ]. self validateSmartRefStreamOnDisk ! ! !BitmapStreamTests methodsFor: 'tests-shortrunarray' stamp: 'nk 3/17/2004 16:39'! createSampleShortRunArray ^ShortRunArray newFrom: { 0. 1. 1. 2. 2. 2. 3. 3. 3. 3 }! ! !BitmapStreamTests methodsFor: 'tests-shortrunarray' stamp: 'stephaneducasse 2/3/2006 22:39'! testShortRunArrayWithImageSegment array := self createSampleShortRunArray. self validateImageSegment ! ! !BitmapStreamTests methodsFor: 'tests-shortrunarray' stamp: 'stephaneducasse 2/3/2006 22:39'! testShortRunArrayWithRefStream array := self createSampleShortRunArray. self validateRefStream ! ! !BitmapStreamTests methodsFor: 'tests-shortrunarray' stamp: 'stephaneducasse 2/3/2006 22:39'! testShortRunArrayWithRefStreamOnDisk array := self createSampleShortRunArray. self validateRefStreamOnDisk ! ! !BitmapStreamTests methodsFor: 'tests-shortrunarray' stamp: 'stephaneducasse 2/3/2006 22:39'! testShortRunArrayWithSmartRefStream array := self createSampleShortRunArray. self validateSmartRefStream ! ! !BitmapStreamTests methodsFor: 'tests-shortrunarray' stamp: 'stephaneducasse 2/3/2006 22:39'! testShortRunArrayWithSmartRefStream2 array := self createSampleShortRunArray. self validateSmartRefStream. self assert: (stream contents asByteArray last: 23) = (ByteArray withAll: #(0 0 0 4 0 1 0 0 0 2 0 1 0 3 0 2 0 4 0 3 33 13 13)) ! ! !BitmapStreamTests methodsFor: 'tests-shortrunarray' stamp: 'stephaneducasse 2/3/2006 22:39'! testShortRunArrayWithSmartRefStreamOnDisk array := self createSampleShortRunArray. self validateSmartRefStreamOnDisk ! ! !BitmapStreamTests methodsFor: 'tests-wordarray' stamp: 'stephaneducasse 2/3/2006 22:39'! testWordArrayWithImageSegment array := WordArray new: 10. 1 to: 10 do: [ :i | array at: i put: self randomWord ]. self validateImageSegment ! ! !BitmapStreamTests methodsFor: 'tests-wordarray' stamp: 'stephaneducasse 2/3/2006 22:39'! testWordArrayWithRefStream array := WordArray new: 10. 1 to: 10 do: [ :i | array at: i put: self randomWord ]. self validateRefStream ! ! !BitmapStreamTests methodsFor: 'tests-wordarray' stamp: 'stephaneducasse 2/3/2006 22:39'! testWordArrayWithRefStreamOnDisk array := WordArray new: 10. 1 to: 10 do: [ :i | array at: i put: self randomWord ]. self validateRefStreamOnDisk ! ! !BitmapStreamTests methodsFor: 'tests-wordarray' stamp: 'stephaneducasse 2/3/2006 22:39'! testWordArrayWithSmartRefStream array := WordArray new: 10. 1 to: 10 do: [ :i | array at: i put: self randomWord ]. self validateSmartRefStream ! ! !BitmapStreamTests methodsFor: 'tests-wordarray' stamp: 'stephaneducasse 2/3/2006 22:39'! testWordArrayWithSmartRefStreamOnDisk array := WordArray new: 10. 1 to: 10 do: [ :i | array at: i put: self randomWord ]. self validateSmartRefStreamOnDisk ! ! !BitmapStreamTests methodsFor: 'private' stamp: 'stephaneducasse 2/3/2006 22:39'! randomFloat "Answer a random 32-bit float" | w | random seed: (w := random nextValue). ^w! ! !BitmapStreamTests methodsFor: 'private' stamp: 'nk 7/5/2003 16:33'! randomShortInt ^((random next * 65536) - 32768) truncated! ! !BitmapStreamTests methodsFor: 'private' stamp: 'nk 7/5/2003 16:00'! randomShortPoint ^(((random next * 65536) @ (random next * 65536)) - (32768 @ 32768)) truncated! ! !BitmapStreamTests methodsFor: 'private' stamp: 'stephaneducasse 2/3/2006 22:39'! randomWord "Answer a random 32-bit integer" | w | random seed: (w := random nextValue). ^w truncated! ! !BitmapStreamTests methodsFor: 'private' stamp: 'al 6/14/2008 19:12'! validateImageSegment | other externalSegmentFilename | externalSegmentFilename := 'bitmapStreamTest.extSeg'. [ (ImageSegment new copyFromRootsForExport: (Array with: array)) writeForExport: externalSegmentFilename. other := (FileDirectory default readOnlyFileNamed: externalSegmentFilename) fileInObjectAndCode ] ensure: [ FileDirectory default deleteFileNamed: externalSegmentFilename ifAbsent: [ ] ]. self assert: array = other originalRoots first! ! !BitmapStreamTests methodsFor: 'private' stamp: 'stephaneducasse 2/3/2006 22:39'! validateRefStream "array is set up with an array." | other rwstream | rwstream := RWBinaryOrTextStream on: (ByteArray new: array basicSize * 6). stream := ReferenceStream on: rwstream. stream nextPut: array; close. rwstream position: 0. stream := ReferenceStream on: rwstream. other := stream next. stream close. self assert: array = other! ! !BitmapStreamTests methodsFor: 'private' stamp: 'SergeStinckwich 5/27/2008 22:59'! validateRefStreamOnDisk "array is set up with an array." | other | FileDirectory default deleteFileNamed: filename ifAbsent: [ ]. stream := ReferenceStream fileNamed: filename. stream nextPut: array; close. stream := ReferenceStream fileNamed: filename. other := stream next. stream close. self assert: array = other! ! !BitmapStreamTests methodsFor: 'private' stamp: 'stephaneducasse 2/3/2006 22:39'! validateSmartRefStream "array is set up with an array." | other | stream := RWBinaryOrTextStream on: (ByteArray new: array basicSize * 6). stream binary. stream fileOutClass: nil andObject: array. stream position: 0. stream binary. other := stream fileInObjectAndCode. self assert: array = other! ! !BitmapStreamTests methodsFor: 'private' stamp: 'SergeStinckwich 5/27/2008 22:59'! validateSmartRefStreamOnDisk "array is set up with an array." | other | FileDirectory default deleteFileNamed: filename ifAbsent: [ ]. stream := FileDirectory default fileNamed: filename. stream fileOutClass: nil andObject: array. stream close. stream := FileDirectory default fileNamed: filename. other := stream fileInObjectAndCode. stream close. self assert: array = other! ! Error subclass: #BlockCannotReturn instanceVariableNames: 'result deadHome' classVariableNames: '' poolDictionaries: '' category: 'Exceptions-Kernel'! !BlockCannotReturn commentStamp: '' prior: 0! This class is private to the EHS implementation. Its use allows for ensured execution to survive code such as: [self doThis. ^nil] ensure: [self doThat] Signaling or handling this exception is not recommended.! !BlockCannotReturn methodsFor: 'accessing' stamp: 'ajh 2/6/2002 11:12'! deadHome ^ deadHome! ! !BlockCannotReturn methodsFor: 'accessing' stamp: 'ajh 2/6/2002 11:12'! deadHome: context deadHome := context! ! !BlockCannotReturn methodsFor: 'accessing' stamp: 'tfei 3/30/1999 12:54'! result ^result! ! !BlockCannotReturn methodsFor: 'accessing' stamp: 'tfei 3/30/1999 12:54'! result: r result := r! ! !BlockCannotReturn methodsFor: 'exceptiondescription' stamp: 'tfei 3/30/1999 12:55'! defaultAction self messageText: 'Block cannot return'. ^super defaultAction! ! !BlockCannotReturn methodsFor: 'exceptiondescription' stamp: 'tfei 4/2/1999 15:49'! isResumable ^true! ! Object variableSubclass: #BlockClosure instanceVariableNames: 'outerContext startpc numArgs' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Methods'! !BlockClosure commentStamp: '' prior: 0! I am a block closure for Eliot's closure implementation. Not to be confused with the old BlockClosure.! ]style[(103)i! !BlockClosure methodsFor: '*services-base' stamp: 'rr 3/21/2006 11:53'! valueWithRequestor: aRequestor "To do later: make the fillInTheBlank display more informative captions. Include the description of the service, and maybe record steps" ^ self numArgs isZero ifTrue: [self value] ifFalse: [self value: aRequestor]! ! !BlockClosure methodsFor: '*splitjoin' stamp: 'stephane.ducasse 4/13/2009 22:03'! split: aSequenceableCollection | result position | result := OrderedCollection new. position := 1. aSequenceableCollection withIndexDo: [:element :idx | (self value: element) ifTrue: [result add: (aSequenceableCollection copyFrom: position to: idx - 1). position := idx + 1]]. result add: (aSequenceableCollection copyFrom: position to: aSequenceableCollection size). ^ result! ! !BlockClosure methodsFor: 'accessing' stamp: 'stephane.ducasse 5/20/2009 21:19'! argumentCount "Answer the number of arguments that must be used to evaluate this block" ^numArgs ! ! !BlockClosure methodsFor: 'accessing' stamp: 'eem 9/3/2008 13:57'! copiedValueAt: i ^self basicAt: i! ! !BlockClosure methodsFor: 'accessing' stamp: 'eem 7/28/2008 13:58'! home ^outerContext home! ! !BlockClosure methodsFor: 'accessing' stamp: 'ajh 1/21/2003 13:16'! isBlock ^ true! ! !BlockClosure methodsFor: 'accessing' stamp: 'eem 5/29/2008 12:18'! method ^outerContext method! ! !BlockClosure methodsFor: 'accessing' stamp: 'eem 5/28/2008 16:02'! numArgs "Answer the number of arguments that must be used to evaluate this block" ^numArgs! ! !BlockClosure methodsFor: 'accessing' stamp: 'eem 9/3/2008 14:07'! numCopiedValues "Answer the number of copied values of the receiver. Since these are stored in the receiver's indexable fields this is the receiver's basic size. Primitive. Answer the number of indexable variables in the receiver. This value is the same as the largest legal subscript." ^self basicSize! ! !BlockClosure methodsFor: 'accessing' stamp: 'eem 5/24/2008 11:21'! outerContext ^outerContext! ! !BlockClosure methodsFor: 'accessing' stamp: 'eem 6/26/2008 09:17'! receiver ^outerContext receiver! ! !BlockClosure methodsFor: 'accessing' stamp: 'eem 6/1/2008 09:39'! startpc ^startpc! ! !BlockClosure methodsFor: 'controlling' stamp: 'jf 9/3/2003 16:45'! doWhileFalse: conditionBlock "Evaluate the receiver once, then again as long the value of conditionBlock is false." | result | [result := self value. conditionBlock value] whileFalse. ^ result! ! !BlockClosure methodsFor: 'controlling' stamp: 'jf 9/3/2003 16:39'! doWhileTrue: conditionBlock "Evaluate the receiver once, then again as long the value of conditionBlock is true." | result | [result := self value. conditionBlock value] whileTrue. ^ result! ! !BlockClosure methodsFor: 'controlling' stamp: 'sma 5/12/2000 13:22'! repeat "Evaluate the receiver repeatedly, ending only if the block explicitly returns." [self value. true] whileTrue! ! !BlockClosure methodsFor: 'controlling' stamp: 'ls 9/24/1999 09:45'! repeatWithGCIf: testBlock | ans | "run the receiver, and if testBlock returns true, garbage collect and run the receiver again" ans := self value. (testBlock value: ans) ifTrue: [ Smalltalk garbageCollect. ans := self value ]. ^ans! ! !BlockClosure methodsFor: 'controlling'! whileFalse "Ordinarily compiled in-line, and therefore not overridable. This is in case the message is sent to other than a literal block. Evaluate the receiver, as long as its value is false." ^ [self value] whileFalse: []! ! !BlockClosure methodsFor: 'controlling'! whileFalse: aBlock "Ordinarily compiled in-line, and therefore not overridable. This is in case the message is sent to other than a literal block. Evaluate the argument, aBlock, as long as the value of the receiver is false." ^ [self value] whileFalse: [aBlock value]! ! !BlockClosure methodsFor: 'controlling' stamp: 'jcg 7/8/2007 18:25'! whileNil: aBlock "Unlike #whileTrue/False: this is not compiled inline." ^ [self value isNil] whileTrue: [aBlock value] ! ! !BlockClosure methodsFor: 'controlling' stamp: 'jcg 7/8/2007 18:25'! whileNotNil: aBlock "Unlike #whileTrue/False: this is not compiled inline." ^ [self value notNil] whileTrue: [aBlock value] ! ! !BlockClosure methodsFor: 'controlling'! whileTrue "Ordinarily compiled in-line, and therefore not overridable. This is in case the message is sent to other than a literal block. Evaluate the receiver, as long as its value is true." ^ [self value] whileTrue: []! ! !BlockClosure methodsFor: 'controlling'! whileTrue: aBlock "Ordinarily compiled in-line, and therefore not overridable. This is in case the message is sent to other than a literal block. Evaluate the argument, aBlock, as long as the value of the receiver is true." ^ [self value] whileTrue: [aBlock value]! ! !BlockClosure methodsFor: 'copying' stamp: 'eem 5/28/2008 14:53'! postCopy "To render a copy safe we need to provide a new outerContext that cannot be returned from and a copy of any remoteTemp vectors. When a block is active it makes no reference to state in its nested contexts (this is the whole point of the indirect temps scheme; any indirect state is either copied or in indirect temp vectors. So we need to substitute a dummy outerContext and copy the copiedValues, copying anything looking like a remote temp vector. if we accidentally copy an Array that isn't actually an indirect temp vector we do extra work but don't break anything." outerContext := MethodContext sender: nil receiver: outerContext receiver method: outerContext method arguments: #(). self fixTemps! ! !BlockClosure methodsFor: 'debugger access' stamp: 'nice 4/14/2009 19:09'! sender "Answer the context that sent the message that created the receiver." ^outerContext sender! ! !BlockClosure methodsFor: 'error handing' stamp: 'eem 11/26/2008 20:03'! numArgsError: numArgsForInvocation | printNArgs | printNArgs := [:n| n printString, ' argument', (n = 1 ifTrue: [''] ifFalse:['s'])]. self error: 'This block accepts ', (printNArgs value: numArgs), ', but was called with ', (printNArgs value: numArgsForInvocation), '.'! ! !BlockClosure methodsFor: 'evaluating' stamp: 'cmm 2/16/2003 16:08'! bench "See how many times I can value in 5 seconds. I'll answer a meaningful description." | startTime endTime count | count := 0. endTime := Time millisecondClockValue + 5000. startTime := Time millisecondClockValue. [ Time millisecondClockValue > endTime ] whileFalse: [ self value. count := count + 1 ]. endTime := Time millisecondClockValue. ^count = 1 ifTrue: [ ((endTime - startTime) // 1000) printString, ' seconds.' ] ifFalse: [ ((count * 1000) / (endTime - startTime)) asFloat printString, ' per second.' ]! ! !BlockClosure methodsFor: 'evaluating' stamp: 'brp 9/25/2003 13:49'! durationToRun "Answer the duration taken to execute this block." ^ Duration milliSeconds: self timeToRun ! ! !BlockClosure methodsFor: 'evaluating' stamp: 'ajh 1/13/2002 13:36'! ifError: errorHandlerBlock "Evaluate the block represented by the receiver, and normally return it's value. If an error occurs, the errorHandlerBlock is evaluated, and it's value is instead returned. The errorHandlerBlock must accept zero, one, or two parameters (the error message and the receiver)." "Examples: [1 whatsUpDoc] ifError: [:err :rcvr | 'huh?']. [1 / 0] ifError: [:err :rcvr | 'ZeroDivide' = err ifTrue: [Float infinity] ifFalse: [self error: err]] " ^ self on: Error do: [:ex | errorHandlerBlock valueWithPossibleArgs: {ex description. ex receiver}]! ! !BlockClosure methodsFor: 'evaluating' stamp: 'eem 9/5/2009 13:05'! simulateValueWithArguments: anArray caller: aContext | newContext sz | (anArray class ~~ Array or: [numArgs ~= anArray size]) ifTrue: [^ContextPart primitiveFailToken]. newContext := (MethodContext newForMethod: outerContext method) setSender: aContext receiver: outerContext receiver method: outerContext method closure: self startpc: startpc. sz := self basicSize. newContext stackp: sz + numArgs. 1 to: numArgs do: [:i| newContext at: i put: (anArray at: i)]. 1 to: sz do: [:i| newContext at: i + numArgs put: (self at: i)]. ^newContext! ! !BlockClosure methodsFor: 'evaluating' stamp: 'jm 6/3/1998 14:25'! timeToRun "Answer the number of milliseconds taken to execute this block." ^ Time millisecondsToRun: self ! ! !BlockClosure methodsFor: 'evaluating' stamp: 'eem 9/3/2008 14:09'! value "Activate the receiver, creating a closure activation (MethodContext) whose closure is the receiver and whose caller is the sender of this message. Supply the copied values to the activation as its arguments and copied temps. Primitive. Optional (but you're going to want this for performance)." | newContext ncv | numArgs ~= 0 ifTrue: [self numArgsError: 0]. newContext := self asContextWithSender: thisContext sender. (ncv := self numCopiedValues) > 0 ifTrue: [newContext stackp: ncv. 1 to: ncv do: "nil basicSize = 0" [:i| newContext at: i put: (self at: i)]]. thisContext privSender: newContext! ! !BlockClosure methodsFor: 'evaluating' stamp: 'eem 9/3/2008 14:09'! value: anArg "Activate the receiver, creating a closure activation (MethodContext) whose closure is the receiver and whose caller is the sender of this message. Supply the argument and copied values to the activation as its arguments and copied temps. Primitive. Optional (but you're going to want this for performance)." | newContext ncv | numArgs ~= 1 ifTrue: [self numArgsError: 1]. newContext := self asContextWithSender: thisContext sender. ncv := self numCopiedValues. newContext stackp: ncv + 1. newContext at: 1 put: anArg. 1 to: ncv do: [:i| newContext at: i + 1 put: (self at: i)]. thisContext privSender: newContext! ! !BlockClosure methodsFor: 'evaluating' stamp: 'eem 9/3/2008 14:10'! value: firstArg value: secondArg "Activate the receiver, creating a closure activation (MethodContext) whose closure is the receiver and whose caller is the sender of this message. Supply the arguments and copied values to the activation as its arguments and copied temps. Primitive. Optional (but you're going to want this for performance)." | newContext ncv | numArgs ~= 2 ifTrue: [self numArgsError: 2]. newContext := self asContextWithSender: thisContext sender. ncv := self numCopiedValues. newContext stackp: ncv + 2. newContext at: 1 put: firstArg. newContext at: 2 put: secondArg. 1 to: ncv do: [:i| newContext at: i + 2 put: (self at: i)]. thisContext privSender: newContext! ! !BlockClosure methodsFor: 'evaluating' stamp: 'eem 9/3/2008 14:11'! value: firstArg value: secondArg value: thirdArg "Activate the receiver, creating a closure activation (MethodContext) whose closure is the receiver and whose caller is the sender of this message. Supply the arguments and copied values to the activation as its arguments and copied temps. Primitive. Optional (but you're going to want this for performance)." | newContext ncv | numArgs ~= 3 ifTrue: [self numArgsError: 3]. newContext := self asContextWithSender: thisContext sender. ncv := self numCopiedValues. newContext stackp: ncv + 3. newContext at: 1 put: firstArg. newContext at: 2 put: secondArg. newContext at: 3 put: thirdArg. 1 to: ncv do: [:i| newContext at: i + 3 put: (self at: i)]. thisContext privSender: newContext! ! !BlockClosure methodsFor: 'evaluating' stamp: 'eem 9/3/2008 14:11'! value: firstArg value: secondArg value: thirdArg value: fourthArg "Activate the receiver, creating a closure activation (MethodContext) whose closure is the receiver and whose caller is the sender of this message. Supply the arguments and copied values to the activation as its arguments and copied temps. Primitive. Optional (but you're going to want this for performance)." | newContext ncv | numArgs ~= 4 ifTrue: [self numArgsError: 4]. newContext := self asContextWithSender: thisContext sender. ncv := self numCopiedValues. newContext stackp: ncv + 4. newContext at: 1 put: firstArg. newContext at: 2 put: secondArg. newContext at: 3 put: thirdArg. newContext at: 4 put: fourthArg. 1 to: ncv do: [:i| newContext at: i + 4 put: (self at: i)]. thisContext privSender: newContext! ! !BlockClosure methodsFor: 'evaluating' stamp: 'al 4/3/2009 18:22'! valueAt: blockPriority "Evaluate the receiver (block), with another priority as the actual one and restore it afterwards. The caller should be careful with using higher priorities." | activeProcess result outsidePriority | activeProcess := Processor activeProcess. outsidePriority := activeProcess priority. activeProcess priority: blockPriority. result := self ensure: [activeProcess priority: outsidePriority]. "Yield after restoring lower priority to give the preempted processes a chance to run." blockPriority > outsidePriority ifTrue: [Processor yield]. ^ result! ! !BlockClosure methodsFor: 'evaluating' stamp: 'eem 8/22/2008 14:21'! valueNoContextSwitch "An exact copy of BlockClosure>>value except that this version will not preempt the current process on block activation if a higher-priority process is runnable. Primitive. Essential." numArgs ~= 0 ifTrue: [self numArgsError: 0]. self primitiveFailed! ! !BlockClosure methodsFor: 'evaluating' stamp: 'eem 8/22/2008 14:21'! valueNoContextSwitch: anArg "An exact copy of BlockClosure>>value: except that this version will not preempt the current process on block activation if a higher-priority process is runnable. Primitive. Essential." numArgs ~= 1 ifTrue: [self numArgsError: 1]. self primitiveFailed! ! !BlockClosure methodsFor: 'evaluating' stamp: 'al 4/3/2009 18:23'! valueSupplyingAnswer: anObject ^ (anObject isCollection and: [anObject isString not]) ifTrue: [self valueSupplyingAnswers: {anObject}] ifFalse: [self valueSupplyingAnswers: {{'*'. anObject}}]! ! !BlockClosure methodsFor: 'evaluating' stamp: 'al 4/3/2009 18:24'! valueSupplyingAnswers: aListOfPairs "evaluate the block using a list of questions / answers that might be called upon to automatically respond to Object>>confirm: or FillInTheBlank requests" ^ [self value] on: ProvideAnswerNotification do: [:notify | | answer caption | caption := notify messageText withSeparatorsCompacted. "to remove new lines" answer := aListOfPairs detect: [:each | caption = each first or: [(caption includesSubstring: each first caseSensitive: false) or: [(each first match: caption) or: [(String includesSelector: #matchesRegex:) and: [caption matchesRegex: each first]]]]] ifNone: [nil]. answer ifNotNil: [notify resume: answer second] ifNil: [ | outerAnswer | outerAnswer := ProvideAnswerNotification signal: notify messageText. outerAnswer ifNil: [notify resume] ifNotNil: [notify resume: outerAnswer]]]! ! !BlockClosure methodsFor: 'evaluating' stamp: 'jrp 10/10/2004 22:28'! valueSuppressingAllMessages ^ self valueSuppressingMessages: #('*')! ! !BlockClosure methodsFor: 'evaluating' stamp: 'al 4/3/2009 18:24'! valueSuppressingMessages: aListOfStrings ^ self valueSuppressingMessages: aListOfStrings supplyingAnswers: #()! ! !BlockClosure methodsFor: 'evaluating' stamp: 'al 4/3/2009 18:24'! valueSuppressingMessages: aListOfStrings supplyingAnswers: aListOfPairs ^ self valueSupplyingAnswers: aListOfPairs, (aListOfStrings collect: [:each | {each. true}])! ! !BlockClosure methodsFor: 'evaluating' stamp: 'eem 9/3/2008 14:08'! valueWithArguments: anArray "Activate the receiver, creating a closure activation (MethodContext) whose closure is the receiver and whose caller is the sender of this message. Supply the arguments in an anArray and copied values to the activation as its arguments and copied temps. Primitive. Optional (but you're going to want this for performance)." | newContext ncv | numArgs ~= anArray size ifTrue: [self numArgsError: anArray size]. newContext := self asContextWithSender: thisContext sender. ncv := self numCopiedValues. newContext stackp: ncv + numArgs. 1 to: numArgs do: [:i| newContext at: i put: (anArray at: i)]. 1 to: ncv do: [:i| newContext at: i + numArgs put: (self at: i)]. thisContext privSender: newContext! ! !BlockClosure methodsFor: 'evaluating' stamp: 'nk 3/11/2001 11:49'! valueWithEnoughArguments: anArray "call me with enough arguments from anArray" | args | (anArray size == self numArgs) ifTrue: [ ^self valueWithArguments: anArray ]. args := Array new: self numArgs. args replaceFrom: 1 to: (anArray size min: args size) with: anArray startingAt: 1. ^ self valueWithArguments: args! ! !BlockClosure methodsFor: 'evaluating' stamp: 'md 3/28/2006 20:17'! valueWithExit self value: [ ^nil ]! ! !BlockClosure methodsFor: 'evaluating' stamp: 'eem 5/28/2008 15:03'! valueWithPossibleArgs: anArray ^numArgs = 0 ifTrue: [self value] ifFalse: [self valueWithArguments: (numArgs = anArray size ifTrue: [anArray] ifFalse: [numArgs > anArray size ifTrue: [anArray, (Array new: numArgs - anArray size)] ifFalse: [anArray copyFrom: 1 to: numArgs]])]! ! !BlockClosure methodsFor: 'evaluating' stamp: 'eem 5/25/2008 14:47'! valueWithPossibleArgument: anArg "Evaluate the block represented by the receiver. If the block requires one argument, use anArg, if it requires more than one, fill up the rest with nils." | a | numArgs = 0 ifTrue: [^self value]. numArgs = 1 ifTrue: [^self value: anArg]. a := Array new: numArgs. a at: 1 put: anArg. ^self valueWithArguments: a! ! !BlockClosure methodsFor: 'evaluating' stamp: 'ar 8/17/2007 13:15'! valueWithin: aDuration onTimeout: timeoutBlock "Evaluate the receiver. If the evaluation does not complete in less than aDuration evaluate the timeoutBlock instead" | theProcess delay watchdog | aDuration <= Duration zero ifTrue: [^ timeoutBlock value ]. "the block will be executed in the current process" theProcess := Processor activeProcess. delay := aDuration asDelay. "make a watchdog process" watchdog := [ delay wait. "wait for timeout or completion" theProcess ifNotNil:[ theProcess signalException: TimedOut ] ] newProcess. "Watchdog needs to run at high priority to do its job (but not at timing priority)" watchdog priority: Processor timingPriority-1. "catch the timeout signal" ^ [ watchdog resume. "start up the watchdog" self ensure:[ "evaluate the receiver" theProcess := nil. "it has completed, so ..." delay delaySemaphore signal. "arrange for the watchdog to exit" ]] on: TimedOut do: [ :e | timeoutBlock value ]. ! ! !BlockClosure methodsFor: 'exceptions' stamp: 'sma 5/11/2000 19:38'! assert self assert: self! ! !BlockClosure methodsFor: 'exceptions' stamp: 'eem 8/22/2008 14:22'! ensure: aBlock "Evaluate a termination block after evaluating the receiver, regardless of whether the receiver's evaluation completes." | returnValue b | returnValue := self valueNoContextSwitch. "aBlock wasn't nil when execution of this method began; it is nil'd out by the unwind machinery, and that's how we know it's already been evaluated ... otherwise, obviously, it needs to be evaluated" aBlock == nil ifFalse: [ "nil out aBlock temp before evaluating aBlock so it is not executed again if aBlock remote returns" b := aBlock. thisContext tempAt: 1 put: nil. "Could be aBlock := nil, but arguments cannot be modified" b value. ]. ^ returnValue! ! !BlockClosure methodsFor: 'exceptions' stamp: 'eem 8/22/2008 14:29'! ifCurtailed: aBlock "Evaluate the receiver with an abnormal termination action. Evaluate aBlock only if execution is unwound during execution of the receiver. If execution of the receiver finishes normally do not evaluate aBlock." ^self valueNoContextSwitch! ! !BlockClosure methodsFor: 'exceptions' stamp: 'ajh 2/1/2003 00:30'! on: exception do: handlerAction "Evaluate the receiver in the scope of an exception handler." | handlerActive | "just a marker, fail and execute the following" handlerActive := true. ^ self value! ! !BlockClosure methodsFor: 'exceptions' stamp: 'ajh 10/9/2001 16:51'! onDNU: selector do: handleBlock "Catch MessageNotUnderstood exceptions but only those of the given selector (DNU stands for doesNotUnderstand:)" ^ self on: MessageNotUnderstood do: [:exception | exception message selector = selector ifTrue: [handleBlock valueWithPossibleArgs: {exception}] ifFalse: [exception pass] ]! ! !BlockClosure methodsFor: 'exceptions' stamp: 'ajh 7/26/2002 11:49'! valueUninterruptably "Prevent remote returns from escaping the sender. Even attempts to terminate (unwind) this process will be halted and the process will resume here. A terminate message is needed for every one of these in the sender chain to get the entire process unwound." ^ self ifCurtailed: [^ self]! ! !BlockClosure methodsFor: 'initialize-release' stamp: 'eem 9/3/2008 14:08'! outerContext: aContext startpc: aStartpc numArgs: argCount copiedValues: anArrayOrNil outerContext := aContext. startpc := aStartpc. numArgs := argCount. 1 to: self numCopiedValues do: [:i| self at: i put: (anArrayOrNil at: i)]! ! !BlockClosure methodsFor: 'printing' stamp: 'stephane.ducasse 4/21/2009 11:52'! asText ^ self asString asText! ! !BlockClosure methodsFor: 'printing' stamp: 'eem 7/28/2008 14:06'! decompile ^Decompiler new decompileBlock: self! ! !BlockClosure methodsFor: 'printing' stamp: 'eem 7/28/2008 14:09'! fullPrintOn: aStream aStream print: self; cr. (self decompile ifNil: ['--source missing--']) printOn: aStream indent: 0! ! !BlockClosure methodsFor: 'printing' stamp: 'eem 5/24/2008 11:23'! printOn: aStream aStream nextPutAll: '[closure] in '. outerContext printOn: aStream! ! !BlockClosure methodsFor: 'scheduling' stamp: 'eem 5/28/2008 16:16'! asContext "Create a MethodContext that is ready to execute self. Assumes self takes no args (if it does the args will be nil)" ^self asContextWithSender: nil! ! !BlockClosure methodsFor: 'scheduling' stamp: 'ajh 7/15/2001 16:03'! fork "Create and schedule a Process running the code in the receiver." ^ self newProcess resume! ! !BlockClosure methodsFor: 'scheduling' stamp: 'ajh 10/16/2002 11:14'! forkAndWait "Suspend current process and execute self in new process, when it completes resume current process" | semaphore | semaphore := Semaphore new. [self ensure: [semaphore signal]] fork. semaphore wait. ! ! !BlockClosure methodsFor: 'scheduling' stamp: 'ajh 9/29/2001 21:00'! forkAt: priority "Create and schedule a Process running the code in the receiver at the given priority. Answer the newly created process." ^ self newProcess priority: priority; resume! ! !BlockClosure methodsFor: 'scheduling' stamp: 'svp 6/23/2003 10:59'! forkAt: priority named: name "Create and schedule a Process running the code in the receiver at the given priority and having the given name. Answer the newly created process." | forkedProcess | forkedProcess := self newProcess. forkedProcess priority: priority. forkedProcess name: name. ^ forkedProcess resume! ! !BlockClosure methodsFor: 'scheduling' stamp: 'svp 6/23/2003 10:59'! forkNamed: aString "Create and schedule a Process running the code in the receiver and having the given name." ^ self newProcess name: aString; resume! ! !BlockClosure methodsFor: 'scheduling' stamp: 'ajh 2/10/2003 14:25'! newProcess "Answer a Process running the code in the receiver. The process is not scheduled." "Simulation guard" ^Process forContext: [self value. Processor terminateActive] asContext priority: Processor activePriority! ! !BlockClosure methodsFor: 'scheduling' stamp: 'marcus.denker 6/10/2009 20:28'! newProcessWith: anArray "Answer a Process running the code in the receiver. The receiver's block arguments are bound to the contents of the argument, anArray. The process is not scheduled." "Simulation guard" ^Process forContext: [self valueWithArguments: anArray. Processor terminateActive] asContext priority: Processor activePriority! ! !BlockClosure methodsFor: 'testing' stamp: 'eem 5/29/2008 12:20'! hasMethodReturn "Answer whether the receiver has a method-return ('^') in its code." | myMethod scanner preceedingBytecodeMessage end | "Determine end of block from the instruction preceding it. Find the instruction by using an MNU handler to capture the instruction message sent by the scanner." myMethod := outerContext method. scanner := InstructionStream new method: myMethod pc: myMethod initialPC. [scanner pc < startpc] whileTrue: [[scanner interpretNextInstructionFor: nil] on: MessageNotUnderstood do: [:ex| preceedingBytecodeMessage := ex message]]. end := preceedingBytecodeMessage arguments last + startpc - 1. scanner method: myMethod pc: startpc. scanner scanFor: [:byte | (byte between: 120 and: 124) or: [scanner pc > end]]. ^scanner pc <= end! ! !BlockClosure methodsFor: 'testing' stamp: 'eem 5/23/2008 13:48'! isClosure ^true! ! !BlockClosure methodsFor: 'testing' stamp: 'eem 11/26/2008 20:27'! isDead "Has self finished" ^false! ! !BlockClosure methodsFor: 'private' stamp: 'eem 6/11/2008 11:38'! asContextWithSender: aContext "Inner private support method for evaluation. Do not use unless you know what you're doing." ^(MethodContext newForMethod: outerContext method) setSender: aContext receiver: outerContext receiver method: outerContext method closure: self startpc: startpc! ! !BlockClosure methodsFor: 'private' stamp: 'sd 3/22/2009 19:33'! asMinimalRepresentation "Answer the receiver." ^self! ! !BlockClosure methodsFor: 'private' stamp: 'eem 5/28/2008 14:50'! copyForSaving "Answer a copy of the receiver suitable for serialization. Notionally, if the receiver's outerContext has been returned from then nothing needs to be done and we can use the receiver. But there's a race condition determining if the receiver has been returned from (it could be executing in a different process). So answer a copy anyway." ^self shallowCopy postCopy! ! !BlockClosure methodsFor: 'private' stamp: 'eem 12/14/2008 16:47'! fixTemps "Fix the values of the temporary variables used in the block that are ordinarily shared with the method in which the block is defined. This is a no-op for closures, provided for backward-compatibility with old BlockContexts that needed the fixTemps hack to persist."! ! !BlockClosure methodsFor: 'private' stamp: 'sd 3/22/2009 19:33'! isValid "Answer the receiver." ^true! ! !BlockClosure methodsFor: 'private' stamp: 'eem 5/28/2008 14:56'! reentrant "Answer a version of the recever that can be reentered. Closures are reentrant (unlike BlockContect) so simply answer self." ^self! ! !BlockClosure methodsFor: 'private' stamp: 'ar 3/2/2001 01:16'! valueUnpreemptively "Evaluate the receiver (block), without the possibility of preemption by higher priority processes. Use this facility VERY sparingly!!" "Think about using Block>>valueUninterruptably first, and think about using Semaphore>>critical: before that, and think about redesigning your application even before that!! After you've done all that thinking, go right ahead and use it..." | activeProcess oldPriority result | activeProcess := Processor activeProcess. oldPriority := activeProcess priority. activeProcess priority: Processor highestPriority. result := self ensure: [activeProcess priority: oldPriority]. "Yield after restoring priority to give the preempted processes a chance to run" Processor yield. ^result! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! BlockClosure class instanceVariableNames: ''! !BlockClosure class methodsFor: 'instance creation' stamp: 'eem 9/3/2008 14:02'! outerContext: aContext startpc: aStartpc numArgs: argCount copiedValues: anArrayOrNil ^(self new: anArrayOrNil basicSize) outerContext: aContext startpc: aStartpc numArgs: argCount copiedValues: anArrayOrNil! ! TestCase subclass: #BlockClosuresTestCase instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'KernelTests-Methods'! !BlockClosuresTestCase commentStamp: '' prior: 0! This test case collects examples for block uses that require full block closures.! !BlockClosuresTestCase methodsFor: 'examples' stamp: 'rw 1/26/2002 01:20'! constructCannotReturnBlockInDeadFrame ^ [:arg | ^arg]. ! ! !BlockClosuresTestCase methodsFor: 'examples' stamp: 'rw 1/26/2002 01:14'! constructFibonacciBlockInDeadFrame | fib | fib := [:val | (val <= 0) ifTrue: [self error: 'not a natural number']. (val <= 2) ifTrue: [1] ifFalse: [(fib value: (val - 1)) + (fib value: (val - 2))]]. ^fib ! ! !BlockClosuresTestCase methodsFor: 'examples' stamp: 'rw 1/26/2002 01:14'! constructFibonacciBlockWithBlockArgumentInDeadFrame ^ [:val :blk | (val <= 0) ifTrue: [self error: 'not a natural number']. (val <= 2) ifTrue: [1] ifFalse: [(blk value: (val - 1) value: blk) + (blk value: (val - 2) value: blk)]]. ! ! !BlockClosuresTestCase methodsFor: 'examples' stamp: 'rw 1/26/2002 01:15'! constructSharedClosureEnvironmentInDeadFrame |array result| result := 10. array := Array new: 2. array at: 1 put: [:arg | result := arg]. array at: 2 put: [result]. ^array ! ! !BlockClosuresTestCase methodsFor: 'examples' stamp: 'BG 1/24/2002 17:44'! continuationExample1: aCollection " see comment below. Here we simply collect the values of a value with continuation block " | streamCreator collector | streamCreator := [:collection | | i localBlock | i := 1. localBlock := [ | current | current := collection at: i. i := i + 1. Array with: current with: (i<= collection size ifTrue: [localBlock] ifFalse: [nil]) ]. ]. collector := [:valueWithContinuation | | oc | oc := OrderedCollection new. [ | local | local := valueWithContinuation value. oc add: local first. local last notNil] whileTrue: []. oc. ]. ^collector value: (streamCreator value: aCollection). "The continuation examples are examples of a 'back to LISP' style. These examples use blocks to process the elements of a collection in a fashion that is similar to streaming. The creator block creates a blocks that act like a stream. In the following, this block is called a 'value with continuation block'. When such a value with continuation block receives the message value, it returns a Array of two elements, the value and the continuation 1. the next collection element 2. a so-called continuation, which is either nil or a block that can return the next value with continuation. To collect all elements of a value with continuation stream, use the collector block. " ! ! !BlockClosuresTestCase methodsFor: 'examples' stamp: 'BG 1/24/2002 17:44'! continuationExample2: aCollection " see comment in method continuationExample1:. The block named 'processor' takes a value with contiuation and a processing block. It creates a new value with continuation. Again we use a collector to collect all values. " | stream processor collector | stream := [:collection | | i localBlock | i := 1. localBlock := [ | current | current := collection at: i. i := i + 1. Array with: current with: (i<= collection size ifTrue: [localBlock] ifFalse: [nil]) ]. ]. processor := [:valueWithContinuation :activity | | localBlock | localBlock := [ | current | current := valueWithContinuation value. Array with: (activity value: current first) with: (current last notNil ifTrue: [localBlock])]. localBlock ]. collector := [:valueWithContinuation | | oc | oc := OrderedCollection new. [ | local | local := valueWithContinuation value. oc add: local first. local last notNil] whileTrue: []. oc. ]. ^collector value: (processor value: (stream value: aCollection) value: [:x | x * x]).! ! !BlockClosuresTestCase methodsFor: 'examples' stamp: 'BG 1/24/2002 17:27'! continuationExample3: aCollection " see comment in method continuationExample1:. The block named 'processor' takes a value with contiuation and a processing block. It creates a new value with continuation. Here we set up a chain of three values with continuation: one data source and two value processors. Again we use a collector to collect all values. " | stream processor collector | stream := [:collection | | i localBlock | i := 1. localBlock := [ | current | current := collection at: i. i := i + 1. Array with: current with: (i<= collection size ifTrue: [localBlock] ifFalse: [nil]) ]. ]. processor := [:valueWithContinuation :activity | | localBlock | localBlock := [ | current | current := valueWithContinuation value. Array with: (activity value: current first) with: (current last notNil ifTrue: [localBlock])]. localBlock ]. collector := [:valueWithContinuation | | oc | oc := OrderedCollection new. [ | local | local := valueWithContinuation value. oc add: local first. local last notNil] whileTrue: []. oc. ]. ^collector value: (processor value: (processor value: (stream value: aCollection) value: [:x | x * x]) value: [:x | x - 10]).! ! !BlockClosuresTestCase methodsFor: 'examples' stamp: 'BG 1/24/2002 17:44'! example1: anInteger " this example is very simple. A named block recursively computes the factorial. The example tests whether the value of x is still available after the recursive call. Note that the recursive call precedes the multiplication. For the purpose of the test this is essential. (When you commute the factors, the example will work also in some system without block closures, but not in Squeak.) " | factorial | factorial := [:x | x = 1 ifTrue: [1] ifFalse: [(factorial value: x - 1)* x]]. ^ factorial value: anInteger ! ! !BlockClosuresTestCase methodsFor: 'examples' stamp: 'lr 3/31/2009 09:31'! example2: anInteger " BlockClosuresTestCase new example2: 6" " to complicate the example1, we set up a dynamic reference chain that is used to dump all calls of facorial when recursion depth is maximal. The return value is an instance of orderedCollection, the trace. " | factorial trace | trace := OrderedCollection new. factorial := [:x :dumper :trace2 | | localDumper | localDumper := [ :collection | collection add: x. dumper value: collection.]. x = 1 ifTrue: [localDumper value: trace2. 1] ifFalse: [(factorial value: x - 1 value: localDumper value: trace2)* x. ] ]. factorial value: anInteger value: [ :collection | ] value: trace. ^trace! ! !BlockClosuresTestCase methodsFor: 'examples' stamp: 'PeterHugossonMiller 9/2/2009 16:19'! nestedLoopsExample: arrays " A while ago, Hans Baveco asked for a way to dynamically nest loops. Better solutions than this one were proposed, but this one is a beautiful test for recursive block usage. " | result sizeOfResult streams block | "arrays := OrderedCollection new. arrays add: #(#a #b); add: #(1 2 3 4); add: #('w' 'x' 'y' 'z')." sizeOfResult := arrays inject: 1 into: [:prod :array | prod * array size]. streams := arrays collect: [:a | a readStream]. " This is an OrderedCollection of Streams " result := OrderedCollection new: sizeOfResult. block := [:r :tupel :allStreams | | innerBlock | innerBlock := [:myIdx | [myIdx = allStreams size ifTrue: [1 to: allStreams size do: [:i | tupel at: i put: (allStreams at: i) peek]. r addLast: tupel shallowCopy] ifFalse: [innerBlock value: myIdx + 1]. (allStreams at: myIdx) next. (allStreams at: myIdx) atEnd ] whileFalse: []. (allStreams at: myIdx) reset. ]. innerBlock value: 1. r ]. block value: result value: (Array new: streams size) " this is a buffer " value: streams. ^result ! ! !BlockClosuresTestCase methodsFor: 'jensen device examples' stamp: 'BG 1/25/2002 10:01'! comment " The Jensen device was something very sophisticated in the days of Algol 60. Essentially it was tricky use of a parameter passing policy that was called 'call by name'. In modern terminology, a call by name parameter was a pair of blocks (in a system with full block closures, of course.) For the lovers of Algol 60, here is a short example: BEGIN REAL PROCEDURE JensenSum (A, I, N); REAL A; INTEGER I, N; BEGIN REAL S; S := 0.0; FOR I := 1 STEP 1 UNTIL N DO S := S + A; JensenSum := S; END; ARRAY X [1:10], Y[1:10, 1:10]; COMMENT Do array initialization here ; JensenSum (X[I], I, 10); JensenSum (Y[I, I], I, 10); JensenSum(JensenSum(Y[I, J], J, 10), I, 10); END; The first call sums the elements of X, the second sums the diagonal elements of Y and the third call sums up all elements of Y. It is possible to reimplement all this with blocks only and that is what is done in the jensen device examples. Additional remark: The Jensen device was something for clever minds. I remember an artice written by Donald Knuth and published in the Communications of the ACM (I think in 1962, but I may err) about that programming trick. That article showed how a simple procedure (called the general problem solver) could be used to do almost anything. The problem was of course to find out the right parameters. I seached my collection of photocopies for that article, but regrettably I could not find it. Perhaps I can find it later. "! ! !BlockClosuresTestCase methodsFor: 'jensen device examples' stamp: 'BG 1/24/2002 18:00'! gpsExample1: aCollection " BlockClosuresTestCase new gpsExample1: (1 to: 100) asArray" | gps i s | gps := [:idx :exp :sum | | cnt | cnt := 1. sum first value: 0. [idx first value: cnt. sum first value: (sum last value + exp last value). cnt := cnt + 1. cnt <= aCollection size] whileTrue: [ ]. sum last value ]. ^gps value: (Array with: [:val | i := val] with: [ i]) value: (Array with: [:val | aCollection at: i put: val] with: [ aCollection at: i]) value: (Array with: [:val | s := val] with: [ s]) ! ! !BlockClosuresTestCase methodsFor: 'jensen device examples' stamp: 'BG 1/25/2002 10:03'! gpsExample2: aCollection " BlockClosuresTestCase new gpsExample2: #(#(1 2 3 4 5) #(6 7 8 9 10) #(11 12 13 14 15) #(16 17 18 19 20) #(21 22 23 24 25))" | js i j | " js is the translation of the Algol procedure from method comment. " js := [:a :idx :n | | sum | sum := 0. idx first value: 1. [idx last value <= n last value] whileTrue: [sum := sum + a last value. idx first value: idx last value + 1.]. sum ]. " This is the most complicated call that is mentioned in method comment. Note that js is called recursively. " ^ js value: (Array with: [:val | self error: 'can not assign to procedure'] with: [ js value: (Array with: [:val | (aCollection at: i) at: j put: val] with: [ (aCollection at: i) at: j]) value: (Array with:[:val | j := val] with: [ j]) value: (Array with: [:val | self error: 'can not assign to constant'] with: [ aCollection size]) ] ) value: (Array with:[:val | i := val] with: [ i]) value: (Array with: [:val | self error: 'can not assign to constant'] with: [ aCollection size]) ! ! !BlockClosuresTestCase methodsFor: 'testing' stamp: 'rw 1/26/2002 01:22'! testCannotReturn | blk | blk := self constructCannotReturnBlockInDeadFrame. self should: [blk value: 1] raise: Exception ! ! !BlockClosuresTestCase methodsFor: 'testing' stamp: 'BG 1/24/2002 17:45'! testContinuationExample1 | array | array := (1 to: 20) asOrderedCollection. self assert: ((self continuationExample1: array) = array) ! ! !BlockClosuresTestCase methodsFor: 'testing' stamp: 'BG 1/24/2002 17:45'! testContinuationExample2 | array | array := (1 to: 20) asOrderedCollection. self assert: ((self continuationExample2: array) = (array collect: [:x | x * x])) ! ! !BlockClosuresTestCase methodsFor: 'testing' stamp: 'BG 1/24/2002 17:45'! testContinuationExample3 | array | array := (1 to: 20) asOrderedCollection. self assert: ((self continuationExample3: array) = (array collect: [:x | x * x - 10])) ! ! !BlockClosuresTestCase methodsFor: 'testing' stamp: 'BG 1/24/2002 16:05'! testExample1 self assert: ((self example1: 5) = 5 factorial) ! ! !BlockClosuresTestCase methodsFor: 'testing' stamp: 'BG 1/24/2002 18:28'! testExample2 self assert: ((self example2: 5) = (1 to: 5) asOrderedCollection) ! ! !BlockClosuresTestCase methodsFor: 'testing' stamp: 'BG 1/24/2002 17:59'! testGpsExample1 | result array | array := (1 to: 100) asArray. result := array inject: 0 into: [:sum :val | sum + val]. self assert: ((self gpsExample1: array) = result) ! ! !BlockClosuresTestCase methodsFor: 'testing' stamp: 'BG 1/25/2002 09:57'! testGpsExample2 | result array | " integer matrix elements should be used for the purpose of this test. " array := #(#(1 2 3 4 5) #(6 7 8 9 10) #(11 12 13 14 15) #(16 17 18 19 20) #(21 22 23 24 25)). result := array inject: 0 into: [:sum :subarray | sum + (subarray inject: 0 into: [:s :elem | s + elem])]. self assert: ((self gpsExample2: array) = result) ! ! !BlockClosuresTestCase methodsFor: 'testing' stamp: 'BG 1/24/2002 16:40'! testNestedLoopsExample1 | arrays result | arrays := OrderedCollection new. arrays add: #(#a #b); add: #(1 2 3 4); add: #('w' 'x' 'y' 'z'). result := OrderedCollection new. CollectionCombinator new forArrays: arrays processWith: [:item |result addLast: item]. self assert: ((self nestedLoopsExample: arrays) = result) ! ! !BlockClosuresTestCase methodsFor: 'testing' stamp: 'rw 1/26/2002 01:17'! testReentrantBlock | fib | fib := [:val | (val <= 0) ifTrue: [self error: 'not a natural number']. (val <= 2) ifTrue: [1] ifFalse: [(fib value: (val - 1)) + (fib value: (val - 2))]]. self should: [fib value: 0] raise: TestResult error. self assert: ((fib value: 1) == 1). self assert: ((fib value: 2) == 1). self assert: ((fib value: 3) == 2). self assert: ((fib value: 4) == 3). self assert: ((fib value: 5) == 5). self assert: ((fib value: 6) == 8). ! ! !BlockClosuresTestCase methodsFor: 'testing' stamp: 'rw 1/26/2002 01:17'! testReentrantBlockOldEnvironment | fib | fib := self constructFibonacciBlockInDeadFrame. self should: [fib value: 0] raise: TestResult error. self assert: ((fib value: 1) == 1). self assert: ((fib value: 2) == 1). self assert: ((fib value: 3) == 2). self assert: ((fib value: 4) == 3). self assert: ((fib value: 5) == 5). self assert: ((fib value: 6) == 8). ! ! !BlockClosuresTestCase methodsFor: 'testing' stamp: 'rw 1/26/2002 01:18'! testReentrantBlockOldEnvironmentWithBlockArguement | fib | fib := self constructFibonacciBlockWithBlockArgumentInDeadFrame. self should: [fib value: 0 value: fib] raise: TestResult error. self assert: ((fib value: 1 value: fib) == 1). self assert: ((fib value: 2 value: fib) == 1). self assert: ((fib value: 3 value: fib) == 2). self assert: ((fib value: 4 value: fib) == 3). self assert: ((fib value: 5 value: fib) == 5). self assert: ((fib value: 6 value: fib) == 8). ! ! !BlockClosuresTestCase methodsFor: 'testing' stamp: 'rw 1/26/2002 01:18'! testSharedClosureEnvironment |blockArray| blockArray := self constructSharedClosureEnvironmentInDeadFrame. self assert: ((blockArray at: 2) value == 10). self assert: (((blockArray at: 1) value: 5) == 5). self assert: ((blockArray at: 2) value == 5). ! ! ContextPart variableSubclass: #BlockContext instanceVariableNames: 'nargs startpc home' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Methods'! !BlockContext commentStamp: '' prior: 0! My instances function similarly to instances of MethodContext, but they hold the dynamic state for execution of a block in Smalltalk. They access all temporary variables and the method sender via their home pointer, so that those values are effectively shared. Their indexable part is used to store their independent value stack during execution. My instance must hold onto its home in order to work. This can cause circularities if the home is also pointing (via a temp, perhaps) to the instance. In the rare event that this happens (as in SortedCollection sortBlock:) the message fixTemps will replace home with a copy of home, thus defeating the sharing of temps but, nonetheless, eliminating the circularity. BlockContexts must only be created using the method newForMethod:. Note that it is impossible to determine the real object size of a BlockContext except by asking for the frameSize of its method. Any fields above the stack pointer (stackp) are truly invisible -- even (and especially!!) to the garbage collector. Any store into stackp other than by the primitive method stackp: is potentially fatal.! !BlockContext methodsFor: '*Polymorph-EventEnhancements' stamp: 'gvc 10/26/2005 16:16'! asMinimalRepresentation "Answer the receiver." ^self! ! !BlockContext methodsFor: '*Polymorph-EventEnhancements' stamp: 'gvc 10/26/2005 15:52'! isValid "Answer true so we can be used in event dispatching." ^true! ! !BlockContext methodsFor: '*services-base' stamp: 'rr 3/21/2006 11:53'! valueWithRequestor: aRequestor "To do later: make the fillInTheBlank display more informative captions. Include the description of the service, and maybe record steps" ^ self numArgs isZero ifTrue: [self value] ifFalse: [self value: aRequestor]! ! !BlockContext methodsFor: '*splitjoin' stamp: 'onierstrasz 4/12/2009 20:12'! split: aSequenceableCollection | result position | result := OrderedCollection new. position := 1. aSequenceableCollection withIndexDo: [:element :idx | (self value: element) ifTrue: [result add: (aSequenceableCollection copyFrom: position to: idx - 1). position := idx + 1]]. result add: (aSequenceableCollection copyFrom: position to: aSequenceableCollection size). ^ result! ! !BlockContext methodsFor: 'accessing' stamp: 'eem 5/28/2008 10:43'! activeHome "Search senders for the home context. If the home context is not found on the sender chain answer nil." ^self caller findContextSuchThat: [:ctxt | ctxt = home]! ! !BlockContext methodsFor: 'accessing' stamp: 'GabrielOmarCotelli 5/25/2009 15:52'! argumentCount "Added for ANSI compatibility." ^ self numArgs! ! !BlockContext methodsFor: 'accessing' stamp: 'eem 5/29/2008 13:14'! caller ^sender! ! !BlockContext methodsFor: 'accessing' stamp: 'eem 5/24/2008 11:20'! closureHome "Answer the context from which an ^-return should return from." ^self home! ! !BlockContext methodsFor: 'accessing' stamp: 'eem 6/15/2008 11:32'! contextForLocalVariables "Answer the context in which local variables (temporaries) are stored." ^home! ! !BlockContext methodsFor: 'accessing' stamp: 'di 9/9/2000 10:44'! copyForSaving "Fix the values of the temporary variables used in the block that are ordinarily shared with the method in which the block is defined." home := home copy. home swapSender: nil! ! !BlockContext methodsFor: 'accessing'! fixTemps "Fix the values of the temporary variables used in the block that are ordinarily shared with the method in which the block is defined." home := home copy. home swapSender: nil! ! !BlockContext methodsFor: 'accessing' stamp: 'md 4/27/2006 15:14'! hasInstVarRef "Answer whether the receiver references an instance variable." | method scanner end printer | home ifNil: [^false]. method := self method. end := self endPC. scanner := InstructionStream new method: method pc: startpc. printer := InstVarRefLocator new. [scanner pc <= end] whileTrue: [ (printer interpretNextInstructionUsing: scanner) ifTrue: [^true]. ]. ^false! ! !BlockContext methodsFor: 'accessing'! hasMethodReturn "Answer whether the receiver has a return ('^') in its code." | method scanner end | method := self method. "Determine end of block from long jump preceding it" end := (method at: startpc-2)\\16-4*256 + (method at: startpc-1) + startpc - 1. scanner := InstructionStream new method: method pc: startpc. scanner scanFor: [:byte | (byte between: 120 and: 124) or: [scanner pc > end]]. ^scanner pc <= end! ! !BlockContext methodsFor: 'accessing'! home "Answer the context in which the receiver was defined." ^home! ! !BlockContext methodsFor: 'accessing' stamp: 'ajh 1/21/2003 13:16'! isBlock ^ true! ! !BlockContext methodsFor: 'accessing' stamp: 'ajh 1/31/2003 12:12'! isExecutingBlock ^ true! ! !BlockContext methodsFor: 'accessing'! method "Answer the compiled method in which the receiver was defined." ^home method! ! !BlockContext methodsFor: 'accessing' stamp: 'eem 6/15/2008 11:33'! methodReturnContext "Answer the context from which an ^-return should return from." ^home! ! !BlockContext methodsFor: 'accessing' stamp: 'mdr 4/10/2001 10:34'! numArgs "Answer the number of arguments that must be used to evaluate this block" ^nargs! ! !BlockContext methodsFor: 'accessing'! receiver "Refer to the comment in ContextPart|receiver." ^home receiver! ! !BlockContext methodsFor: 'accessing' stamp: 'ajh 1/30/2003 15:45'! reentrant "Copy before calling so multiple activations can exist" ^ self copy! ! !BlockContext methodsFor: 'accessing'! tempAt: index "Refer to the comment in ContextPart|tempAt:." ^home at: index! ! !BlockContext methodsFor: 'accessing'! tempAt: index put: value "Refer to the comment in ContextPart|tempAt:put:." ^home at: index put: value! ! !BlockContext methodsFor: 'accessing' stamp: 'md 2/9/2007 19:11'! tempNamed: aName ^self home tempNamed: aName! ! !BlockContext methodsFor: 'accessing' stamp: 'md 2/9/2007 19:12'! tempNamed: aName put: anObject ^self home tempNamed: aName put: anObject! ! !BlockContext methodsFor: 'controlling' stamp: 'jf 9/3/2003 16:45'! doWhileFalse: conditionBlock "Evaluate the receiver once, then again as long the value of conditionBlock is false." | result | [result := self value. conditionBlock value] whileFalse. ^ result! ! !BlockContext methodsFor: 'controlling' stamp: 'jf 9/3/2003 16:39'! doWhileTrue: conditionBlock "Evaluate the receiver once, then again as long the value of conditionBlock is true." | result | [result := self value. conditionBlock value] whileTrue. ^ result! ! !BlockContext methodsFor: 'controlling' stamp: 'sma 5/12/2000 13:22'! repeat "Evaluate the receiver repeatedly, ending only if the block explicitly returns." [self value. true] whileTrue! ! !BlockContext methodsFor: 'controlling' stamp: 'ls 9/24/1999 09:45'! repeatWithGCIf: testBlock | ans | "run the receiver, and if testBlock returns true, garbage collect and run the receiver again" ans := self value. (testBlock value: ans) ifTrue: [ Smalltalk garbageCollect. ans := self value ]. ^ans! ! !BlockContext methodsFor: 'controlling'! whileFalse "Ordinarily compiled in-line, and therefore not overridable. This is in case the message is sent to other than a literal block. Evaluate the receiver, as long as its value is false." ^ [self value] whileFalse: []! ! !BlockContext methodsFor: 'controlling'! whileFalse: aBlock "Ordinarily compiled in-line, and therefore not overridable. This is in case the message is sent to other than a literal block. Evaluate the argument, aBlock, as long as the value of the receiver is false." ^ [self value] whileFalse: [aBlock value]! ! !BlockContext methodsFor: 'controlling'! whileTrue "Ordinarily compiled in-line, and therefore not overridable. This is in case the message is sent to other than a literal block. Evaluate the receiver, as long as its value is true." ^ [self value] whileTrue: []! ! !BlockContext methodsFor: 'controlling'! whileTrue: aBlock "Ordinarily compiled in-line, and therefore not overridable. This is in case the message is sent to other than a literal block. Evaluate the argument, aBlock, as long as the value of the receiver is true." ^ [self value] whileTrue: [aBlock value]! ! !BlockContext methodsFor: 'evaluating' stamp: 'cmm 2/16/2003 16:08'! bench "See how many times I can value in 5 seconds. I'll answer a meaningful description." | startTime endTime count | count := 0. endTime := Time millisecondClockValue + 5000. startTime := Time millisecondClockValue. [ Time millisecondClockValue > endTime ] whileFalse: [ self value. count := count + 1 ]. endTime := Time millisecondClockValue. ^count = 1 ifTrue: [ ((endTime - startTime) // 1000) printString, ' seconds.' ] ifFalse: [ ((count * 1000) / (endTime - startTime)) asFloat printString, ' per second.' ]! ! !BlockContext methodsFor: 'evaluating' stamp: 'brp 9/25/2003 13:49'! durationToRun "Answer the duration taken to execute this block." ^ Duration milliSeconds: self timeToRun ! ! !BlockContext methodsFor: 'evaluating' stamp: 'ajh 1/13/2002 13:36'! ifError: errorHandlerBlock "Evaluate the block represented by the receiver, and normally return it's value. If an error occurs, the errorHandlerBlock is evaluated, and it's value is instead returned. The errorHandlerBlock must accept zero, one, or two parameters (the error message and the receiver)." "Examples: [1 whatsUpDoc] ifError: [:err :rcvr | 'huh?']. [1 / 0] ifError: [:err :rcvr | 'ZeroDivide' = err ifTrue: [Float infinity] ifFalse: [self error: err]] " ^ self on: Error do: [:ex | errorHandlerBlock valueWithPossibleArgs: {ex description. ex receiver}]! ! !BlockContext methodsFor: 'evaluating' stamp: 'jm 6/3/1998 14:25'! timeToRun "Answer the number of milliseconds taken to execute this block." ^ Time millisecondsToRun: self ! ! !BlockContext methodsFor: 'evaluating'! value "Primitive. Evaluate the block represented by the receiver. Fail if the block expects any arguments or if the block is already being executed. Optional. No Lookup. See Object documentation whatIsAPrimitive." ^self valueWithArguments: #()! ! !BlockContext methodsFor: 'evaluating' stamp: 'nk 3/11/2001 11:49'! valueWithEnoughArguments: anArray "call me with enough arguments from anArray" | args | (anArray size == self numArgs) ifTrue: [ ^self valueWithArguments: anArray ]. args := Array new: self numArgs. args replaceFrom: 1 to: (anArray size min: args size) with: anArray startingAt: 1. ^ self valueWithArguments: args! ! !BlockContext methodsFor: 'evaluating' stamp: 'md 3/28/2006 20:17'! valueWithExit self value: [ ^nil ]! ! !BlockContext methodsFor: 'evaluating'! value: arg "Primitive. Evaluate the block represented by the receiver. Fail if the block expects other than one argument or if the block is already being executed. Optional. No Lookup. See Object documentation whatIsAPrimitive." ^self valueWithArguments: (Array with: arg)! ! !BlockContext methodsFor: 'evaluating'! value: arg1 value: arg2 "Primitive. Evaluate the block represented by the receiver. Fail if the block expects other than two arguments or if the block is already being executed. Optional. See Object documentation whatIsAPrimitive." ^self valueWithArguments: (Array with: arg1 with: arg2)! ! !BlockContext methodsFor: 'evaluating'! value: arg1 value: arg2 value: arg3 "Primitive. Evaluate the block represented by the receiver. Fail if the block expects other than three arguments or if the block is already being executed. Optional. See Object documentation whatIsAPrimitive." ^self valueWithArguments: (Array with: arg1 with: arg2 with: arg3)! ! !BlockContext methodsFor: 'evaluating' stamp: 'di 11/30/97 09:19'! value: arg1 value: arg2 value: arg3 value: arg4 "Primitive. Evaluate the block represented by the receiver. Fail if the block expects other than three arguments or if the block is already being executed. Optional. See Object documentation whatIsAPrimitive." ^self valueWithArguments: (Array with: arg1 with: arg2 with: arg3 with: arg4)! ! !BlockContext methodsFor: 'evaluating' stamp: 'jrp 10/10/2004 22:28'! valueSupplyingAnswer: anObject ^ (anObject isCollection and: [anObject isString not]) ifTrue: [self valueSupplyingAnswers: {anObject}] ifFalse: [self valueSupplyingAnswers: {{'*'. anObject}}]! ! !BlockContext methodsFor: 'evaluating' stamp: 'NicolasCellier 10/28/2008 00:43'! valueSupplyingAnswers: aListOfPairs "evaluate the block using a list of questions / answers that might be called upon to automatically respond to Object>>confirm: or FillInTheBlank requests" ^ [self value] on: ProvideAnswerNotification do: [:notify | | answer caption | caption := notify messageText withSeparatorsCompacted. "to remove new lines" answer := aListOfPairs detect: [:each | caption = each first or: [(caption includesSubstring: each first caseSensitive: false) or: [(each first match: caption) or: [(String includesSelector: #matchesRegex:) and: [caption matchesRegex: each first]]]]] ifNone: [nil]. answer ifNotNil: [notify resume: answer second] ifNil: [ | outerAnswer | outerAnswer := ProvideAnswerNotification signal: notify messageText. outerAnswer ifNil: [notify resume] ifNotNil: [notify resume: outerAnswer]]]! ! !BlockContext methodsFor: 'evaluating' stamp: 'jrp 10/10/2004 22:28'! valueSuppressingAllMessages ^ self valueSuppressingMessages: #('*')! ! !BlockContext methodsFor: 'evaluating' stamp: 'jrp 10/4/2004 18:59'! valueSuppressingMessages: aListOfStrings ^ self valueSuppressingMessages: aListOfStrings supplyingAnswers: #()! ! !BlockContext methodsFor: 'evaluating' stamp: 'jrp 10/4/2004 18:58'! valueSuppressingMessages: aListOfStrings supplyingAnswers: aListOfPairs ^ self valueSupplyingAnswers: aListOfPairs, (aListOfStrings collect: [:each | {each. true}])! ! !BlockContext methodsFor: 'evaluating' stamp: 'md 7/30/2005 21:22'! valueWithArguments: anArray "Primitive. Evaluate the block represented by the receiver. The argument is an Array whose elements are the arguments for the block. Fail if the length of the Array is not the same as the the number of arguments that the block was expecting. Fail if the block is already being executed. Essential. See Object documentation whatIsAPrimitive." anArray isArray ifFalse: [^self error: 'valueWithArguments: expects an array']. self numArgs = anArray size ifTrue: [self error: 'Attempt to evaluate a block that is already being evaluated.'] ifFalse: [self error: 'This block accepts ' ,self numArgs printString, ' argument', (self numArgs = 1 ifTrue:[''] ifFalse:['s']) , ', but was called with ', anArray size printString, '.'] ! ! !BlockContext methodsFor: 'evaluating' stamp: 'md 10/7/2004 15:24'! valueWithPossibleArgs: anArray "Evaluate the block represented by the receiver. If the block requires arguments, take them from anArray. If anArray is too large, the rest is ignored, if it is too small, use nil for the other arguments" self numArgs = 0 ifTrue: [^self value]. self numArgs = anArray size ifTrue: [^self valueWithArguments: anArray]. self numArgs > anArray size ifTrue: [ ^self valueWithArguments: anArray, (Array new: (self numArgs - anArray size)) ]. ^self valueWithArguments: (anArray copyFrom: 1 to: self numArgs) ! ! !BlockContext methodsFor: 'evaluating' stamp: 'md 10/7/2004 15:26'! valueWithPossibleArgument: anArg "Evaluate the block represented by the receiver. If the block requires one argument, use anArg, if it requires more than one, fill up the rest with nils." self numArgs = 0 ifTrue: [^self value]. self numArgs = 1 ifTrue: [^self value: anArg]. self numArgs > 1 ifTrue: [^self valueWithArguments: {anArg}, (Array new: self numArgs - 1)]! ! !BlockContext methodsFor: 'evaluating' stamp: 'ar 8/17/2007 13:15'! valueWithin: aDuration onTimeout: timeoutBlock "Evaluate the receiver. If the evaluation does not complete in less than aDuration evaluate the timeoutBlock instead" | theProcess delay watchdog | aDuration <= Duration zero ifTrue: [^ timeoutBlock value ]. "the block will be executed in the current process" theProcess := Processor activeProcess. delay := aDuration asDelay. "make a watchdog process" watchdog := [ delay wait. "wait for timeout or completion" theProcess ifNotNil:[ theProcess signalException: TimedOut ] ] newProcess. "Watchdog needs to run at high priority to do its job (but not at timing priority)" watchdog priority: Processor timingPriority-1. "catch the timeout signal" ^ [ watchdog resume. "start up the watchdog" self ensure:[ "evaluate the receiver" theProcess := nil. "it has completed, so ..." delay delaySemaphore signal. "arrange for the watchdog to exit" ]] on: TimedOut do: [ :e | timeoutBlock value ]. ! ! !BlockContext methodsFor: 'exceptions' stamp: 'sma 5/11/2000 19:38'! assert self assert: self! ! !BlockContext methodsFor: 'exceptions' stamp: 'ajh 3/4/2004 22:36'! ensure: aBlock "Evaluate a termination block after evaluating the receiver, regardless of whether the receiver's evaluation completes." | returnValue b | returnValue := self value. "aBlock wasn't nil when execution of this method began; it is nil'd out by the unwind machinery, and that's how we know it's already been evaluated ... otherwise, obviously, it needs to be evaluated" aBlock == nil ifFalse: [ "nil out aBlock temp before evaluating aBlock so it is not executed again if aBlock remote returns" b := aBlock. thisContext tempAt: 1 put: nil. "aBlock := nil" b value. ]. ^ returnValue! ! !BlockContext methodsFor: 'exceptions' stamp: 'ajh 1/24/2003 21:43'! ifCurtailed: aBlock "Evaluate the receiver with an abnormal termination action." ^ self value! ! !BlockContext methodsFor: 'exceptions' stamp: 'ar 3/6/2001 14:25'! on: exception do: handlerAction "Evaluate the receiver in the scope of an exception handler." | handlerActive | handlerActive := true. ^self value! ! !BlockContext methodsFor: 'exceptions' stamp: 'ajh 10/9/2001 16:51'! onDNU: selector do: handleBlock "Catch MessageNotUnderstood exceptions but only those of the given selector (DNU stands for doesNotUnderstand:)" ^ self on: MessageNotUnderstood do: [:exception | exception message selector = selector ifTrue: [handleBlock valueWithPossibleArgs: {exception}] ifFalse: [exception pass] ]! ! !BlockContext methodsFor: 'exceptions' stamp: 'ajh 1/24/2003 21:53'! valueUninterruptably "Temporarily make my home Context unable to return control to its sender, to guard against circumlocution of the ensured behavior." ^ self ifCurtailed: [^ self]! ! !BlockContext methodsFor: 'initialize-release' stamp: 'ls 6/21/2000 17:42'! home: aContextPart startpc: position nargs: anInteger "This is the initialization message. The receiver has been initialized with the correct size only." home := aContextPart. pc := startpc := position. nargs := anInteger. stackp := 0.! ! !BlockContext methodsFor: 'initialize-release' stamp: 'ajh 7/18/2003 21:49'! privRefresh "Reinitialize the receiver so that it is in the state it was at its creation." pc := startpc. self stackp: 0. nargs timesRepeat: [ "skip arg popping" self nextInstruction selector = #popIntoTemporaryVariable: ifFalse: [self halt: 'unexpected bytecode instruction'] ]. ! ! !BlockContext methodsFor: 'instruction decoding' stamp: 'ajh 1/24/2003 16:35'! blockReturnTop "Simulate the interpreter's action when a ReturnTopOfStack bytecode is encountered in the receiver." | save dest | save := home. "Needed because return code will nil it" dest := self return: self pop from: self. home := save. sender := nil. ^ dest! ! !BlockContext methodsFor: 'printing' stamp: 'md 2/22/2006 15:53'! decompile ^ home method decompilerClass new decompileBlock: self! ! !BlockContext methodsFor: 'printing' stamp: 'md 2/20/2006 13:46'! decompileString ^self decompile decompileString.! ! !BlockContext methodsFor: 'printing' stamp: 'eem 7/28/2008 14:10'! fullPrintOn: aStream aStream print: self; cr. (self decompile ifNil: ['--source missing--']) printOn: aStream indent: 0! ! !BlockContext methodsFor: 'printing' stamp: 'eem 5/16/2008 12:03'! printOn: aStream | decompilation blockString truncatedBlockString | home == nil ifTrue: [^aStream nextPutAll: 'a BlockContext with home=nil']. aStream nextPutAll: '[] in '. super printOn: aStream. decompilation := [self decompile ifNil: ['--source missing--']] on: Error do: [:ex| ' (error in decompilation)']. blockString := ((decompilation isString ifTrue: [decompilation] ifFalse: [decompilation printString]) replaceAll: Character cr with: Character space) replaceAll: Character tab with: Character space. truncatedBlockString := blockString truncateWithElipsisTo: 80. truncatedBlockString size < blockString size ifTrue: [truncatedBlockString := truncatedBlockString, ']}']. aStream space; nextPutAll: truncatedBlockString! ! !BlockContext methodsFor: 'printing' stamp: 'MPW 1/1/1901 22:01'! printOnStream: aStream home == nil ifTrue: [^aStream print: 'a BlockContext with home=nil']. aStream print: '[] in '. super printOnStream: aStream! ! !BlockContext methodsFor: 'scheduling' stamp: 'ajh 2/10/2003 14:23'! asContext ^ self! ! !BlockContext methodsFor: 'scheduling' stamp: 'di 9/12/1998 11:53'! fork "Create and schedule a Process running the code in the receiver." ^ self newProcess resume! ! !BlockContext methodsFor: 'scheduling' stamp: 'ajh 10/16/2002 11:14'! forkAndWait "Suspend current process and execute self in new process, when it completes resume current process" | semaphore | semaphore := Semaphore new. [self ensure: [semaphore signal]] fork. semaphore wait. ! ! !BlockContext methodsFor: 'scheduling' stamp: 'jm 11/9/1998 10:16'! forkAt: priority "Create and schedule a Process running the code in the receiver at the given priority. Answer the newly created process." | forkedProcess | forkedProcess := self newProcess. forkedProcess priority: priority. ^ forkedProcess resume ! ! !BlockContext methodsFor: 'scheduling' stamp: 'svp 6/23/2003 10:59'! forkAt: priority named: name "Create and schedule a Process running the code in the receiver at the given priority and having the given name. Answer the newly created process." | forkedProcess | forkedProcess := self newProcess. forkedProcess priority: priority. forkedProcess name: name. ^ forkedProcess resume! ! !BlockContext methodsFor: 'scheduling' stamp: 'svp 6/23/2003 10:59'! forkNamed: aString "Create and schedule a Process running the code in the receiver and having the given name." ^ self newProcess name: aString; resume! ! !BlockContext methodsFor: 'scheduling' stamp: 'ajh 2/10/2003 14:25'! newProcess "Answer a Process running the code in the receiver. The process is not scheduled." "Simulation guard" ^Process forContext: [self value. Processor terminateActive] asContext priority: Processor activePriority! ! !BlockContext methodsFor: 'scheduling' stamp: 'ajh 2/10/2003 14:25'! newProcessWith: anArray "Answer a Process running the code in the receiver. The receiver's block arguments are bound to the contents of the argument, anArray. The process is not scheduled." "Simulation guard" ^Process forContext: [self valueWithArguments: anArray. Processor terminateActive] asContext priority: Processor activePriority! ! !BlockContext methodsFor: 'scheduling' stamp: 'sr 6/14/2004 15:19'! valueAt: blockPriority "Evaluate the receiver (block), with another priority as the actual one and restore it afterwards. The caller should be careful with using higher priorities." | activeProcess result outsidePriority | activeProcess := Processor activeProcess. outsidePriority := activeProcess priority. activeProcess priority: blockPriority. result := self ensure: [activeProcess priority: outsidePriority]. "Yield after restoring lower priority to give the preempted processes a chance to run." blockPriority > outsidePriority ifTrue: [Processor yield]. ^ result! ! !BlockContext methodsFor: 'system simulation' stamp: 'di 1/11/1999 10:24'! pushArgs: args from: sendr "Simulates action of the value primitive." args size ~= nargs ifTrue: [^self error: 'incorrect number of args']. self stackp: 0. args do: [:arg | self push: arg]. sender := sendr. pc := startpc! ! !BlockContext methodsFor: 'system simulation' stamp: 'hmm 7/30/2001 18:03'! stepToSendOrReturn pc = startpc ifTrue: [ "pop args first" self numArgs timesRepeat: [self step]]. ^super stepToSendOrReturn! ! !BlockContext methodsFor: 'testing' stamp: 'kph 1/21/2009 15:33'! = other self class == other class ifFalse: [^ false]. self home receiver == other home receiver ifFalse: [^ false]. self home selector == other home selector ifFalse: [^ false]. ^ self startpc == other startpc ! ! !BlockContext methodsFor: 'testing' stamp: 'kph 1/21/2009 15:33'! hash ^ self method hash! ! !BlockContext methodsFor: 'private' stamp: 'ajh 1/24/2003 20:36'! aboutToReturn: result through: firstUnwindContext "Called from VM when an unwindBlock is found between self and its home. Return to home's sender, executing unwind blocks on the way." self home return: result! ! !BlockContext methodsFor: 'private' stamp: 'tfei 3/31/1999 17:40'! cannotReturn: result "The receiver tried to return result to a method context that no longer exists." | ex newResult | ex := BlockCannotReturn new. ex result: result. newResult := ex signal. ^newResult! ! !BlockContext methodsFor: 'private' stamp: 'ajh 1/27/2003 21:18'! copyTo: aContext blocks: dict "Copy self and my sender chain down to, but not including, aContext. End of copied chain will have nil sender. BlockContexts whose home is also copied will point to the copy. However, blockContexts that are not on the stack but may be later will not have their home pointing in the new copied thread. So an error will be raised if one of these tries to return directly to its home." | copy | self == aContext ifTrue: [^ nil]. copy := self copy. (dict at: self home ifAbsentPut: [OrderedCollection new]) add: copy. self sender ifNotNil: [ copy privSender: (self sender copyTo: aContext blocks: dict)]. ^ copy! ! !BlockContext methodsFor: 'private' stamp: 'md 4/27/2006 15:14'! endPC "Determine end of block from long jump preceding it" ^(self method at: startpc - 2) \\ 16 - 4 * 256 + (self method at: startpc - 1) + startpc - 1.! ! !BlockContext methodsFor: 'private' stamp: 'di 1/14/1999 22:28'! instVarAt: index put: value index = 3 ifTrue: [self stackp: value. ^ value]. ^ super instVarAt: index put: value! ! !BlockContext methodsFor: 'private' stamp: 'ajh 7/7/2004 13:43'! myEnv "polymorphic with MethodContext" ^ nil! ! !BlockContext methodsFor: 'private' stamp: 'ajh 1/27/2003 21:08'! privHome: context home := context! ! !BlockContext methodsFor: 'private'! startpc "for use by the System Tracer only" ^startpc! ! !BlockContext methodsFor: 'private'! valueError self error: 'Incompatible number of args, or already active'! ! !BlockContext methodsFor: 'private' stamp: 'ar 3/2/2001 01:16'! valueUnpreemptively "Evaluate the receiver (block), without the possibility of preemption by higher priority processes. Use this facility VERY sparingly!!" "Think about using Block>>valueUninterruptably first, and think about using Semaphore>>critical: before that, and think about redesigning your application even before that!! After you've done all that thinking, go right ahead and use it..." | activeProcess oldPriority result | activeProcess := Processor activeProcess. oldPriority := activeProcess priority. activeProcess priority: Processor highestPriority. result := self ensure: [activeProcess priority: oldPriority]. "Yield after restoring priority to give the preempted processes a chance to run" Processor yield. ^result! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! BlockContext class instanceVariableNames: ''! TestCase subclass: #BlockContextTest instanceVariableNames: 'aBlockContext contextOfaBlockContext' classVariableNames: '' poolDictionaries: '' category: 'KernelTests-Methods'! !BlockContextTest commentStamp: 'jrp 10/17/2004 12:22' prior: 0! I am an SUnit Test of BlockContext and its supertype ContextPart. See also MethodContextTest. My fixtures are: aBlockContext - just some trivial block, i.e., [100@100 corner: 200@200]. NOTES ABOUT AUTOMATING USER INPUTS When executing non-interactive programs you will inevitably run into programs (like SqueakMap or Monticello installation packages -- and other programs, to be fair) that require user input during their execution and these sort of problems shoot the whole non-interactiveness of your enclosing program. BlockContext helper methods have been made available and tests of these helpers are provided in this class to demonstrate that it can intercept PopUpMenu and FillInTheBlankMorph requests for user interaction. Of course, PopUpMenu and FillInTheBlankMorph were modified to first signal a ProvideAnswerNotification and if someone handles that (e.g. the enclosing block) then the user interaction will be circumvented and the provided answer of the enclosing block will be used. The basic syntax looks like: [self confirm: 'Install spyware?'] valueSupplyingAnswer: #('Install spyware?' false) There a few variants on this theme making it easy to provide a literal list of answers for the block so that you can handle a bunch of questions in a block with appropriate answers. Additionally, it is possible to suppress Object>>inform: modal dialog boxes as these get in the way of automating anything. After applying this changeset you should be able to tryout the following code snippets to see the variants on this theme that are available. Examples: So you don't need any introduction here -- this one works like usual. [self inform: 'hello'. #done] value. Now let's suppress all inform: messages. [self inform: 'hello'; inform: 'there'. #done] valueSuppressingAllMessages. Here we can just suppress a single inform: message. [self inform: 'hi'; inform: 'there'. #done] valueSuppressingMessages: #('there') Here you see how you can suppress a list of messages. [self inform: 'hi'; inform: 'there'; inform: 'bill'. #done] valueSuppressingMessages: #('hi' 'there') Enough about inform:, let's look at confirm:. As you see this one works as expected. [self confirm: 'You like Squeak?'] value Let's supply answers to one of the questions -- check out the return value. [{self confirm: 'You like Smalltalk?'. self confirm: 'You like Squeak?'}] valueSupplyingAnswer: #('You like Smalltalk?' true) Here we supply answers using only substrings of the questions (for simplicity). [{self confirm: 'You like Squeak?'. self confirm: 'You like MVC?'}] valueSupplyingAnswers: #( ('Squeak' true) ('MVC' false) ) This time let's answer all questions exactly the same way. [{self confirm: 'You like Squeak?'. self confirm: 'You like Morphic?'}] valueSupplyingAnswer: true And, of course, we can answer FillInTheBlank questions in the same manner. [FillInTheBlank request: 'What day is it?'] valueSupplyingAnswer: 'the first day of the rest of your life' We can also return whatever the initialAnswer of the FillInTheBlank was by using the #default answer. [FillInTheBlank request: 'What day is it?' initialAnswer: DateAndTime now dayOfWeekName] valueSupplyingAnswer: #default Finally, you can also do regex matches on any of the question text (or inform text) (should you have VB-Regex enhancements in your image). [FillInTheBlank request: 'What day is it?'] valueSupplyingAnswers: { {'What day.*\?'. DateAndTime now dayOfWeekName} }! !BlockContextTest methodsFor: 'setup' stamp: 'md 9/6/2005 19:56'! setUp super setUp. aBlockContext := [100@100 corner: 200@200]. contextOfaBlockContext := thisContext.! ! !BlockContextTest methodsFor: 'testing' stamp: 'rbb 3/1/2005 10:23'! testSupplyAnswerOfFillInTheBlank self should: ['blue' = ([UIManager default request: 'Your favorite color?'] valueSupplyingAnswer: #('Your favorite color?' 'blue'))]! ! !BlockContextTest methodsFor: 'testing' stamp: 'rbb 3/1/2005 10:24'! testSupplyAnswerOfFillInTheBlankUsingDefaultAnswer self should: ['red' = ([UIManager default request: 'Your favorite color?' initialAnswer: 'red'] valueSupplyingAnswer: #('Your favorite color?' #default))]! ! !BlockContextTest methodsFor: 'tests' stamp: 'tlk 5/31/2004 13:13'! testNew self should: [ContextPart new: 5] raise: Error. [ContextPart new: 5] ifError: [:error :receiver | error = 'Error: Contexts must only be created with newForMethod:']. [ContextPart new] ifError: [:error :receiver | error = 'Error: Contexts must only be created with newForMethod:']. [ContextPart basicNew] ifError: [:error :receiver | error = 'Error: Contexts must only be created with newForMethod:']. ! ! !BlockContextTest methodsFor: 'tests' stamp: 'mjr 8/24/2003 18:27'! testNoArguments [10 timesRepeat: [:arg | 1 + 2]] ifError: [:err :rcvr | self deny: err = 'This block requires 1 arguments.']. [10 timesRepeat: [:arg1 :arg2 | 1 + 2]] ifError: [:err :rcvr | self deny: err = 'This block requires 2 arguments.'] ! ! !BlockContextTest methodsFor: 'tests' stamp: 'mjr 8/24/2003 18:25'! testOneArgument | c | c := OrderedCollection new. c add: 'hello'. [c do: [1 + 2]] ifError: [:err :rcvr | self deny: err = 'This block requires 0 arguments.']. [c do: [:arg1 :arg2 | 1 + 2]] ifError: [:err :rcvr | self deny: err = 'This block requires 2 arguments.'] ! ! !BlockContextTest methodsFor: 'tests' stamp: 'tlk 5/31/2004 12:50'! testRunSimulated self assert: (ContextPart runSimulated: aBlockContext) class = Rectangle.! ! !BlockContextTest methodsFor: 'tests' stamp: 'al 7/4/2009 19:01'! testSetUp "Note: In addition to verifying that the setUp worked the way it was expected to, testSetUp is used to illustrate the meaning of the simple access methods, methods that are not normally otherwise 'tested'" self deny: aBlockContext isPseudoContext. self assert: aBlockContext home = contextOfaBlockContext. self assert: aBlockContext receiver = self. self assert: (aBlockContext method isKindOf: CompiledMethod).! ! !BlockContextTest methodsFor: 'tests' stamp: 'jrp 10/10/2004 22:19'! testSupplyAnswerThroughNestedBlocks self should: [true = ([[self confirm: 'You like Smalltalk?'] valueSupplyingAnswer: #('Blub' false)] valueSupplyingAnswer: #('Smalltalk' true))]! ! !BlockContextTest methodsFor: 'tests' stamp: 'jrp 10/4/2004 19:27'! testSupplyAnswerUsingOnlySubstringOfQuestion self should: [false = ([self confirm: 'You like Smalltalk?'] valueSupplyingAnswer: #('like' false))]! ! !BlockContextTest methodsFor: 'tests' stamp: 'jrp 10/10/2004 22:31'! testSupplyAnswerUsingRegexMatchOfQuestion (String includesSelector: #matchesRegex:) ifFalse: [^ self]. self should: [true = ([self confirm: 'You like Smalltalk?'] valueSupplyingAnswer: #('.*Smalltalk\?' true))]! ! !BlockContextTest methodsFor: 'tests' stamp: 'jrp 10/10/2004 22:17'! testSupplyAnswerUsingTraditionalMatchOfQuestion self should: [true = ([self confirm: 'You like Smalltalk?'] valueSupplyingAnswer: #('*Smalltalk#' true))]! ! !BlockContextTest methodsFor: 'tests' stamp: 'jrp 10/4/2004 19:25'! testSupplySameAnswerToAllQuestions self should: [true = ([self confirm: 'You like Smalltalk?'] valueSupplyingAnswer: true)]. self should: [#(true true) = ([{self confirm: 'One'. self confirm: 'Two'}] valueSupplyingAnswer: true)].! ! !BlockContextTest methodsFor: 'tests' stamp: 'jrp 10/4/2004 19:39'! testSupplySeveralAnswersToSeveralQuestions self should: [#(false true) = ([{self confirm: 'One'. self confirm: 'Two'}] valueSupplyingAnswers: #( ('One' false) ('Two' true) ))]. self should: [#(true false) = ([{self confirm: 'One'. self confirm: 'Two'}] valueSupplyingAnswers: #( ('One' true) ('Two' false) ))]! ! !BlockContextTest methodsFor: 'tests' stamp: 'jrp 10/4/2004 19:26'! testSupplySpecificAnswerToQuestion self should: [false = ([self confirm: 'You like Smalltalk?'] valueSupplyingAnswer: #('You like Smalltalk?' false))]! ! !BlockContextTest methodsFor: 'tests' stamp: 'jrp 10/4/2004 19:35'! testSuppressInform self should: [[nil inform: 'Should not see this message or this test failed!!'] valueSuppressingAllMessages isNil]! ! !BlockContextTest methodsFor: 'tests' stamp: 'jrp 10/10/2004 22:29'! testSuppressInformUsingStringMatchOptions self should: [([nil inform: 'Should not see this message or this test failed!!'] valueSuppressingMessages: #('Should not see this message or this test failed!!')) isNil]. self should: [([nil inform: 'Should not see this message or this test failed!!'] valueSuppressingMessages: #('not see this message')) isNil]. self should: [([nil inform: 'Should not see this message or this test failed!!'] valueSuppressingMessages: #('*message*failed#')) isNil]. ! ! !BlockContextTest methodsFor: 'tests' stamp: 'md 9/6/2005 19:58'! testTallyInstructions self assert: (ContextPart tallyInstructions: aBlockContext) size = 15.! ! !BlockContextTest methodsFor: 'tests' stamp: 'md 9/6/2005 19:58'! testTallyMethods self assert: (ContextPart tallyMethods: aBlockContext) size = 3.! ! !BlockContextTest methodsFor: 'tests' stamp: 'tlk 5/31/2004 12:48'! testTrace self assert: (ContextPart trace: aBlockContext) class = Rectangle.! ! !BlockContextTest methodsFor: 'tests - evaluating' stamp: 'Henrik Sperre Johansen 3/23/2009 13:45'! testValueWithArguments self should: [aBlockContext valueWithArguments: #(1 )] raise: Error. self shouldnt: [aBlockContext valueWithArguments: #()] raise: Error. [aBlockContext valueWithArguments: #(1 )] ifError: [:err :rcvr | self assert: err = 'Error: This block accepts 0 arguments, but was called with 1 argument.']. [[:i | 3 + 4] valueWithArguments: #(1 2)] ifError: [:err :rcvr | self assert: err = 'Error: This block accepts 1 argument, but was called with 2 arguments.']! ! !BlockContextTest methodsFor: 'tests - evaluating' stamp: 'md 3/23/2006 13:52'! testValueWithExitBreak | val | [ :break | 1 to: 10 do: [ :i | val := i. i = 4 ifTrue: [break value]. ] ] valueWithExit. self assert: val = 4.! ! !BlockContextTest methodsFor: 'tests - evaluating' stamp: 'md 3/23/2006 13:52'! testValueWithExitContinue | val last | val := 0. 1 to: 10 do: [ :i | [ :continue | i = 4 ifTrue: [continue value]. val := val + 1. last := i ] valueWithExit. ]. self assert: val = 9. self assert: last = 10. ! ! !BlockContextTest methodsFor: 'tests - evaluating' stamp: 'md 10/7/2004 13:52'! testValueWithPossibleArgs | block blockWithArg blockWith2Arg | block := [1]. blockWithArg := [:arg | arg]. blockWith2Arg := [:arg1 :arg2 | {arg1. arg2}]. self assert: (block valueWithPossibleArgs: #()) = 1. self assert: (block valueWithPossibleArgs: #(1)) = 1. self assert: (blockWithArg valueWithPossibleArgs: #()) = nil. self assert: (blockWithArg valueWithPossibleArgs: #(1)) = 1. self assert: (blockWithArg valueWithPossibleArgs: #(1 2)) = 1. self assert: (blockWith2Arg valueWithPossibleArgs: #()) = {nil .nil}. self assert: (blockWith2Arg valueWithPossibleArgs: #(1)) = {1 . nil}. self assert: (blockWith2Arg valueWithPossibleArgs: #(1 2)) = #(1 2). self assert: (blockWith2Arg valueWithPossibleArgs: #(1 2 3)) = #(1 2). ! ! !BlockContextTest methodsFor: 'tests - evaluating' stamp: 'md 10/7/2004 13:59'! testValueWithPossibleArgument | block blockWithArg blockWith2Arg | block := [1]. blockWithArg := [:arg | arg]. blockWith2Arg := [:arg1 :arg2 | {arg1. arg2}]. self assert: (block valueWithPossibleArgument: 1) = 1. self assert: (blockWithArg valueWithPossibleArgument: 1) = 1. self assert: (blockWith2Arg valueWithPossibleArgument: 1) = {1 . nil}. ! ! !BlockContextTest methodsFor: 'tests - printing' stamp: 'md 2/22/2006 15:39'! testDecompile self assert: ([3 + 4] decompile printString = '{[3 + 4]}').! ! InstructionClient subclass: #BlockLocalTempCounter instanceVariableNames: 'stackPointer scanner blockEnd joinOffsets' classVariableNames: '' poolDictionaries: '' category: 'Compiler-Support'! !BlockLocalTempCounter commentStamp: '' prior: 0! I am a support class for the decompiler that is used to find the number of local temps in a block by finding out what the stack offset is at the end of a block.! ]style[(160)i! !BlockLocalTempCounter methodsFor: 'initialize-release' stamp: 'eem 9/26/2008 13:40'! tempCountForBlockAt: pc in: method "Compute the number of local temporaries in a block. If the block begins with a sequence of push: nil bytecodes then some of These could be initializing local temps. We can only reliably disambuguate them from other uses of nil by parsing the stack and seeing what the offset of the stack pointer is at the end of the block. There are short-cuts. The ones we take here are - if there is no sequence of push nils there can be no local temps - we follow forward jumps to shorten the amount of scanning" stackPointer := 0. scanner := InstructionStream new method: method pc: pc. scanner interpretNextInstructionFor: self. blockEnd isNil ifTrue: [self error: 'pc is not that of a block']. scanner nextByte = Encoder pushNilCode ifTrue: [joinOffsets := Dictionary new. [scanner pc < blockEnd] whileTrue: [scanner interpretNextInstructionFor: self]]. ^stackPointer! ! !BlockLocalTempCounter methodsFor: 'initialize-release' stamp: 'eem 9/26/2008 13:41'! testTempCountForBlockAt: startPc in: method "Compute the number of local temporaries in a block. If the block begins with a sequence of push: nil bytecodes then some of These could be initializing local temps. We can only reliably disambuguate them from other uses of nil by parsing the stack and seeing what the offset of the stack pointer is at the end of the block.There are short-cuts. The only one we take here is - if there is no sequence of push nils there can be no local temps" | symbolicLines line prior thePc | symbolicLines := Dictionary new. method symbolicLinesDo: [:pc :lineForPC| symbolicLines at: pc put: lineForPC]. stackPointer := 0. scanner := InstructionStream new method: method pc: startPc. scanner interpretNextInstructionFor: self. blockEnd isNil ifTrue: [self error: 'pc is not that of a block']. scanner nextByte = Encoder pushNilCode ifTrue: [joinOffsets := Dictionary new. [scanner pc < blockEnd] whileTrue: [line := symbolicLines at: scanner pc. prior := stackPointer. thePc := scanner pc. scanner interpretNextInstructionFor: self. Transcript cr; print: prior; nextPutAll: '->'; print: stackPointer; tab; print: thePc; tab; nextPutAll: line; flush]]. ^stackPointer! ! !BlockLocalTempCounter methodsFor: 'instruction decoding' stamp: 'eem 9/26/2008 11:36'! blockReturnTop "Return Top Of Stack bytecode." stackPointer := stackPointer - 1. scanner pc < blockEnd ifTrue: [self doJoin]! ! !BlockLocalTempCounter methodsFor: 'instruction decoding' stamp: 'eem 9/23/2008 16:13'! doDup "Duplicate Top Of Stack bytecode." stackPointer := stackPointer + 1! ! !BlockLocalTempCounter methodsFor: 'instruction decoding' stamp: 'eem 9/23/2008 16:17'! doPop "Remove Top Of Stack bytecode." stackPointer := stackPointer - 1! ! !BlockLocalTempCounter methodsFor: 'instruction decoding' stamp: 'eem 9/26/2008 13:40'! jump: offset "Unconditional Jump bytecode." offset > 0 ifTrue: [joinOffsets at: scanner pc + offset put: stackPointer. self doJoin]! ! !BlockLocalTempCounter methodsFor: 'instruction decoding' stamp: 'eem 9/26/2008 13:40'! jump: offset if: condition "Conditional Jump bytecode." stackPointer := stackPointer - 1. offset > 0 ifTrue: [joinOffsets at: scanner pc + offset put: stackPointer]! ! !BlockLocalTempCounter methodsFor: 'instruction decoding' stamp: 'eem 9/26/2008 11:36'! methodReturnConstant: value "Return Constant bytecode." self doJoin! ! !BlockLocalTempCounter methodsFor: 'instruction decoding' stamp: 'eem 9/26/2008 11:36'! methodReturnReceiver "Return Self bytecode." self doJoin! ! !BlockLocalTempCounter methodsFor: 'instruction decoding' stamp: 'eem 9/26/2008 11:36'! methodReturnTop "Return Top Of Stack bytecode." stackPointer := stackPointer - 1. self doJoin! ! !BlockLocalTempCounter methodsFor: 'instruction decoding' stamp: 'eem 9/23/2008 16:19'! popIntoLiteralVariable: anAssociation "Remove Top Of Stack And Store Into Literal Variable bytecode." stackPointer := stackPointer - 1! ! !BlockLocalTempCounter methodsFor: 'instruction decoding' stamp: 'eem 9/23/2008 16:19'! popIntoReceiverVariable: offset "Remove Top Of Stack And Store Into Instance Variable bytecode." stackPointer := stackPointer - 1! ! !BlockLocalTempCounter methodsFor: 'instruction decoding' stamp: 'eem 9/23/2008 16:19'! popIntoRemoteTemp: remoteTempIndex inVectorAt: tempVectorIndex "Remove Top Of Stack And Store Into Offset of Temp Vector bytecode." stackPointer := stackPointer - 1! ! !BlockLocalTempCounter methodsFor: 'instruction decoding' stamp: 'eem 9/23/2008 16:20'! popIntoTemporaryVariable: offset "Remove Top Of Stack And Store Into Temporary Variable bytecode." stackPointer := stackPointer - 1! ! !BlockLocalTempCounter methodsFor: 'instruction decoding' stamp: 'eem 9/23/2008 16:20'! pushActiveContext "Push Active Context On Top Of Its Own Stack bytecode." stackPointer := stackPointer + 1! ! !BlockLocalTempCounter methodsFor: 'instruction decoding' stamp: 'eem 9/23/2008 16:16'! pushClosureCopyNumCopiedValues: numCopied numArgs: numArgs blockSize: blockSize "Push Closure bytecode. Either compute the end of the block if this is the block we're analysing, or skip it, adjusting the stack as appropriate." blockEnd ifNil: [blockEnd := scanner pc + blockSize] ifNotNil: [stackPointer := stackPointer - numCopied + 1. scanner pc: scanner pc + blockSize]! ! !BlockLocalTempCounter methodsFor: 'instruction decoding' stamp: 'eem 9/23/2008 16:21'! pushConsArrayWithElements: numElements "Push Cons Array of size numElements popping numElements items from the stack into the array bytecode." stackPointer := stackPointer - numElements + 1! ! !BlockLocalTempCounter methodsFor: 'instruction decoding' stamp: 'eem 9/23/2008 16:21'! pushConstant: value "Push Constant, value, on Top Of Stack bytecode." stackPointer := stackPointer + 1! ! !BlockLocalTempCounter methodsFor: 'instruction decoding' stamp: 'eem 9/23/2008 16:22'! pushLiteralVariable: anAssociation "Push Contents Of anAssociation On Top Of Stack bytecode." stackPointer := stackPointer + 1! ! !BlockLocalTempCounter methodsFor: 'instruction decoding' stamp: 'eem 9/23/2008 16:22'! pushNewArrayOfSize: numElements "Push New Array of size numElements bytecode." stackPointer := stackPointer + 1! ! !BlockLocalTempCounter methodsFor: 'instruction decoding' stamp: 'eem 9/23/2008 16:22'! pushReceiver "Push Active Context's Receiver on Top Of Stack bytecode." stackPointer := stackPointer + 1! ! !BlockLocalTempCounter methodsFor: 'instruction decoding' stamp: 'eem 9/23/2008 16:23'! pushReceiverVariable: offset "Push Contents Of the Receiver's Instance Variable Whose Index is the argument, offset, On Top Of Stack bytecode." stackPointer := stackPointer + 1! ! !BlockLocalTempCounter methodsFor: 'instruction decoding' stamp: 'eem 9/23/2008 16:23'! pushRemoteTemp: remoteTempIndex inVectorAt: tempVectorIndex "Push Contents at Offset in Temp Vector bytecode." stackPointer := stackPointer + 1! ! !BlockLocalTempCounter methodsFor: 'instruction decoding' stamp: 'eem 9/23/2008 16:23'! pushTemporaryVariable: offset "Push Contents Of Temporary Variable Whose Index Is the argument, offset, On Top Of Stack bytecode." stackPointer := stackPointer + 1! ! !BlockLocalTempCounter methodsFor: 'instruction decoding' stamp: 'eem 9/23/2008 16:24'! send: selector super: supered numArgs: numberArguments "Send Message With Selector, selector, bytecode. The argument, supered, indicates whether the receiver of the message is specified with 'super' in the source method. The arguments of the message are found in the top numArguments locations on the stack and the receiver just below them." stackPointer := stackPointer - numberArguments! ! !BlockLocalTempCounter methodsFor: 'private' stamp: 'eem 9/26/2008 13:40'! doJoin scanner pc < blockEnd ifTrue: [stackPointer := joinOffsets at: scanner pc]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! BlockLocalTempCounter class instanceVariableNames: ''! !BlockLocalTempCounter class methodsFor: 'instance creation' stamp: 'eem 9/23/2008 16:07'! tempCountForBlockAt: pc in: method ^self new tempCountForBlockAt: pc in: method! ! ParseNode subclass: #BlockNode instanceVariableNames: 'arguments statements returns nArgsNode size remoteCopyNode temporaries optimized actualScopeIfOptimized blockExtent remoteTempNode copiedValues closureCreationNode startOfLastStatement' classVariableNames: '' poolDictionaries: '' category: 'Compiler-ParseNodes'! !BlockNode commentStamp: '' prior: 0! I represent a bracketed block with 0 or more arguments and 1 or more statements. If I am initialized with no statements, I create one. I have a flag to tell whether my last statement returns a value from the enclosing method. My last three fields remember data needed for code generation. I can emit for value in the usual way, in which case I create a literal method (actually a context remotely copied) to be evaluated by sending it value: at run time. Or I can emit code to be evaluated in line; this only happens at the top level of a method and in conditionals and while-loops, none of which have arguments.! !BlockNode methodsFor: 'accessing' stamp: 'eem 6/2/2008 14:00'! addArgument: aTempVariableNode temporaries := temporaries copyWith: aTempVariableNode! ! !BlockNode methodsFor: 'accessing' stamp: 'eem 7/27/2008 15:57'! arguments ^arguments! ! !BlockNode methodsFor: 'accessing'! arguments: argNodes "Decompile." arguments := argNodes! ! !BlockNode methodsFor: 'accessing' stamp: 'tk 8/4/1999 22:53'! block ^ self! ! !BlockNode methodsFor: 'accessing' stamp: 'eem 8/22/2008 10:01'! closureCreationNode closureCreationNode ifNil: [closureCreationNode := LeafNode new key: #closureCreationNode code: nil]. ^closureCreationNode! ! !BlockNode methodsFor: 'accessing'! firstArgument ^ arguments first! ! !BlockNode methodsFor: 'accessing' stamp: 'eem 5/30/2008 12:12'! nArgsSlot "Private for the Encoder to use in bindArg" ^nArgsNode! ! !BlockNode methodsFor: 'accessing' stamp: 'eem 5/30/2008 12:12'! nArgsSlot: anInteger "Private for the Encoder to use in bindArg" nArgsNode := anInteger! ! !BlockNode methodsFor: 'accessing'! numberOfArguments ^arguments size! ! !BlockNode methodsFor: 'accessing' stamp: 'eem 7/24/2008 12:37'! optimized ^optimized! ! !BlockNode methodsFor: 'accessing'! returnLast self returns ifFalse: [returns := true. statements at: statements size put: statements last asReturnNode]! ! !BlockNode methodsFor: 'accessing' stamp: 'ar 11/17/2002 19:57'! returnNilIfNoOther self returns ifFalse: [statements last == NodeNil ifFalse: [statements add: NodeNil]. self returnLast]! ! !BlockNode methodsFor: 'accessing' stamp: 'gk 4/6/2006 11:29'! returnSelfIfNoOther: encoder self returns ifTrue:[^self]. statements last == NodeSelf ifFalse: [ statements := statements copyWith: (encoder encodeVariable: 'self'). ]. self returnLast. ! ! !BlockNode methodsFor: 'accessing' stamp: 'eem 8/4/2008 10:48'! startOfLastStatement ^startOfLastStatement! ! !BlockNode methodsFor: 'accessing' stamp: 'eem 8/4/2008 10:50'! startOfLastStatement: anInteger "Note the source index of the start of the last full statement. The last full statement is the value answered by a block and hence the expression the debugger should display as the value of the block." startOfLastStatement := anInteger! ! !BlockNode methodsFor: 'accessing' stamp: 'eem 7/27/2008 15:57'! temporaries ^temporaries! ! !BlockNode methodsFor: 'accessing' stamp: 'sma 2/27/2000 22:37'! temporaries: aCollection temporaries := aCollection! ! !BlockNode methodsFor: 'code generation'! code ^statements first code! ! !BlockNode methodsFor: 'code generation' stamp: 'di 11/19/1999 19:32'! emitExceptLast: stack on: aStream | nextToLast | nextToLast := statements size - 1. nextToLast < 1 ifTrue: [^ self]. "Only one statement" 1 to: nextToLast do: [:i | (statements at: i) emitForEffect: stack on: aStream]. ! ! !BlockNode methodsFor: 'code generation'! emitForEvaluatedEffect: stack on: aStream self returns ifTrue: [self emitForEvaluatedValue: stack on: aStream. stack pop: 1] ifFalse: [self emitExceptLast: stack on: aStream. statements last emitForEffect: stack on: aStream]! ! !BlockNode methodsFor: 'code generation' stamp: 'di 11/19/1999 19:44'! emitForEvaluatedValue: stack on: aStream self emitExceptLast: stack on: aStream. statements last emitForValue: stack on: aStream. ! ! !BlockNode methodsFor: 'code generation' stamp: 'hmm 7/17/2001 21:02'! emitForValue: stack on: aStream aStream nextPut: LdThisContext. stack push: 1. nArgsNode emitForValue: stack on: aStream. remoteCopyNode emit: stack args: 1 on: aStream. "Force a two byte jump." self emitLong: size code: JmpLong on: aStream. stack push: arguments size. arguments reverseDo: [:arg | arg emitStorePop: stack on: aStream]. self emitForEvaluatedValue: stack on: aStream. self returns ifFalse: [ aStream nextPut: EndRemote. pc := aStream position. ]. stack pop: 1! ! !BlockNode methodsFor: 'code generation' stamp: 'di 11/19/1999 19:33'! sizeExceptLast: encoder | codeSize nextToLast | nextToLast := statements size - 1. nextToLast < 1 ifTrue: [^ 0]. "Only one statement" codeSize := 0. 1 to: nextToLast do: [:i | codeSize := codeSize + ((statements at: i) sizeForEffect: encoder)]. ^ codeSize! ! !BlockNode methodsFor: 'code generation'! sizeForEvaluatedEffect: encoder self returns ifTrue: [^self sizeForEvaluatedValue: encoder]. ^(self sizeExceptLast: encoder) + (statements last sizeForEffect: encoder)! ! !BlockNode methodsFor: 'code generation'! sizeForEvaluatedValue: encoder ^(self sizeExceptLast: encoder) + (statements last sizeForValue: encoder)! ! !BlockNode methodsFor: 'code generation'! sizeForValue: encoder nArgsNode := encoder encodeLiteral: arguments size. remoteCopyNode := encoder encodeSelector: #blockCopy:. size := (self sizeForEvaluatedValue: encoder) + (self returns ifTrue: [0] ifFalse: [1]). "endBlock" arguments := arguments collect: "Chance to prepare debugger remote temps" [:arg | arg asStorableNode: encoder]. arguments do: [:arg | size := size + (arg sizeForStorePop: encoder)]. ^1 + (nArgsNode sizeForValue: encoder) + (remoteCopyNode size: encoder args: 1 super: false) + 2 + size! ! !BlockNode methodsFor: 'code generation (closures)' stamp: 'eem 9/3/2009 12:55'! actualScope "Answer the actual scope for the receiver. If this is an unoptimized block then it is its actual scope, but if this is an optimized block then the actual scope is some outer block." ^actualScopeIfOptimized ifNil: [self]! ! !BlockNode methodsFor: 'code generation (closures)' stamp: 'eem 8/4/2009 11:42'! addHoistedTemps: additionalTemporaries "" additionalTemporaries do: [:temp| temp definingScope ifNil: [temp definingScope: self]]. temporaries := (temporaries isNil or: [temporaries isEmpty]) ifTrue: [additionalTemporaries copy] ifFalse: [temporaries last isIndirectTempVector ifTrue: [temporaries allButLast, additionalTemporaries, { temporaries last }] ifFalse: [temporaries, additionalTemporaries]]! ! !BlockNode methodsFor: 'code generation (closures)' stamp: 'eem 7/24/2009 16:43'! addRemoteTemp: aTempVariableNode rootNode: rootNode "" "Add aTempVariableNode to my actualScope's sequence of remote temps. If I am an optimized block then the actual scope is my actualScopeIfOptimized, otherwise it is myself." temporaries isArray ifTrue: [temporaries := temporaries asOrderedCollection]. remoteTempNode == nil ifTrue: [remoteTempNode := RemoteTempVectorNode new name: self remoteTempNodeName index: arguments size + temporaries size type: LdTempType scope: 0. actualScopeIfOptimized ifNil: [temporaries addLast: remoteTempNode. remoteTempNode definingScope: self] ifNotNil: [actualScopeIfOptimized addHoistedTemps: { remoteTempNode }]]. remoteTempNode addRemoteTemp: aTempVariableNode encoder: rootNode encoder. "use remove:ifAbsent: because the deferred analysis for optimized loops can result in the temp has already been hoised into the root." temporaries remove: aTempVariableNode ifAbsent: []. ^remoteTempNode! ! !BlockNode methodsFor: 'code generation (closures)' stamp: 'eem 8/4/2009 13:29'! analyseArguments: methodArguments temporaries: methodTemporaries rootNode: rootNode "" "^>" "Top level entry-point for analysing temps within the hierarchy of blocks in the receiver's method. Answer the (possibly modified) sequence of temp vars. Need to hoist temps out of macro-optimized blocks into their actual blocks. Need to note reads and writes to temps from blocks other than their actual blocks to determine whether blocks can be local (simple slots within a block/method context) or remote (slots in indirection vectors that are shared between contexts by sharing indirection vectors). The algorithm is based on numbering temporary reads and writes and block extents. The index used for numbering starts at zero and is incremented on every block entry and block exit. So the following | a b blk r1 r2 t | a := 1. b := 2. t := 0. blk := [ | s | s := a + b. t := t + s]. r1 := blk value. b := -100. r2 := blk value. r1 -> r2 -> t is numbered as method block 0 to: 6: | a b blk r1 r2 t | a w@1 := 1. b w@1 := 2. t w@1 := 0. blk w@5 := [entry@2 | s | t w@3 := t r@3 + a r@3 + b r@3 ] exit@4. r1 w@5 := blk r@5 value. b w@5 := nil. r2 w@5 := blk r@5 value. r1 r@5 -> r2 r@5 -> t r@5 So: b and blk cannot be copied because for both there exists a write @5 that follows a read @4 within block 2 through 4 t must be remote because there exists a write @3 within block (2 to: 4) Complications are introduced by optimized blocks. In the following temp is written to after it is closed over by [ temp ] since the inlined block is executed more than once. | temp coll | coll := OrderedCollection new. 1 to: 5 do: [ :index | temp := index. coll add: [ temp ] ]. self assert: (coll collect: [:ea| ea value]) asArray = #(5 5 5 5 5) In the following i is local to the block and must be initialized each time around the loop but if the block is inlined it must be declared at method level. | col | col := OrderedCollection new. 1 to: 3 do: [ :each | | i | i := each. col add: [ i ]. i := i + 1 ]. self assert: (col collect: [ :each | each value ]) asArray = #(2 3 4)" self assert: (arguments isEmpty or: [arguments hasEqualElements: methodArguments]). arguments := methodArguments asArray. "won't change" self assert: (temporaries isNil or: [temporaries isEmpty or: [temporaries hasEqualElements: methodTemporaries]]). temporaries := OrderedCollection withAll: methodTemporaries. self assert: optimized not. "the top-level block should not be optimized." self analyseTempsWithin: self rootNode: rootNode assignmentPools: Dictionary new. "The top-level block needs to reindex temporaries since analysis may have rearranged them. This happens when temps are made remote and/or a remote node is added." temporaries withIndexDo: [:temp :offsetPlusOne| temp index: arguments size + offsetPlusOne - 1]. "Answer the (possibly modified) sequence of temps." ^temporaries asArray! ! !BlockNode methodsFor: 'code generation (closures)' stamp: 'eem 8/4/2009 11:42'! analyseTempsWithin: scopeBlock "" rootNode: rootNode "" assignmentPools: assignmentPools "" | effectiveScope blockStart | effectiveScope := optimized ifTrue: [actualScopeIfOptimized := scopeBlock] ifFalse: [self]. arguments ifNotNil: [arguments do: [:temp| temp definingScope: self]]. temporaries ifNotNil: [temporaries do: [:temp| temp definingScope: self]]. optimized ifFalse: "if optimized this isn't an actual scope" [rootNode noteBlockEntry: [:entryNumber| blockExtent := (blockStart := entryNumber) to: 0]]. "Need to enumerate a copy because closure analysis can add a statement via ifHasRemoteTempNodeEnsureInitializationStatementExists:." statements copy do: [:statement| statement analyseTempsWithin: effectiveScope rootNode: rootNode assignmentPools: assignmentPools]. optimized ifFalse: "if optimized this isn't an actual scope" [rootNode noteBlockExit: [:exitNumber| blockExtent := blockStart to: exitNumber]]. "Now that the analysis is done move any temps that need to be moved." self postNumberingProcessTempsWithin: effectiveScope rootNode: rootNode. "This is simply a nicety for compiler developers..." temporaries do: [:temp| (temp isIndirectTempVector and: [temp name includes: $?]) ifTrue: [temp name: temp definingScope remoteTempNodeName]]! ! !BlockNode methodsFor: 'code generation (closures)' stamp: 'eem 5/20/2008 12:16'! blockExtent "^" ^blockExtent! ! !BlockNode methodsFor: 'code generation (closures)' stamp: 'eem 8/4/2009 11:56'! computeCopiedValues: rootNode | referencedValues | referencedValues := rootNode referencedValuesWithinBlockExtent: blockExtent. ^((referencedValues reject: [:temp| temp isDefinedWithinBlockExtent: blockExtent]) asSortedCollection: ParseNode tempSortBlock) asArray! ! !BlockNode methodsFor: 'code generation (closures)' stamp: 'eem 8/4/2008 14:10'! constructClosureCreationNode: encoder copiedValues := self computeCopiedValues: encoder rootNode. encoder supportsClosureOpcodes ifTrue: [^self closureCreationNode]. "Without the bytecode we can still get by." ^MessageNode new receiver: (encoder encodeVariable: 'thisContext') selector: #closureCopy:copiedValues: arguments: (Array with: (encoder encodeLiteral: arguments size) with: (copiedValues isEmpty ifTrue: [NodeNil] ifFalse: [BraceNode new elements: copiedValues])) precedence: 3 from: encoder! ! !BlockNode methodsFor: 'code generation (closures)' stamp: 'eem 8/4/2008 14:10'! emitCodeForClosureValue: stack encoder: encoder "if not supportsClosureOpcodes closureCreationSupportNode is the node for thisContext closureCopy: numArgs [ copiedValues: { values } ]" encoder supportsClosureOpcodes ifTrue: [copiedValues do: [:copiedValue| copiedValue emitCodeForValue: stack encoder: encoder]. closureCreationNode pc: encoder methodStreamPosition + 1. encoder genPushClosureCopyNumCopiedValues: copiedValues size numArgs: arguments size jumpSize: size. stack pop: copiedValues size; push: 1] ifFalse: [closureCreationNode emitCodeForValue: stack encoder: encoder. encoder genJumpLong: size]. "Force a two byte jump." "Emit the body of the block" self emitCodeForEvaluatedClosureValue: stack encoder: encoder! ! !BlockNode methodsFor: 'code generation (closures)' stamp: 'eem 9/12/2008 10:55'! emitCodeForEvaluatedClosureValue: stack encoder: encoder | position | position := stack position. stack position: arguments size + copiedValues size. temporaries size timesRepeat: [NodeNil emitCodeForValue: stack encoder: encoder]. self reindexingLocalsDo: [self emitCodeForEvaluatedValue: stack encoder: encoder] encoder: encoder. self returns ifFalse: [encoder genReturnTopToCaller. pc := encoder methodStreamPosition]. stack position: position! ! !BlockNode methodsFor: 'code generation (closures)' stamp: 'eem 7/24/2009 18:56'! ifHasRemoteTempNodeEnsureInitializationStatementExists: rootNode "If a remoteTempNode has been added ensure a statement exists to initialize it." remoteTempNode ~~ nil ifTrue: [(statements notEmpty and: [statements first isAssignmentNode and: [statements first variable isTemp and: [statements first variable isIndirectTempVector]]]) ifTrue: "If this is a decompiled tree, or if a temporary has been added later in the analysis then there already is a temp vector initialization node." [(statements first variable ~~ remoteTempNode) ifTrue: [statements first variable become: remoteTempNode]. statements first value numElements: remoteTempNode remoteTemps size] ifFalse: [statements addFirst: (remoteTempNode nodeToInitialize: rootNode encoder)]].! ! !BlockNode methodsFor: 'code generation (closures)' stamp: 'eem 5/19/2008 17:12'! noteOptimized optimized := true! ! !BlockNode methodsFor: 'code generation (closures)' stamp: 'eem 7/20/2009 09:52'! optimizedBlockHoistTempsInto: scopeBlock "" "This is a No-op for all nodes except non-optimized BlockNodes." "Let's assume the special > 0 guard in MessageNode>>analyseTempsWithin:forValue:encoder: is correct. Then we can simply hoist our temps up." self assert: (arguments isNil or: [arguments size <= 1]). (arguments notNil and: [arguments notEmpty]) ifTrue: [scopeBlock addHoistedTemps: arguments. arguments := #()]. temporaries notEmpty ifTrue: [scopeBlock addHoistedTemps: temporaries. temporaries := #()]! ! !BlockNode methodsFor: 'code generation (closures)' stamp: 'eem 7/24/2009 16:23'! postNumberingProcessTempsWithin: scopeBlock "" rootNode: rootNode "" "A temp can be local (and copied) if it is not written to after it is captured. A temp cannot be local if it is written to remotely. Need to enumerate a copy of the temporaries because any temps becoming remote will be removed from temporaries in analyseClosure: (and a single remote temp node will get added)" temporaries copy do: [:each| each isIndirectTempVector ifFalse: [each analyseClosure: rootNode]]. "If this is an optimized node we need to hoist temporaries up into the relevant block scope." optimized ifTrue: [self optimizedBlockHoistTempsInto: scopeBlock]. "Now we may have added a remoteTempNode. So we need a statement to initialize it." self ifHasRemoteTempNodeEnsureInitializationStatementExists: rootNode. "Now add all arguments and locals to the pool so that copiedValues can be computed during sizing." rootNode addLocalsToPool: arguments; addLocalsToPool: temporaries! ! !BlockNode methodsFor: 'code generation (closures)' stamp: 'eem 6/2/2008 16:37'! reindexingLocalsDo: aBlock encoder: encoderOrNil "Evaluate aBlock wih arguments, temporaries and copiedValues reindexed for their positions within the receiver's block, restoring the correct indices afterwards. If encoder is not nil remember the temps for this block's extent." | tempIndices result tempsToReindex | self assert: copiedValues notNil. tempsToReindex := arguments asArray, copiedValues, temporaries. tempIndices := tempsToReindex collect: [:temp| temp index]. tempsToReindex withIndexDo: [:temp :newIndex| temp index: newIndex - 1. self assert: temp index + 1 = newIndex]. encoderOrNil ifNotNil: [encoderOrNil noteBlockExtent: blockExtent hasLocals: tempsToReindex]. result := aBlock ensure: ["Horribly pragmatic hack. The copiedValues will have completely unrelated indices within the closure method and sub-method. Avoiding the effort of rebinding temps in the inner scope simply update the indices to their correct ones during the generation of the closure method and restore the indices immedately there-after." tempsToReindex with: tempIndices do: [:temp :oldIndex| temp index: oldIndex. self assert: temp index = oldIndex]]. ^result! ! !BlockNode methodsFor: 'code generation (closures)' stamp: 'eem 7/22/2009 10:48'! remoteTempNodeName "Answer a useful name for a RemoteTempVectorNode in the receiver." | prefix scope extent | prefix := actualScopeIfOptimized ifNil: ['<'] ifNotNil: [ '<...']. scope := self. [extent := scope blockExtent. extent == nil and: [scope actualScope ~~ scope]] whileTrue: [scope := scope actualScope]. ^extent ifNil: [prefix, '?-?>'] ifNotNil: [prefix, extent first printString, '-', (extent last isZero ifTrue: ['?'] ifFalse: [extent last printString]), '>']! ! !BlockNode methodsFor: 'code generation (closures)' stamp: 'eem 8/4/2008 14:11'! sizeCodeForClosureValue: encoder "Compute the size for the creation of the block and its code." "If we have the closure bytecodes constructClosureCreationNode: will note the copied values in the copiedValues inst var and answer #pushCopiedValues." closureCreationNode := self constructClosureCreationNode: encoder. "Remember size of body for emit time so we know the size of the jump around it." size := self sizeCodeForEvaluatedClosureValue: encoder. ^encoder supportsClosureOpcodes ifTrue: [(copiedValues inject: 0 into: [:sum :node| sum + (node sizeCodeForValue: encoder)]) + (encoder sizePushClosureCopyNumCopiedValues: copiedValues size numArgs: arguments size jumpSize: size) + size] ifFalse: ["closureCreationSupportNode is send closureCopy:copiedValues:" (closureCreationNode sizeCodeForValue: encoder) + (encoder sizeJumpLong: size) + size]! ! !BlockNode methodsFor: 'code generation (closures)' stamp: 'eem 5/31/2008 14:31'! sizeCodeForEvaluatedClosureValue: encoder "The closure value primitives push the arguments and the copied values. The compiler guarantees that any copied values come before all local temps. So on closure activation we only need to push nils for the remaining temporaries." ^temporaries size * (NodeNil sizeCodeForValue: encoder) + (self reindexingLocalsDo: [self sizeCodeForEvaluatedValue: encoder] encoder: nil "don't store temps yet") + (self returns ifTrue: [0] ifFalse: [encoder sizeReturnTopToCaller])! ! !BlockNode methodsFor: 'code generation (new scheme)' stamp: 'eem 6/2/2008 13:29'! emitCodeExceptLast: stack encoder: encoder | position nextToLast | position := stack position. nextToLast := statements size - 1. 1 to: nextToLast do: [:i | | statement | statement := statements at: i. statement emitCodeForEffect: stack encoder: encoder. self assert: stack position = position].! ! !BlockNode methodsFor: 'code generation (new scheme)' stamp: 'eem 5/21/2008 11:28'! emitCodeForEvaluatedEffect: stack encoder: encoder | position | position := stack position. self returns ifTrue: [self emitCodeForEvaluatedValue: stack encoder: encoder. stack pop: 1] ifFalse: [self emitCodeExceptLast: stack encoder: encoder. statements last emitCodeForEffect: stack encoder: encoder]. self assert: stack position = position! ! !BlockNode methodsFor: 'code generation (new scheme)' stamp: 'eem 5/21/2008 11:36'! emitCodeForEvaluatedValue: stack encoder: encoder | position | position := stack position. self emitCodeExceptLast: stack encoder: encoder. statements last emitCodeForBlockValue: stack encoder: encoder. self assert: stack position - 1 = position! ! !BlockNode methodsFor: 'code generation (new scheme)' stamp: 'eem 5/20/2008 16:55'! emitCodeForValue: stack encoder: encoder self generateAsClosure ifTrue: [^self emitCodeForClosureValue: stack encoder: encoder]. encoder genPushThisContext. stack push: 1. nArgsNode emitCodeForValue: stack encoder: encoder. remoteCopyNode emitCode: stack args: 1 encoder: encoder. "Force a two byte jump." encoder genJumpLong: size. stack push: arguments size. arguments reverseDo: [:arg | arg emitCodeForStorePop: stack encoder: encoder]. self emitCodeForEvaluatedValue: stack encoder: encoder. self returns ifFalse: [encoder genReturnTopToCaller. pc := encoder methodStreamPosition]. stack pop: 1! ! !BlockNode methodsFor: 'code generation (new scheme)' stamp: 'eem 5/29/2008 15:21'! sizeCodeExceptLast: encoder | codeSize | codeSize := 0. 1 to: statements size - 1 do: [:i | | statement | statement := statements at: i. codeSize := codeSize + (statement sizeCodeForEffect: encoder)]. ^codeSize! ! !BlockNode methodsFor: 'code generation (new scheme)' stamp: 'eem 5/14/2008 17:13'! sizeCodeForEvaluatedEffect: encoder ^self returns ifTrue: [self sizeCodeForEvaluatedValue: encoder] ifFalse: [(self sizeCodeExceptLast: encoder) + (statements last sizeCodeForEffect: encoder)]! ! !BlockNode methodsFor: 'code generation (new scheme)' stamp: 'eem 5/14/2008 14:52'! sizeCodeForEvaluatedValue: encoder ^(self sizeCodeExceptLast: encoder) + (statements last sizeCodeForBlockValue: encoder)! ! !BlockNode methodsFor: 'code generation (new scheme)' stamp: 'eem 5/20/2008 16:55'! sizeCodeForValue: encoder self generateAsClosure ifTrue: [^self sizeCodeForClosureValue: encoder]. nArgsNode := encoder encodeLiteral: arguments size. remoteCopyNode := encoder encodeSelector: #blockCopy:. size := self sizeCodeForEvaluatedValue: encoder. self returns ifFalse: [size := size + encoder sizeReturnTopToCaller]. "endBlock" arguments := arguments collect: "Chance to prepare debugger remote temps" [:arg | arg asStorableNode: encoder]. arguments do: [:arg | size := size + (arg sizeCodeForStorePop: encoder)]. ^encoder sizePushThisContext + (nArgsNode sizeCodeForValue: encoder) + (remoteCopyNode sizeCode: encoder args: 1 super: false) + (encoder sizeJumpLong: size) + size! ! !BlockNode methodsFor: 'equation translation'! statements ^statements! ! !BlockNode methodsFor: 'equation translation'! statements: val statements := val! ! !BlockNode methodsFor: 'initialize-release' stamp: 'eem 5/20/2008 13:40'! arguments: argNodes statements: statementsCollection returns: returnBool from: encoder "Compile." arguments := argNodes. statements := statementsCollection size > 0 ifTrue: [statementsCollection] ifFalse: [argNodes size > 0 ifTrue: [statementsCollection copyWith: arguments last] ifFalse: [Array with: NodeNil]]. optimized := false. returns := returnBool! ! !BlockNode methodsFor: 'initialize-release' stamp: 'eem 8/4/2008 14:12'! noteSourceRangeStart: start end: end encoder: encoder "Note two source ranges for this node. One is for the debugger and is of the last expression, the result of the block. One is for source analysis and is for the entire block." encoder noteSourceRange: (start to: end) forNode: self closureCreationNode. startOfLastStatement ifNil: [encoder noteSourceRange: (start to: end) forNode: self] ifNotNil: [encoder noteSourceRange: (startOfLastStatement to: end - 1) forNode: self]! ! !BlockNode methodsFor: 'initialize-release' stamp: 'eem 5/20/2008 13:40'! statements: statementsCollection returns: returnBool "Decompile." | returnLast | returnLast := returnBool. returns := false. statements := (statementsCollection size > 1 and: [(statementsCollection at: statementsCollection size - 1) isReturningIf]) ifTrue: [returnLast := false. statementsCollection allButLast] ifFalse: [statementsCollection size = 0 ifTrue: [Array with: NodeNil] ifFalse: [statementsCollection]]. arguments := #(). temporaries := #(). optimized := false. returnLast ifTrue: [self returnLast]! ! !BlockNode methodsFor: 'printing' stamp: 'alain.plantec 5/18/2009 15:34'! decompileString "Answer a string description of the parse tree whose root is the receiver." ^ self printString ! ! !BlockNode methodsFor: 'printing' stamp: 'eem 5/6/2008 14:28'! printArgumentsOn: aStream indent: level arguments size = 0 ifTrue: [^ self]. arguments do: [:arg | aStream nextPut: $:; nextPutAll: arg key; space]. aStream nextPut: $|; space. "If >0 args and >1 statement, put all statements on separate lines" statements size > 1 ifTrue: [aStream crtab: level]! ! !BlockNode methodsFor: 'printing' stamp: 'eem 9/25/2008 12:48'! printOn: aStream indent: level "statements size <= 1 ifFalse: [aStream crtab: level]." aStream nextPut: $[. self printArgumentsOn: aStream indent: level. (self printTemporaries: temporaries on: aStream doPrior: []) ifTrue: ["If >0 temps and >1 statement, put all statements on separate lines" statements size > 1 ifTrue: [aStream crtab: level] ifFalse: [aStream space]]. self printStatementsOn: aStream indent: level. aStream nextPut: $]! ! !BlockNode methodsFor: 'printing' stamp: 'eem 9/23/2008 15:05'! printStatementsOn: aStream indent: levelOrZero | len shown thisStatement level | level := 1 max: levelOrZero. comment == nil ifFalse: [self printCommentOn: aStream indent: level. aStream crtab: level]. len := shown := statements size. (levelOrZero = 0 "top level" and: [statements last isReturnSelf]) ifTrue: [shown := 1 max: shown - 1] ifFalse: ["should a trailing nil be printed or not? Not if it is an implicit result." (arguments size = 0 and: [len >= 1 and: [(statements at: len) == NodeNil and: [len = 1 or: [len > 1 and: [(statements at: len - 1) isMessageNode and: [(statements at: len - 1) isNilIf]]]]]]) ifTrue: [shown := shown - 1]]. 1 to: shown do: [:i | thisStatement := statements at: i. thisStatement printOn: aStream indent: level. i < shown ifTrue: [aStream nextPut: $.; crtab: level]. (thisStatement comment ~~ nil and: [thisStatement comment size > 0]) ifTrue: [i = shown ifTrue: [aStream crtab: level]. thisStatement printCommentOn: aStream indent: level. i < shown ifTrue: [aStream crtab: level]]]! ! !BlockNode methodsFor: 'printing' stamp: 'eem 7/21/2009 13:12'! printTemporaries: tempSequence on: aStream doPrior: aBlock "Print any in-scope temporaries. If there are any evaluate aBlock prior to printing. Answer whether any temporaries were printed." | tempStream seen | tempSequence ifNil: [^false]. tempStream := (String new: 16) writeStream. "This is for the decompiler which canmot work out which optimized block a particular temp is local to and hence may produce diplicates as in expr ifTrue: [| aTemp | ...] ifFalse: [| aTemp | ...]" seen := Set new. tempSequence do: [:tempNode | tempNode isIndirectTempVector ifTrue: [tempNode remoteTemps do: [:tempVariableNode| (tempVariableNode scope >= 0 and: [(seen includes: tempNode key) not]) ifTrue: [tempStream space; nextPutAll: (seen add: tempVariableNode key)]]] ifFalse: [(tempNode scope >= -1 and: ["This is for the decompiler which may create a block arg when converting a while into a to:do: but won't remove it form temporaries" tempNode isBlockArg not and: [(seen includes: tempNode key) not]]) ifTrue: [tempStream space; nextPutAll: (seen add: tempNode key)]]]. tempStream position = 0 ifTrue: [^false]. aBlock value. aStream nextPut: $|; nextPutAll: tempStream contents; space; nextPut: $|. ^true! ! !BlockNode methodsFor: 'printing' stamp: 'eem 6/2/2008 12:06'! printWithClosureAnalysisArgumentsOn: aStream indent: level arguments size = 0 ifTrue: [^self]. arguments do: [:tempNode | aStream space; nextPut: $:. tempNode printDefinitionForClosureAnalysisOn: aStream]. aStream nextPut: $|; space. "If >0 args and >1 statement, put all statements on separate lines" statements size > 1 ifTrue: [aStream crtab: level]! ! !BlockNode methodsFor: 'printing' stamp: 'eem 6/2/2008 11:53'! printWithClosureAnalysisOn: aStream indent: level aStream nextPut: $[. blockExtent ifNotNil: [aStream print: blockExtent]. self printWithClosureAnalysisArgumentsOn: aStream indent: level. self printWithClosureAnalysisTemporariesOn: aStream indent: level. self printWithClosureAnalysisStatementsOn: aStream indent: level. aStream nextPut: $]! ! !BlockNode methodsFor: 'printing' stamp: 'eem 6/2/2008 11:48'! printWithClosureAnalysisStatementsOn: aStream indent: levelOrZero | len shown thisStatement level | level := 1 max: levelOrZero. comment == nil ifFalse: [self printCommentOn: aStream indent: level. aStream crtab: level]. len := shown := statements size. (levelOrZero = 0 "top level" and: [statements last isReturnSelf]) ifTrue: [shown := 1 max: shown - 1] ifFalse: [(len = 1 and: [((statements at: 1) == NodeNil) & (arguments size = 0)]) ifTrue: [shown := shown - 1]]. 1 to: shown do: [:i | thisStatement := statements at: i. thisStatement printWithClosureAnalysisOn: aStream indent: level. i < shown ifTrue: [aStream nextPut: $.; crtab: level]. (thisStatement comment ~~ nil and: [thisStatement comment size > 0]) ifTrue: [i = shown ifTrue: [aStream crtab: level]. thisStatement printCommentOn: aStream indent: level. i < shown ifTrue: [aStream crtab: level]]]! ! !BlockNode methodsFor: 'printing' stamp: 'eem 6/2/2008 11:54'! printWithClosureAnalysisTemporariesOn: aStream indent: level (temporaries == nil or: [temporaries size = 0]) ifFalse: [aStream nextPut: $|. temporaries do: [:tempNode | aStream space. tempNode printDefinitionForClosureAnalysisOn: aStream]. aStream nextPutAll: ' | '. "If >0 args and >1 statement, put all statements on separate lines" statements size > 1 ifTrue: [aStream crtab: level]]! ! !BlockNode methodsFor: 'testing'! canBeSpecialArgument "Can I be an argument of (e.g.) ifTrue:?" ^arguments size = 0! ! !BlockNode methodsFor: 'testing' stamp: 'eem 7/17/2008 12:20'! generateAsClosure "Answer if we're compiling under the closure regime. If blockExtent has been set by analyseTempsWithin:rootNode: et al then we're compiling under the closure regime." ^blockExtent ~~ nil! ! !BlockNode methodsFor: 'testing' stamp: 'eem 9/25/2008 12:10'! isBlockNode ^true! ! !BlockNode methodsFor: 'testing'! isComplex ^statements size > 1 or: [statements size = 1 and: [statements first isComplex]]! ! !BlockNode methodsFor: 'testing'! isJust: node returns ifTrue: [^false]. ^statements size = 1 and: [statements first == node]! ! !BlockNode methodsFor: 'testing'! isJustCaseError ^ statements size = 1 and: [statements first isMessage: #caseError receiver: [:r | r==NodeSelf] arguments: nil]! ! !BlockNode methodsFor: 'testing'! isQuick ^ statements size = 1 and: [statements first isVariableReference or: [statements first isSpecialConstant]]! ! !BlockNode methodsFor: 'testing'! returns ^returns or: [statements last isReturningIf]! ! !BlockNode methodsFor: 'visiting' stamp: 'eem 9/10/2008 15:13'! accept: aVisitor aVisitor visitBlockNode: self! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! BlockNode class instanceVariableNames: ''! !BlockNode class methodsFor: 'instance creation' stamp: 'sma 3/3/2000 13:34'! statements: statements returns: returns ^ self new statements: statements returns: returns! ! !BlockNode class methodsFor: 'instance creation' stamp: 'eem 5/19/2008 17:10'! withJust: aNode ^ self new statements: (Array with: aNode) returns: false! ! InstructionClient subclass: #BlockStartLocator instanceVariableNames: 'nextJumpIsAroundBlock' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Methods'! !BlockStartLocator methodsFor: 'initialize-release' stamp: 'alain.plantec 5/28/2009 09:43'! initialize super initialize. nextJumpIsAroundBlock := false! ! !BlockStartLocator methodsFor: 'instruction decoding' stamp: 'eem 5/31/2008 13:48'! jump: offset "If this jump is around a block answer the size of that block." nextJumpIsAroundBlock ifTrue: [nextJumpIsAroundBlock := false. ^offset]! ! !BlockStartLocator methodsFor: 'instruction decoding' stamp: 'eem 5/31/2008 13:54'! pushClosureCopyNumCopiedValues: numCopied numArgs: numArgs blockSize: blockSize "Answer the size of the block" ^blockSize! ! !BlockStartLocator methodsFor: 'instruction decoding' stamp: 'eem 5/31/2008 14:16'! send: selector super: supered numArgs: numberArguments nextJumpIsAroundBlock := #closureCopy:copiedValues: == selector "Don't use nextJumpIsAroundBlock := #(blockCopy: closureCopy:copiedValues:) includes: selector since BlueBook BlockContexts do not have their own temps."! ! Object subclass: #Boolean instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Objects'! !Boolean commentStamp: '' prior: 0! Boolean is an abstract class defining the protocol for logic testing operations and conditional control structures for the logical values represented by the instances of its subclasses True and False. Boolean redefines #new so no instances of Boolean can be created. It also redefines several messages in the 'copying' protocol to ensure that only one instance of each of its subclasses True (the global true, logical assertion) and False (the global false, logical negation) ever exist in the system.! !Boolean methodsFor: 'controlling'! and: alternativeBlock "Nonevaluating conjunction. If the receiver is true, answer the value of the argument, alternativeBlock; otherwise answer false without evaluating the argument." self subclassResponsibility! ! !Boolean methodsFor: 'controlling' stamp: 'zz 3/2/2004 23:44'! and: block1 and: block2 "Nonevaluating conjunction without deep nesting. The receiver is evaluated, followed by the blocks in order. If any of these evaluates as false, then return false immediately, without evaluating any further blocks. If all return true, then return true." self ifFalse: [^ false]. block1 value ifFalse: [^ false]. block2 value ifFalse: [^ false]. ^ true! ! !Boolean methodsFor: 'controlling' stamp: 'zz 3/2/2004 23:44'! and: block1 and: block2 and: block3 "Nonevaluating conjunction without deep nesting. The receiver is evaluated, followed by the blocks in order. If any of these evaluates as false, then return false immediately, without evaluating any further blocks. If all return true, then return true." self ifFalse: [^ false]. block1 value ifFalse: [^ false]. block2 value ifFalse: [^ false]. block3 value ifFalse: [^ false]. ^ true! ! !Boolean methodsFor: 'controlling' stamp: 'zz 3/2/2004 23:44'! and: block1 and: block2 and: block3 and: block4 "Nonevaluating conjunction without deep nesting. The receiver is evaluated, followed by the blocks in order. If any of these evaluates as false, then return false immediately, without evaluating any further blocks. If all return true, then return true." self ifFalse: [^ false]. block1 value ifFalse: [^ false]. block2 value ifFalse: [^ false]. block3 value ifFalse: [^ false]. block4 value ifFalse: [^ false]. ^ true! ! !Boolean methodsFor: 'controlling'! ifFalse: alternativeBlock "If the receiver is true (i.e., the condition is true), then the value is the true alternative, which is nil. Otherwise answer the result of evaluating the argument, alternativeBlock. Create an error notification if the receiver is nonBoolean. Execution does not actually reach here because the expression is compiled in-line." self subclassResponsibility! ! !Boolean methodsFor: 'controlling'! ifFalse: falseAlternativeBlock ifTrue: trueAlternativeBlock "Same as ifTrue:ifFalse:." self subclassResponsibility! ! !Boolean methodsFor: 'controlling'! ifTrue: alternativeBlock "If the receiver is false (i.e., the condition is false), then the value is the false alternative, which is nil. Otherwise answer the result of evaluating the argument, alternativeBlock. Create an error notification if the receiver is nonBoolean. Execution does not actually reach here because the expression is compiled in-line." self subclassResponsibility! ! !Boolean methodsFor: 'controlling'! ifTrue: trueAlternativeBlock ifFalse: falseAlternativeBlock "If the receiver is true (i.e., the condition is true), then answer the value of the argument trueAlternativeBlock. If the receiver is false, answer the result of evaluating the argument falseAlternativeBlock. If the receiver is a nonBoolean then create an error notification. Execution does not actually reach here because the expression is compiled in-line." self subclassResponsibility! ! !Boolean methodsFor: 'controlling'! or: alternativeBlock "Nonevaluating disjunction. If the receiver is false, answer the value of the argument, alternativeBlock; otherwise answer true without evaluating the argument." self subclassResponsibility! ! !Boolean methodsFor: 'controlling' stamp: 'zz 3/2/2004 23:45'! or: block1 or: block2 "Nonevaluating alternation without deep nesting. The receiver is evaluated, followed by the blocks in order. If any of these evaluates as true, then return true immediately, without evaluating any further blocks. If all return false, then return false." self ifTrue: [^ true]. block1 value ifTrue: [^ true]. block2 value ifTrue: [^ true]. ^ false! ! !Boolean methodsFor: 'controlling' stamp: 'zz 3/2/2004 23:45'! or: block1 or: block2 or: block3 "Nonevaluating alternation without deep nesting. The receiver is evaluated, followed by the blocks in order. If any of these evaluates as true, then return true immediately, without evaluating any further blocks. If all return false, then return false." self ifTrue: [^ true]. block1 value ifTrue: [^ true]. block2 value ifTrue: [^ true]. block3 value ifTrue: [^ true]. ^ false! ! !Boolean methodsFor: 'controlling' stamp: 'zz 3/2/2004 23:45'! or: block1 or: block2 or: block3 or: block4 "Nonevaluating alternation without deep nesting. The receiver is evaluated, followed by the blocks in order. If any of these evaluates as true, then return true immediately, without evaluating any further blocks. If all return false, then return false." self ifTrue: [^ true]. block1 value ifTrue: [^ true]. block2 value ifTrue: [^ true]. block3 value ifTrue: [^ true]. block4 value ifTrue: [^ true]. ^ false! ! !Boolean methodsFor: 'controlling' stamp: 'dgd 9/26/2004 19:05'! or: block1 or: block2 or: block3 or: block4 or: block5 "Nonevaluating alternation without deep nesting. The receiver is evaluated, followed by the blocks in order. If any of these evaluates as true, then return true immediately, without evaluating any further blocks. If all return false, then return false." self ifTrue: [^ true]. block1 value ifTrue: [^ true]. block2 value ifTrue: [^ true]. block3 value ifTrue: [^ true]. block4 value ifTrue: [^ true]. block5 value ifTrue: [^ true]. ^ false! ! !Boolean methodsFor: 'copying' stamp: 'tk 6/26/1998 11:32'! clone "Receiver has two concrete subclasses, True and False. Only one instance of each should be made, so return self."! ! !Boolean methodsFor: 'copying'! deepCopy "Receiver has two concrete subclasses, True and False. Only one instance of each should be made, so return self."! ! !Boolean methodsFor: 'copying'! shallowCopy "Receiver has two concrete subclasses, True and False. Only one instance of each should be made, so return self."! ! !Boolean methodsFor: 'copying' stamp: 'tk 8/20/1998 16:07'! veryDeepCopyWith: deepCopier "Return self. I can't be copied. Do not record me."! ! !Boolean methodsFor: 'logical operations'! & aBoolean "Evaluating conjunction. Evaluate the argument. Then answer true if both the receiver and the argument are true." self subclassResponsibility! ! !Boolean methodsFor: 'logical operations' stamp: 'stephane.ducasse 5/20/2009 21:28'! ==> aBlock "The material conditional, also known as the material implication or truth functional conditional. Correspond to not ... or ... and does not correspond to the English if...then... construction. known as: b if a a implies b if a then b b is a consequence of a a therefore b (but note: 'it is raining therefore it is cloudy' is implication; 'it is autumn therefore the leaves are falling' is equivalence). Here is the truth table for material implication: p | q | p ==> q -------|-------|------------- T | T | T T | F | F F | T | T F | F | T " ^self not or: [aBlock value]! ! !Boolean methodsFor: 'logical operations'! eqv: aBoolean "Answer true if the receiver is equivalent to aBoolean." ^self == aBoolean! ! !Boolean methodsFor: 'logical operations'! not "Negation. Answer true if the receiver is false, answer false if the receiver is true." self subclassResponsibility! ! !Boolean methodsFor: 'logical operations'! | aBoolean "Evaluating disjunction (OR). Evaluate the argument. Then answer true if either the receiver or the argument is true." self subclassResponsibility! ! !Boolean methodsFor: 'printing' stamp: 'sw 9/27/2001 17:19'! basicType "Answer a symbol representing the inherent type of the receiver" ^ #Boolean! ! !Boolean methodsFor: 'printing' stamp: 'apb 4/21/2006 09:22'! isLiteral ^ true! ! !Boolean methodsFor: 'printing'! storeOn: aStream "Refer to the comment in Object|storeOn:." self printOn: aStream! ! !Boolean methodsFor: 'self evaluating' stamp: 'sd 7/31/2005 21:45'! isSelfEvaluating ^ true! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Boolean class instanceVariableNames: ''! !Boolean class methodsFor: 'instance creation' stamp: 'sw 5/5/2000 00:31'! initializedInstance ^ nil! ! !Boolean class methodsFor: 'instance creation'! new self error: 'You may not create any more Booleans - this is two-valued logic'! ! PreferenceView subclass: #BooleanPreferenceView instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'System-Support'! !BooleanPreferenceView commentStamp: '' prior: 0! I am responsible for building the visual representation of a preference that accepts true and false values! !BooleanPreferenceView methodsFor: 'user interface' stamp: 'alain.plantec 5/30/2008 09:57'! offerPreferenceNameMenu: aPanel with: ignored1 in: ignored2 "the user clicked on a preference name -- put up a menu" | aMenu | ActiveHand showTemporaryCursor: nil. aMenu := MenuMorph new defaultTarget: self preference. aMenu addTitle: self preference name. (Preferences okayToChangeProjectLocalnessOf: self preference name) ifTrue: [aMenu addUpdating: #isProjectLocalString target: self preference action: #toggleProjectLocalness. aMenu balloonTextForLastItem: 'Some preferences are best applied uniformly to all projects, and others are best set by each individual project. If this item is checked, then this preference will be printed in bold and will have a separate value for each project']. aMenu add: 'browse senders' target: self systemNavigation selector: #browseAllCallsOn: argument: self preference name. aMenu balloonTextForLastItem: 'This will open a method-list browser on all methods that the send the preference "', self preference name, '".'. aMenu add: 'show category...' target: aPanel selector: #findCategoryFromPreference: argument: self preference name. aMenu balloonTextForLastItem: 'Allows you to find out which category, or categories, this preference belongs to.'. aMenu add: 'hand me a button for this preference' target: self selector: #tearOffButton. aMenu balloonTextForLastItem: 'Will give you a button that governs this preference, which you may deposit wherever you wish'. aMenu add: 'copy this name to clipboard' target: self preference selector: #copyName. aMenu balloonTextForLastItem: 'Copy the name of the preference to the text clipboard, so that you can paste into code somewhere'. aMenu popUpInWorld! ! !BooleanPreferenceView methodsFor: 'user interface' stamp: 'md 9/5/2005 15:40'! 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: (StrikeFont familyName: 'NewYork' size: 12). self preference localToProject ifTrue: [str emphasis: TextEmphasis bold emphasisCode]. miniWrapper := AlignmentMorph newRow hResizing: #shrinkWrap; vResizing: #shrinkWrap. 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'] ifNil: "We're a naked button, not in a panel" [miniWrapper setBalloonText: self preference helpString; setProperty: #balloonTarget toValue: aButton]. outerButton addMorphBack: miniWrapper. outerButton setNameTo: self preference name. aButton setBalloonText: self preference helpString. ^ outerButton "(Preferences preferenceAt: #balloonHelpEnabled) view tearOffButton"! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! BooleanPreferenceView class instanceVariableNames: ''! !BooleanPreferenceView class methodsFor: 'initialization' stamp: 'hpt 9/26/2004 15:55'! initialize PreferenceViewRegistry ofBooleanPreferences register: self.! ! !BooleanPreferenceView class methodsFor: 'initialization' stamp: 'hpt 9/26/2004 15:55'! unload PreferenceViewRegistry ofBooleanPreferences unregister: self.! ! !BooleanPreferenceView class methodsFor: 'view registry' stamp: 'alain.plantec 6/6/2009 22:38'! handlesPanel: aPreferencePanel ^false! ! ClassTestCase subclass: #BooleanTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'KernelTests-Objects'! !BooleanTest commentStamp: '' prior: 0! This is the unit test for the class Boolean. Unit tests are a good way to exercise the functionality of your system in a repeatable and automatic manner. They are therefore recommended if you plan to release anything. For more information, see: - http://www.c2.com/cgi/wiki?UnitTest - http://minnow.cc.gatech.edu/squeak/1547 - the sunit class category ! !BooleanTest methodsFor: 'tests' stamp: 'sd 6/5/2005 09:02'! testBooleanInitializedInstance self assert: (Boolean initializedInstance = nil).! ! !BooleanTest methodsFor: 'tests' stamp: 'sd 6/5/2005 09:02'! testBooleanNew self should: [Boolean new] raise: TestResult error. self should: [True new] raise: TestResult error. self should: [False new] raise: TestResult error. ! ! !BooleanTest methodsFor: 'tests' stamp: 'sd 6/5/2005 09:02'! testNew self should: [Boolean new] raise: TestResult error. ! ! Object subclass: #BorderStyle instanceVariableNames: '' classVariableNames: 'Default' poolDictionaries: '' category: 'Morphic-Borders'! !BorderStyle commentStamp: 'kfr 10/27/2003 10:19' prior: 0! See BorderedMorph BorderedMorh new borderStyle: (BorderStyle inset width: 2); openInWorld.! !BorderStyle methodsFor: '*Polymorph-Widgets' stamp: 'gvc 6/25/2008 12:09'! hasFillStyle "Answer false." ^false! ! !BorderStyle methodsFor: '*Polymorph-Widgets' stamp: 'gvc 3/14/2007 10:31'! isComposite "Answer false." ^false! ! !BorderStyle methodsFor: '*Polymorph-Widgets' stamp: 'gvc 2/25/2009 15:35'! printOn: aStream "Print a description of the receiver on the given stream." self storeOn: aStream! ! !BorderStyle methodsFor: '*Polymorph-Widgets' stamp: 'gvc 2/25/2009 15:34'! storeOn: aStream "Store a reconstructable representation of the receiver on the given stream." aStream nextPutAll: '(' , self class name; nextPutAll: ' width: '; print: self width; nextPutAll: ' color: '; print: self color; nextPutAll: ')'! ! !BorderStyle methodsFor: 'accessing' stamp: 'ar 8/25/2001 18:15'! baseColor ^Color transparent! ! !BorderStyle methodsFor: 'accessing' stamp: 'ar 8/25/2001 18:15'! baseColor: aColor "Ignored"! ! !BorderStyle methodsFor: 'accessing' stamp: 'ar 8/25/2001 16:07'! color ^Color transparent! ! !BorderStyle methodsFor: 'accessing' stamp: 'ar 8/25/2001 16:07'! color: aColor "Ignored"! ! !BorderStyle methodsFor: 'accessing' stamp: 'ar 11/26/2001 15:22'! colorsAtCorners ^Array new: 4 withAll: self color! ! !BorderStyle methodsFor: 'accessing' stamp: 'ar 8/25/2001 16:07'! dotOfSize: diameter forDirection: aDirection | form | form := Form extent: diameter@diameter depth: Display depth. form getCanvas fillOval: form boundingBox color: self color. ^form! ! !BorderStyle methodsFor: 'accessing' stamp: 'ar 8/25/2001 17:51'! style ^#none! ! !BorderStyle methodsFor: 'accessing' stamp: 'ar 8/25/2001 16:07'! width ^0! ! !BorderStyle methodsFor: 'accessing' stamp: 'ar 8/25/2001 16:07'! width: aNumber "Ignored"! ! !BorderStyle methodsFor: 'accessing' stamp: 'ar 8/25/2001 16:08'! widthForRounding ^self width! ! !BorderStyle methodsFor: 'color tracking' stamp: 'ar 8/25/2001 17:29'! trackColorFrom: aMorph "If necessary, update our color to reflect a change in aMorphs color"! ! !BorderStyle methodsFor: 'comparing' stamp: 'ar 8/25/2001 18:38'! = aBorderStyle ^self species = aBorderStyle species and:[self style == aBorderStyle style and:[self width = aBorderStyle width and:[self color = aBorderStyle color]]].! ! !BorderStyle methodsFor: 'comparing' stamp: 'ar 8/25/2001 16:08'! hash "hash is implemented because #= is implemented" ^self species hash bitXor: (self width hash bitXor: self color hash)! ! !BorderStyle methodsFor: 'drawing' stamp: 'ar 8/25/2001 17:01'! drawLineFrom: startPoint to: stopPoint on: aCanvas ^aCanvas line: startPoint to: stopPoint width: self width color: self color! ! !BorderStyle methodsFor: 'drawing' stamp: 'ar 8/25/2001 16:24'! frameOval: aRectangle on: aCanvas "Frame the given rectangle on aCanvas" aCanvas frameOval: aRectangle width: self width color: self color! ! !BorderStyle methodsFor: 'drawing' stamp: 'ar 8/25/2001 16:57'! framePolygon: vertices on: aCanvas "Frame the given rectangle on aCanvas" self framePolyline: vertices on: aCanvas. self drawLineFrom: vertices last to: vertices first on: aCanvas.! ! !BorderStyle methodsFor: 'drawing' stamp: 'dgd 2/21/2003 22:59'! framePolyline: vertices on: aCanvas "Frame the given rectangle on aCanvas" | prev next | prev := vertices first. 2 to: vertices size do: [:i | next := vertices at: i. self drawLineFrom: prev to: next on: aCanvas. prev := next]! ! !BorderStyle methodsFor: 'drawing' stamp: 'ar 8/25/2001 16:24'! frameRectangle: aRectangle on: aCanvas "Frame the given rectangle on aCanvas" aCanvas frameRectangle: aRectangle width: self width color: self color! ! !BorderStyle methodsFor: 'initialize' stamp: 'ar 8/25/2001 16:06'! releaseCachedState "Release any associated cached state"! ! !BorderStyle methodsFor: 'testing' stamp: 'ar 8/25/2001 16:08'! isBorderStyle ^true! ! !BorderStyle methodsFor: 'testing' stamp: 'ar 8/26/2001 19:30'! isComplex ^false! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! BorderStyle class instanceVariableNames: ''! !BorderStyle class methodsFor: '*Polymorph-Widgets' stamp: 'gvc 8/8/2007 17:20'! dashed "Answer a dashed border style" ^DashedBorder new! ! !BorderStyle class methodsFor: 'instance creation' stamp: 'sw 11/26/2001 16:05'! borderStyleChoices "Answer the superset of all supported borderStyle symbols" ^ #(simple inset raised complexAltFramed complexAltInset complexAltRaised complexFramed complexInset complexRaised)! ! !BorderStyle class methodsFor: 'instance creation' stamp: 'yo 7/2/2004 17:21'! borderStyleForSymbol: sym "Answer a border style corresponding to the given symbol" | aSymbol | aSymbol := sym == #none ifTrue: [#simple] ifFalse: [sym]. ^ self perform: aSymbol " | aSymbol selector | aSymbol := sym == #none ifTrue: [#simple] ifFalse: [sym]. selector := Vocabulary eToyVocabulary translationKeyFor: aSymbol. selector isNil ifTrue: [selector := aSymbol]. ^ self perform: selector " ! ! !BorderStyle class methodsFor: 'instance creation' stamp: 'ar 8/25/2001 23:52'! color: aColor width: aNumber ^self width: aNumber color: aColor! ! !BorderStyle class methodsFor: 'instance creation' stamp: 'ar 11/26/2001 15:01'! complexAltFramed ^ComplexBorder style: #complexAltFramed! ! !BorderStyle class methodsFor: 'instance creation' stamp: 'ar 11/26/2001 15:01'! complexAltInset ^ComplexBorder style: #complexAltInset! ! !BorderStyle class methodsFor: 'instance creation' stamp: 'ar 11/26/2001 15:00'! complexAltRaised ^ComplexBorder style: #complexAltRaised! ! !BorderStyle class methodsFor: 'instance creation' stamp: 'ar 11/26/2001 15:00'! complexFramed ^ComplexBorder style: #complexFramed! ! !BorderStyle class methodsFor: 'instance creation' stamp: 'ar 11/26/2001 15:00'! complexInset ^ComplexBorder style: #complexInset! ! !BorderStyle class methodsFor: 'instance creation' stamp: 'ar 11/26/2001 15:00'! complexRaised ^ComplexBorder style: #complexRaised! ! !BorderStyle class methodsFor: 'instance creation' stamp: 'ar 8/25/2001 17:26'! default ^Default ifNil:[Default := self new]! ! !BorderStyle class methodsFor: 'instance creation' stamp: 'ar 11/26/2001 14:59'! inset ^InsetBorder new! ! !BorderStyle class methodsFor: 'instance creation' stamp: 'ar 11/26/2001 14:59'! raised ^RaisedBorder new! ! !BorderStyle class methodsFor: 'instance creation' stamp: 'sw 11/27/2001 15:22'! simple "Answer a simple border style" ^ SimpleBorder new! ! !BorderStyle class methodsFor: 'instance creation' stamp: 'rr 6/21/2005 13:50'! thinGray ^ self width: 1 color: Color gray! ! !BorderStyle class methodsFor: 'instance creation' stamp: 'ar 8/25/2001 16:19'! width: aNumber ^self width: aNumber color: Color black! ! !BorderStyle class methodsFor: 'instance creation' stamp: 'ar 8/25/2001 16:19'! width: aNumber color: aColor ^SimpleBorder new color: aColor; width: aNumber; yourself! ! Morph subclass: #BorderedMorph instanceVariableNames: 'borderWidth borderColor' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Kernel'! !BorderedMorph commentStamp: 'kfr 10/27/2003 11:17' prior: 0! BorderedMorph introduce borders to morph. Borders have the instanceVariables borderWidth and borderColor. BorderedMorph new borderColor: Color red; borderWidth: 10; openInWorld. BorderedMorph also have a varaity of border styles: simple, inset, raised, complexAltFramed, complexAltInset, complexAltRaised, complexFramed, complexInset, complexRaised. These styles are set using the classes BorderStyle, SimpleBorder, RaisedBorder, InsetBorder and ComplexBorder. BorderedMorph new borderStyle: (SimpleBorder width: 1 color: Color white); openInWorld. BorderedMorph new borderStyle: (BorderStyle inset width: 2); openInWorld. ! !BorderedMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 5/9/2006 15:50'! colorForInsets "Return the color to be used for shading inset borders." self owner isSystemWindow ifTrue: [^self owner colorForInsets]. ^super colorForInsets! ! !BorderedMorph methodsFor: 'accessing' stamp: 'sw 8/6/97 14:34'! borderColor ^ borderColor! ! !BorderedMorph methodsFor: 'accessing' stamp: 'ar 8/17/2001 16:52'! borderColor: colorOrSymbolOrNil self doesBevels ifFalse:[ colorOrSymbolOrNil isColor ifFalse:[^self]]. borderColor = colorOrSymbolOrNil ifFalse: [ borderColor := colorOrSymbolOrNil. self changed]. ! ! !BorderedMorph methodsFor: 'accessing' stamp: 'di 6/20/97 11:24'! borderInset self borderColor: #inset! ! !BorderedMorph methodsFor: 'accessing' stamp: 'di 6/20/97 11:25'! borderRaised self borderColor: #raised! ! !BorderedMorph methodsFor: 'accessing' stamp: 'aoy 2/17/2003 01:19'! borderStyle "Work around the borderWidth/borderColor pair" | style | borderColor ifNil: [^BorderStyle default]. borderWidth isZero ifTrue: [^BorderStyle default]. style := self valueOfProperty: #borderStyle ifAbsent: [BorderStyle default]. (borderWidth = style width and: ["Hah!! Try understanding this..." borderColor == style style or: ["#raised/#inset etc" #simple == style style and: [borderColor = style color]]]) ifFalse: [style := borderColor isColor ifTrue: [BorderStyle width: borderWidth color: borderColor] ifFalse: [(BorderStyle perform: borderColor) width: borderWidth "argh."]. self setProperty: #borderStyle toValue: style]. ^style trackColorFrom: self! ! !BorderedMorph methodsFor: 'accessing' stamp: 'dgd 2/21/2003 22:42'! borderStyle: aBorderStyle "Work around the borderWidth/borderColor pair" aBorderStyle = self borderStyle ifTrue: [^self]. "secure against invalid border styles" (self canDrawBorder: aBorderStyle) ifFalse: ["Replace the suggested border with a simple one" ^self borderStyle: (BorderStyle width: aBorderStyle width color: (aBorderStyle trackColorFrom: self) color)]. aBorderStyle width = self borderStyle width ifFalse: [self changed]. (aBorderStyle isNil or: [aBorderStyle == BorderStyle default]) ifTrue: [self removeProperty: #borderStyle. borderWidth := 0. ^self changed]. self setProperty: #borderStyle toValue: aBorderStyle. borderWidth := aBorderStyle width. borderColor := aBorderStyle style == #simple ifTrue: [aBorderStyle color] ifFalse: [aBorderStyle style]. self changed! ! !BorderedMorph methodsFor: 'accessing' stamp: 'di 6/20/97 11:09'! borderWidth ^ borderWidth! ! !BorderedMorph methodsFor: 'accessing' stamp: 'di 6/4/1999 09:42'! borderWidth: anInteger borderColor ifNil: [borderColor := Color black]. borderWidth := anInteger max: 0. self changed! ! !BorderedMorph methodsFor: 'accessing' stamp: 'di 6/20/97 11:19'! doesBevels "To return true means that this object can show bevelled borders, and therefore can accept, eg, #raised or #inset as valid borderColors. Must be overridden by subclasses that do not support bevelled borders." ^ true! ! !BorderedMorph methodsFor: 'accessing' stamp: 'di 1/3/1999 12:24'! hasTranslucentColor "Answer true if this any of this morph is translucent but not transparent." (color isColor and: [color isTranslucentColor]) ifTrue: [^ true]. (borderColor isColor and: [borderColor isTranslucentColor]) ifTrue: [^ true]. ^ false ! ! !BorderedMorph methodsFor: 'accessing' stamp: 'sw 11/29/1999 17:36'! useRoundedCorners self cornerStyle: #rounded! ! !BorderedMorph methodsFor: 'accessing' stamp: 'sw 11/29/1999 17:37'! useSquareCorners self cornerStyle: #square! ! !BorderedMorph methodsFor: 'geometry' stamp: 'sw 5/18/2001 22:52'! acquireBorderWidth: aBorderWidth "Gracefully acquire the new border width, keeping the interior area intact and not seeming to shift" | delta | (delta := aBorderWidth- self borderWidth) == 0 ifTrue: [^ self]. self bounds: ((self bounds origin - (delta @ delta)) corner: (self bounds corner + (delta @ delta))). self borderWidth: aBorderWidth. self layoutChanged! ! !BorderedMorph methodsFor: 'geometry' stamp: 'nk 4/5/2001 14:24'! closestPointTo: aPoint "account for round corners. Still has a couple of glitches at upper left and right corners" | pt | pt := self bounds pointNearestTo: aPoint. self wantsRoundedCorners ifFalse: [ ^pt ]. self bounds corners with: (self bounds insetBy: 6) corners do: [ :out :in | (pt - out) abs < (6@6) ifTrue: [ ^(in + (Point r: 5.0 degrees: (pt - in) degrees)) asIntegerPoint ]. ]. ^pt.! ! !BorderedMorph methodsFor: 'geometry' stamp: 'nk 4/5/2001 14:23'! intersectionWithLineSegmentFromCenterTo: aPoint "account for round corners. Still has a couple of glitches at upper left and right corners" | pt | pt := super intersectionWithLineSegmentFromCenterTo: aPoint. self wantsRoundedCorners ifFalse: [ ^pt ]. self bounds corners with: (self bounds insetBy: 6) corners do: [ :out :in | (pt - out) abs < (6@6) ifTrue: [ ^(in + (Point r: 5.0 degrees: (pt - in) degrees)) asIntegerPoint ]. ]. ^pt.! ! !BorderedMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 15:53'! borderInitialize "initialize the receiver state related to border" borderColor:= self defaultBorderColor. borderWidth := self defaultBorderWidth! ! !BorderedMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:33'! defaultBorderColor "answer the default border color/fill style for the receiver" ^ Color black! ! !BorderedMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:36'! defaultBorderWidth "answer the default border width for the receiver" ^ 2! ! !BorderedMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 20:07'! initialize "initialize the state of the receiver" super initialize. "" self borderInitialize! ! !BorderedMorph methodsFor: 'lookenhancements' stamp: 'kfr 11/5/2006 21:36'! addCornerGrips self addMorphBack: (TopLeftGripMorph new target: self; position: self position). self addMorphBack: (TopRightGripMorph new target: self; position: self position). self addMorphBack: (BottomLeftGripMorph new target: self;position: self position). self addMorphBack: (BottomRightGripMorph new target: self;position: self position)! ! !BorderedMorph methodsFor: 'lookenhancements' stamp: 'kfr 11/5/2006 21:36'! addPaneHSplitterBetween: topMorph and: bottomMorphs | targetY minX maxX splitter | targetY := topMorph layoutFrame bottomFraction. minX := (bottomMorphs detectMin: [:each | each layoutFrame leftFraction]) layoutFrame leftFraction. maxX := (bottomMorphs detectMax: [:each | each layoutFrame rightFraction]) layoutFrame rightFraction. splitter := ProportionalSplitterMorph new beSplitsTopAndBottom; yourself. splitter layoutFrame: (LayoutFrame fractions: (minX @ targetY corner: maxX @ targetY) offsets: (((topMorph layoutFrame leftOffset ifNil: [0]) @ 0 corner: (topMorph layoutFrame rightOffset ifNil: [0]) @ 4) translateBy: 0 @ (topMorph layoutFrame bottomOffset ifNil: [0]))). self addMorphBack: (splitter position: self position).! ! !BorderedMorph methodsFor: 'lookenhancements' stamp: 'kfr 11/5/2006 21:34'! addPaneSplitters | splitter remaining target targetX sameX minY maxY targetY sameY minX maxX | self removePaneSplitters. self removeCornerGrips. remaining := submorphs reject: [:each | each layoutFrame rightFraction = 1]. [remaining notEmpty] whileTrue: [target := remaining first. targetX := target layoutFrame rightFraction. sameX := submorphs select: [:each | each layoutFrame rightFraction = targetX]. minY := (sameX detectMin: [:each | each layoutFrame topFraction]) layoutFrame topFraction. maxY := (sameX detectMax: [:each | each layoutFrame bottomFraction]) layoutFrame bottomFraction. splitter := ProportionalSplitterMorph new. splitter layoutFrame: (LayoutFrame fractions: (targetX @ minY corner: targetX @ maxY) offsets: ((0 @ (target layoutFrame topOffset ifNil: [0]) corner: 4 @ (target layoutFrame bottomOffset ifNil: [0])) translateBy: (target layoutFrame rightOffset ifNil: [0]) @ 0)). self addMorphBack: (splitter position: self position). remaining := remaining copyWithoutAll: sameX]. remaining := submorphs copy reject: [:each | each layoutFrame bottomFraction = 1]. [remaining notEmpty] whileTrue: [target := remaining first. targetY := target layoutFrame bottomFraction. sameY := submorphs select: [:each | each layoutFrame bottomFraction = targetY]. minX := (sameY detectMin: [:each | each layoutFrame leftFraction]) layoutFrame leftFraction. maxX := (sameY detectMax: [:each | each layoutFrame rightFraction]) layoutFrame rightFraction. splitter := ProportionalSplitterMorph new beSplitsTopAndBottom; yourself. splitter layoutFrame: (LayoutFrame fractions: (minX @ targetY corner: maxX @ targetY) offsets: (((target layoutFrame leftOffset ifNil: [0]) @ 0 corner: (target layoutFrame rightOffset ifNil: [0]) @ 4) translateBy: 0 @ (target layoutFrame bottomOffset ifNil: [0]))). self addMorphBack: (splitter position: self position). remaining := remaining copyWithoutAll: sameY]. self linkSubmorphsToSplitters. self splitters do: [:each | each comeToFront]. ! ! !BorderedMorph methodsFor: 'lookenhancements' stamp: 'kfr 11/5/2006 21:37'! addPaneVSplitterBetween: leftMorph and: rightMorphs | targetX minY maxY splitter | targetX := leftMorph layoutFrame rightFraction. minY := (rightMorphs detectMin: [:each | each layoutFrame topFraction]) layoutFrame topFraction. maxY := (rightMorphs detectMax: [:each | each layoutFrame bottomFraction]) layoutFrame bottomFraction. splitter := ProportionalSplitterMorph new. splitter layoutFrame: (LayoutFrame fractions: (targetX @ minY corner: targetX @ maxY) offsets: ((0 @ (leftMorph layoutFrame topOffset ifNil: [0]) corner: (4@ (leftMorph layoutFrame bottomOffset ifNil: [0]))) translateBy: (leftMorph layoutFrame rightOffset ifNil: [0]) @ 0)). self addMorphBack: (splitter position: self position).! ! !BorderedMorph methodsFor: 'lookenhancements' stamp: 'jrp 7/23/2005 22:16'! linkSubmorphsToSplitters self splitters do: [:each | each splitsTopAndBottom ifTrue: [self submorphsDo: [:eachMorph | (eachMorph ~= each and: [eachMorph layoutFrame bottomFraction = each layoutFrame topFraction]) ifTrue: [each addLeftOrTop: eachMorph]. (eachMorph ~= each and: [eachMorph layoutFrame topFraction = each layoutFrame bottomFraction]) ifTrue: [each addRightOrBottom: eachMorph]]] ifFalse: [self submorphsDo: [:eachMorph | (eachMorph ~= each and: [eachMorph layoutFrame rightFraction = each layoutFrame leftFraction]) ifTrue: [each addLeftOrTop: eachMorph]. (eachMorph ~= each and: [eachMorph layoutFrame leftFraction = each layoutFrame rightFraction]) ifTrue: [each addRightOrBottom: eachMorph]]]]! ! !BorderedMorph methodsFor: 'lookenhancements' stamp: 'jrp 7/23/2005 00:03'! removeCornerGrips | corners | corners := self submorphsSatisfying: [:each | each isKindOf: CornerGripMorph]. corners do: [:each | each delete]! ! !BorderedMorph methodsFor: 'lookenhancements' stamp: 'jrp 7/23/2005 22:28'! removePaneSplitters self splitters do: [:each | each delete]! ! !BorderedMorph methodsFor: 'lookenhancements' stamp: 'jrp 7/23/2005 22:16'! splitters ^ self submorphsSatisfying: [:each | each isKindOf: ProportionalSplitterMorph]! ! !BorderedMorph methodsFor: 'menu' stamp: 'dgd 9/18/2004 19:16'! addBorderStyleMenuItems: aMenu hand: aHandMorph "Add border-style menu items" | subMenu | subMenu := MenuMorph new defaultTarget: self. "subMenu addTitle: 'border' translated." subMenu addStayUpItemSpecial. subMenu addList: {{'border color...' translated. #changeBorderColor:}. {'border width...' translated. #changeBorderWidth:}}. subMenu addLine. BorderStyle borderStyleChoices do: [:sym | (self borderStyleForSymbol: sym) ifNotNil: [subMenu add: sym translated target: self selector: #setBorderStyle: argument: sym]]. aMenu add: 'border style' translated subMenu: subMenu ! ! !BorderedMorph methodsFor: 'menu' stamp: 'ar 10/5/2000 18:50'! changeBorderColor: evt | aHand | aHand := evt ifNotNil: [evt hand] ifNil: [self primaryHand]. self changeColorTarget: self selector: #borderColor: originalColor: self borderColor hand: aHand! ! !BorderedMorph methodsFor: 'menu' stamp: 'marcus.denker 11/10/2008 10:04'! changeBorderWidth: evt | handle origin aHand newWidth oldWidth | aHand := evt ifNil: [self primaryHand] ifNotNil: [evt hand]. origin := aHand position. oldWidth := borderWidth. handle := HandleMorph new forEachPointDo: [:newPoint | handle removeAllMorphs. handle addMorph: (LineMorph from: origin to: newPoint color: Color black width: 1). newWidth := (newPoint - origin) r asInteger // 5. self borderWidth: newWidth] lastPointDo: [:newPoint | handle deleteBalloon. self halo ifNotNil: [:halo | halo addHandles]. self rememberCommand: (Command new cmdWording: 'border change' translated; undoTarget: self selector: #borderWidth: argument: oldWidth; redoTarget: self selector: #borderWidth: argument: newWidth)]. aHand attachMorph: handle. handle setProperty: #helpAtCenter toValue: true. handle showBalloon: 'Move cursor farther from this point to increase border width. Click when done.' translated hand: evt hand. handle startStepping! ! !BorderedMorph methodsFor: 'private' stamp: 'di 6/20/97 11:21'! setBorderWidth: w borderColor: bc self borderWidth: w. self borderColor: bc.! ! !BorderedMorph methodsFor: 'private' stamp: 'di 6/20/97 11:22'! setColor: c borderWidth: w borderColor: bc self color: c. self borderWidth: w. self borderColor: bc.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! BorderedMorph class instanceVariableNames: ''! !BorderedMorph class methodsFor: 'examples' stamp: 'StephaneDucasse 9/6/2009 15:53'! gradientExample "self gradientExample" | morph fs | morph := BorderedMorph new. fs := GradientFillStyle ramp: {0.0 -> Color red. 1.0 -> Color green}. fs origin: morph bounds center. fs direction: (morph bounds width // 2) @ 0. fs radial: true. morph fillStyle: fs. World primaryHand attachMorph: morph.! ! BorderedMorph subclass: #BorderedSubpaneDividerMorph instanceVariableNames: 'resizingEdge' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Windows'! !BorderedSubpaneDividerMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 4/2/2007 13:56'! adoptPaneColor: paneColor "Match the color." super adoptPaneColor: paneColor. paneColor ifNil: [^self]. self color: paneColor! ! !BorderedSubpaneDividerMorph methodsFor: 'as yet unclassified' stamp: 'ar 8/15/2001 23:24'! firstEnter: evt "The first time this divider is activated, find its window and redirect further interaction there." | window | window := self firstOwnerSuchThat: [:m | m respondsTo: #secondaryPaneTransition:divider:]. window ifNil: [ self suspendEventHandler. ^ self ]. "not working out" window secondaryPaneTransition: evt divider: self. self on: #mouseEnter send: #secondaryPaneTransition:divider: to: window. ! ! !BorderedSubpaneDividerMorph methodsFor: 'as yet unclassified' stamp: 'ar 8/15/2001 23:24'! horizontal self hResizing: #spaceFill.! ! !BorderedSubpaneDividerMorph methodsFor: 'as yet unclassified' stamp: 'ar 8/15/2001 23:24'! resizingEdge ^resizingEdge ! ! !BorderedSubpaneDividerMorph methodsFor: 'as yet unclassified' stamp: 'ar 8/15/2001 23:24'! resizingEdge: edgeSymbol (#(top bottom) includes: edgeSymbol) ifFalse: [ self error: 'resizingEdge must be #top or #bottom' ]. resizingEdge := edgeSymbol. self on: #mouseEnter send: #firstEnter: to: self. ! ! !BorderedSubpaneDividerMorph methodsFor: 'as yet unclassified' stamp: 'ar 8/15/2001 23:24'! vertical self vResizing: #spaceFill.! ! !BorderedSubpaneDividerMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:09'! defaultBorderWidth "answer the default border width for the receiver" ^ 0! ! !BorderedSubpaneDividerMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:09'! defaultColor "answer the default color/fill style for the receiver" ^ Color black! ! !BorderedSubpaneDividerMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:09'! initialize "initialize the state of the receiver" super initialize. "" self extent: 1 @ 1! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! BorderedSubpaneDividerMorph class instanceVariableNames: ''! !BorderedSubpaneDividerMorph class methodsFor: 'as yet unclassified' stamp: 'ar 8/15/2001 23:24'! forBottomEdge ^self new horizontal resizingEdge: #bottom! ! !BorderedSubpaneDividerMorph class methodsFor: 'as yet unclassified' stamp: 'ar 8/15/2001 23:25'! forTopEdge ^self new horizontal resizingEdge: #top! ! !BorderedSubpaneDividerMorph class methodsFor: 'as yet unclassified' stamp: 'ar 8/15/2001 23:25'! horizontal ^self new horizontal! ! !BorderedSubpaneDividerMorph class methodsFor: 'as yet unclassified' stamp: 'ar 8/15/2001 23:25'! vertical ^self new vertical! ! CornerGripMorph subclass: #BottomLeftGripMorph instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Windows'! !BottomLeftGripMorph commentStamp: 'jmv 1/29/2006 17:17' prior: 0! I am the handle in the left bottom of windows used for resizing them.! !BottomLeftGripMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 7/30/2009 13:47'! containsPoint: aPoint "Answer true only if on edges." |w| ^(super containsPoint: aPoint) and: [ w := SystemWindow borderWidth. ((self bounds translateBy: w@w negated) containsPoint: aPoint) not]! ! !BottomLeftGripMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 5/13/2008 10:21'! drawOn: aCanvas "Draw the grip on the given canvas." | dotBounds alphaCanvas windowBorderWidth dotBounds2 | self shouldDraw ifFalse: [^self]. windowBorderWidth := SystemWindow borderWidth. alphaCanvas := aCanvas asAlphaBlendingCanvas: 0.7. "alphaCanvas frameRectangle: bounds color: Color blue." dotBounds := self bounds. dotBounds2 := dotBounds right: (dotBounds left + windowBorderWidth). dotBounds2 := dotBounds2 top: (dotBounds2 bottom - windowBorderWidth). alphaCanvas fillRectangle: dotBounds2 color: self handleColor. dotBounds2 := dotBounds left: (dotBounds left + windowBorderWidth). dotBounds2 := dotBounds2 top: (dotBounds2 bottom - windowBorderWidth). alphaCanvas fillRectangle: dotBounds2 color: self handleColor. dotBounds2 := dotBounds2 left: (dotBounds2 left + 7). dotBounds2 := dotBounds2 right: (dotBounds2 right - 7). alphaCanvas fillRectangle: dotBounds2 color: self dotColor. dotBounds2 := dotBounds right: (dotBounds left + windowBorderWidth). dotBounds2 := dotBounds2 bottom: (dotBounds2 bottom - windowBorderWidth). alphaCanvas fillRectangle: dotBounds2 color: self handleColor. dotBounds2 := dotBounds2 top: (dotBounds2 top + 7). dotBounds2 := dotBounds2 bottom: (dotBounds2 bottom - 7). alphaCanvas fillRectangle: dotBounds2 color: self dotColor! ! !BottomLeftGripMorph methodsFor: 'accessing' stamp: 'jmv 2/2/2006 14:26'! gripLayoutFrame ^ LayoutFrame fractions: (0 @ 1 corner: 0 @ 1) offsets: (0 @ (0 - self defaultHeight) corner: self defaultWidth @ 0)! ! !BottomLeftGripMorph methodsFor: 'accessing' stamp: 'md 2/24/2006 22:43'! ptName ^#bottomLeft! ! !BottomLeftGripMorph methodsFor: 'accessing' stamp: 'jmv 1/29/2006 17:52'! resizeCursor ^ Cursor resizeForEdge: #bottomLeft! ! !BottomLeftGripMorph methodsFor: 'target resize' stamp: 'jmv 1/29/2006 18:06'! apply: delta | oldBounds | oldBounds := target bounds. target bounds: (oldBounds origin + (delta x @ 0) corner: oldBounds corner + (0 @ delta y))! ! CornerGripMorph subclass: #BottomRightGripMorph instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Windows'! !BottomRightGripMorph commentStamp: 'jmv 1/29/2006 17:18' prior: 0! I am the handle in the right bottom of windows used for resizing them.! !BottomRightGripMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 3/12/2007 10:52'! containsPoint: aPoint "Answer true only if on edges." |w| ^(super containsPoint: aPoint) and: [ w := SystemWindow borderWidth. ((self bounds translateBy: (w@w) negated) containsPoint: aPoint) not]! ! !BottomRightGripMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 5/13/2008 10:21'! drawOn: aCanvas "Draw the grip on the given canvas." | dotBounds alphaCanvas windowBorderWidth dotBounds2 | self shouldDraw ifFalse: [^self]. windowBorderWidth := SystemWindow borderWidth. alphaCanvas := aCanvas asAlphaBlendingCanvas: 0.7. "alphaCanvas frameRectangle: bounds color: Color blue." dotBounds := self bounds. dotBounds2 := dotBounds left: (dotBounds right - windowBorderWidth). dotBounds2 := dotBounds2 top: (dotBounds2 bottom - windowBorderWidth). alphaCanvas fillRectangle: dotBounds2 color: self handleColor. dotBounds2 := dotBounds right: (dotBounds right - windowBorderWidth). dotBounds2 := dotBounds2 top: (dotBounds2 bottom - windowBorderWidth). alphaCanvas fillRectangle: dotBounds2 color: self handleColor. dotBounds2 := dotBounds2 left: (dotBounds2 left + 7). dotBounds2 := dotBounds2 right: (dotBounds2 right - 7). alphaCanvas fillRectangle: dotBounds2 color: self dotColor. dotBounds2 := dotBounds left: (dotBounds right - windowBorderWidth). dotBounds2 := dotBounds2 bottom: (dotBounds2 bottom - windowBorderWidth). alphaCanvas fillRectangle: dotBounds2 color: self handleColor. dotBounds2 := dotBounds2 top: (dotBounds2 top + 7). dotBounds2 := dotBounds2 bottom: (dotBounds2 bottom - 7). alphaCanvas fillRectangle: dotBounds2 color: self dotColor! ! !BottomRightGripMorph methodsFor: 'accessing' stamp: 'jmv 2/2/2006 14:27'! gripLayoutFrame ^ LayoutFrame fractions: (1 @ 1 corner: 1 @ 1) offsets: (0 - self defaultWidth @ (0 - self defaultHeight) corner: 0 @ 0)! ! !BottomRightGripMorph methodsFor: 'accessing' stamp: 'md 2/24/2006 22:43'! ptName ^#bottomRight! ! !BottomRightGripMorph methodsFor: 'accessing' stamp: 'jmv 1/29/2006 17:51'! resizeCursor ^ Cursor resizeForEdge: #bottomRight! ! !BottomRightGripMorph methodsFor: 'target resize' stamp: 'jmv 1/29/2006 17:59'! apply: delta | oldBounds | oldBounds := target bounds. target bounds: (oldBounds origin corner: oldBounds corner + delta)! ! GradientFillStyle subclass: #BoundedGradientFillStyle instanceVariableNames: 'extent' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Widgets-FillStyles'! !BoundedGradientFillStyle commentStamp: 'gvc 3/13/2009 12:19' prior: 0! Gradient fillstyle that draws with optional extent.! !BoundedGradientFillStyle methodsFor: 'accessing' stamp: 'gvc 3/13/2009 12:22'! extent "Answer the value of extent" ^ extent! ! !BoundedGradientFillStyle methodsFor: 'accessing' stamp: 'gvc 3/13/2009 12:22'! extent: anObject "Set the value of extent" extent := anObject! ! !BoundedGradientFillStyle methodsFor: 'as yet unclassified' stamp: 'gvc 3/13/2009 12:39'! = aGradientFillStyle "Answer whether equal." ^super = aGradientFillStyle and: [self extent = aGradientFillStyle extent]! ! !BoundedGradientFillStyle methodsFor: 'as yet unclassified' stamp: 'gvc 3/13/2009 12:22'! fillRectangle: aRectangle on: aCanvas "Fill the given rectangle on the given canvas with the receiver." self extent ifNil: [^super fillRectangle: aRectangle on: aCanvas]. aCanvas fillRectangle: ((self origin extent: self extent) intersect: aRectangle) basicFillStyle: self! ! !BoundedGradientFillStyle methodsFor: 'as yet unclassified' stamp: 'gvc 3/13/2009 12:39'! hash "Hash is implemented because #= is implemented." ^super hash bitXor: self extent hash! ! ParseNode subclass: #BraceNode instanceVariableNames: 'elements sourceLocations emitNode' classVariableNames: '' poolDictionaries: '' category: 'Compiler-ParseNodes'! !BraceNode commentStamp: '' prior: 0! Used for compiling and decompiling brace constructs. These now compile into either a fast short form for 4 elements or less: Array braceWith: a with: b ... or a long form of indefinfite length: (Array braceStream: N) nextPut: a; nextPut: b; ...; braceArray. The erstwhile brace assignment form is no longer supported.! !BraceNode methodsFor: 'code generation' stamp: 'di 11/19/1999 08:58'! emitForValue: stack on: aStream ^ emitNode emitForValue: stack on: aStream! ! !BraceNode methodsFor: 'code generation' stamp: 'di 1/4/2000 11:24'! selectorForShortForm: nElements nElements > 4 ifTrue: [^ nil]. ^ #(braceWithNone braceWith: braceWith:with: braceWith:with:with: braceWith:with:with:with:) at: nElements + 1! ! !BraceNode methodsFor: 'code generation' stamp: 'di 11/19/1999 11:13'! sizeForValue: encoder emitNode := elements size <= 4 ifTrue: ["Short form: Array braceWith: a with: b ... " MessageNode new receiver: (encoder encodeVariable: #Array) selector: (self selectorForShortForm: elements size) arguments: elements precedence: 3 from: encoder] ifFalse: ["Long form: (Array braceStream: N) nextPut: a; nextPut: b; ...; braceArray" CascadeNode new receiver: (MessageNode new receiver: (encoder encodeVariable: #Array) selector: #braceStream: arguments: (Array with: (encoder encodeLiteral: elements size)) precedence: 3 from: encoder) messages: ((elements collect: [:elt | MessageNode new receiver: nil selector: #nextPut: arguments: (Array with: elt) precedence: 3 from: encoder]) copyWith: (MessageNode new receiver: nil selector: #braceArray arguments: (Array new) precedence: 1 from: encoder))]. ^ emitNode sizeForValue: encoder! ! !BraceNode methodsFor: 'code generation (closures)' stamp: 'eem 7/20/2009 09:33'! analyseTempsWithin: scopeBlock "" rootNode: rootNode "" assignmentPools: assignmentPools "" elements do: [:node| node analyseTempsWithin: scopeBlock rootNode: rootNode assignmentPools: assignmentPools]! ! !BraceNode methodsFor: 'code generation (closures)' stamp: 'eem 5/21/2008 10:40'! elements ^elements! ! !BraceNode methodsFor: 'code generation (closures)' stamp: 'eem 5/30/2008 17:22'! maxElementsForConsArray "Hack; we have no way of knowing how much stack space is available during sizing" ^8! ! !BraceNode methodsFor: 'code generation (new scheme)' stamp: 'eem 5/30/2008 17:40'! emitCodeForValue: stack encoder: encoder (encoder supportsClosureOpcodes "Hack; we have no way of knowing how much stack space is available" and: [elements size <= self maxElementsForConsArray]) ifTrue: [elements do: [:node| node emitCodeForValue: stack encoder: encoder]. encoder genPushConsArray: elements size. stack pop: elements size; push: 1. ^self]. ^emitNode emitCodeForValue: stack encoder: encoder! ! !BraceNode methodsFor: 'code generation (new scheme)' stamp: 'eem 5/30/2008 17:22'! sizeCodeForValue: encoder (encoder supportsClosureOpcodes "Hack; we have no way of knowing how much stack space is available" and: [elements size <= self maxElementsForConsArray]) ifTrue: [^(elements inject: 0 into: [:sum :node| sum + (node sizeCodeForValue: encoder)]) + (encoder sizePushConsArray: elements size)]. emitNode := elements size <= 4 ifTrue: ["Short form: Array braceWith: a with: b ... " MessageNode new receiver: (encoder encodeVariable: #Array) selector: (self selectorForShortForm: elements size) arguments: elements precedence: 3 from: encoder] ifFalse: ["Long form: (Array braceStream: N) nextPut: a; nextPut: b; ...; braceArray" CascadeNode new receiver: (MessageNode new receiver: (encoder encodeVariable: #Array) selector: #braceStream: arguments: (Array with: (encoder encodeLiteral: elements size)) precedence: 3 from: encoder) messages: ((elements collect: [:elt | MessageNode new receiver: nil selector: #nextPut: arguments: (Array with: elt) precedence: 3 from: encoder]) copyWith: (MessageNode new receiver: nil selector: #braceArray arguments: (Array new) precedence: 1 from: encoder))]. ^emitNode sizeCodeForValue: encoder! ! !BraceNode methodsFor: 'enumerating'! casesForwardDo: aBlock "For each case in forward order, evaluate aBlock with three arguments: the key block, the value block, and whether it is the last case." | numCases case | 1 to: (numCases := elements size) do: [:i | case := elements at: i. aBlock value: case receiver value: case arguments first value: i=numCases]! ! !BraceNode methodsFor: 'enumerating'! casesReverseDo: aBlock "For each case in reverse order, evaluate aBlock with three arguments: the key block, the value block, and whether it is the last case." | numCases case | (numCases := elements size) to: 1 by: -1 do: [:i | case := elements at: i. aBlock value: case receiver value: case arguments first value: i=numCases]! ! !BraceNode methodsFor: 'initialize-release'! elements: collection "Decompile." elements := collection! ! !BraceNode methodsFor: 'initialize-release'! elements: collection sourceLocations: locations "Compile." elements := collection. sourceLocations := locations! ! !BraceNode methodsFor: 'initialize-release' stamp: 'di 11/19/1999 11:06'! matchBraceStreamReceiver: receiver messages: messages ((receiver isMessage: #braceStream: receiver: nil arguments: [:arg | arg isConstantNumber]) and: [messages last isMessage: #braceArray receiver: nil arguments: nil]) ifFalse: [^ nil "no match"]. "Appears to be a long form brace construct" self elements: (messages allButLast collect: [:msg | (msg isMessage: #nextPut: receiver: nil arguments: nil) ifFalse: [^ nil "not a brace element"]. msg arguments first])! ! !BraceNode methodsFor: 'initialize-release' stamp: 'di 11/19/1999 11:19'! matchBraceWithReceiver: receiver selector: selector arguments: arguments selector = (self selectorForShortForm: arguments size) ifFalse: [^ nil "no match"]. "Appears to be a short form brace construct" self elements: arguments! ! !BraceNode methodsFor: 'printing' stamp: 'di 11/19/1999 09:17'! printOn: aStream indent: level aStream nextPut: ${. 1 to: elements size do: [:i | (elements at: i) printOn: aStream indent: level. i < elements size ifTrue: [aStream nextPutAll: '. ']]. aStream nextPut: $}! ! !BraceNode methodsFor: 'printing' stamp: 'eem 6/2/2008 11:47'! printWithClosureAnalysisOn: aStream indent: level aStream nextPut: ${. 1 to: elements size do: [:i | (elements at: i) printWithClosureAnalysisOn: aStream indent: level. i < elements size ifTrue: [aStream nextPutAll: '. ']]. aStream nextPut: $}! ! !BraceNode methodsFor: 'testing' stamp: 'eem 9/25/2008 14:48'! blockAssociationCheck: encoder "If all elements are MessageNodes of the form [block]->[block], and there is at least one element, answer true. Otherwise, notify encoder of an error." elements size = 0 ifTrue: [^encoder notify: 'At least one case required']. elements with: sourceLocations do: [:x :loc | (x isMessage: #-> receiver: [:rcvr | rcvr isBlockNode and: [rcvr numberOfArguments = 0]] arguments: [:arg | arg isBlockNode and: [arg numberOfArguments = 0]]) ifFalse: [^encoder notify: 'Association between 0-argument blocks required' at: loc]]. ^true! ! !BraceNode methodsFor: 'testing'! numElements ^ elements size! ! !BraceNode methodsFor: 'visiting' stamp: 'eem 9/10/2008 15:14'! accept: aVisitor aVisitor visitBraceNode: self! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! BraceNode class instanceVariableNames: ''! !BraceNode class methodsFor: 'examples' stamp: 'di 11/19/1999 09:05'! example "Test the {a. b. c} syntax." | x | x := {1. {2. 3}. 4}. ^ {x first. x second first. x second last. x last. 5} as: Set "BraceNode example Set (0 1 2 3 4 5 )" ! ! Morph subclass: #BracketMorph instanceVariableNames: 'orientation' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Widgets'! !BracketMorph commentStamp: 'gvc 5/18/2007 13:48' prior: 0! Morph displaying opposing arrows.! !BracketMorph methodsFor: 'accessing' stamp: 'gvc 9/21/2006 15:48'! horizontal "Answer whether horizontal or vertical." ^self orientation == #horizontal! ! !BracketMorph methodsFor: 'accessing' stamp: 'gvc 9/19/2006 15:54'! horizontal: aBoolean "Set whether horizontal or vertical." ^self orientation: (aBoolean ifTrue: [#horizontal] ifFalse: [#vertical])! ! !BracketMorph methodsFor: 'accessing' stamp: 'gvc 9/19/2006 15:51'! orientation "Answer the value of orientation" ^ orientation! ! !BracketMorph methodsFor: 'accessing' stamp: 'gvc 9/19/2006 15:52'! orientation: anObject "Set the value of orientation" orientation := anObject. self changed! ! !BracketMorph methodsFor: 'drawing' stamp: 'gvc 9/21/2006 16:16'! drawOn: aCanvas "Draw triangles at the edges." |r| r := self horizontal ifTrue: [self bounds insetBy: (2@1 corner: 2@1)] ifFalse: [self bounds insetBy: (1@2 corner: 1@2)]. aCanvas drawPolygon: (self leftOrTopVertices: self bounds) fillStyle: self borderColor; drawPolygon: (self leftOrTopVertices: r) fillStyle: self fillStyle; drawPolygon: (self rightOrBottomVertices: self bounds) fillStyle: self borderColor; drawPolygon: (self rightOrBottomVertices: r) fillStyle: self fillStyle! ! !BracketMorph methodsFor: 'geometry' stamp: 'gvc 9/21/2006 15:45'! leftOrTopVertices: r "Answer the vertices for a left or top bracket in the given rectangle." ^self orientation == #vertical ifTrue: [{r topLeft - (0@1). r left + (r height // 2 + (r height \\ 2))@(r center y - (r height + 1 \\ 2)). r left + (r height // 2 + (r height \\ 2))@(r center y). r bottomLeft}] ifFalse: [{r topLeft. (r center x - (r width + 1 \\ 2))@(r top + (r width // 2 + (r width \\ 2))). r center x@(r top + (r width // 2 + (r width \\ 2))). r topRight}]! ! !BracketMorph methodsFor: 'geometry' stamp: 'gvc 9/21/2006 16:18'! rightOrBottomVertices: r "Answer the vertices for a right or bottom bracket in the given rectangle." ^self orientation == #vertical ifTrue: [{r topRight - (0@1). r right - (r height // 2 + (r height \\ 2))@(r center y - (r height + 1 \\ 2)). r right - (r height // 2 + (r height \\ 2))@(r center y). r bottomRight}] ifFalse: [{(r center x)@(r bottom - 1 - (r width // 2 + (r width \\ 2))). r center x @(r bottom - 1 - (r width // 2 + (r width \\ 2))). r bottomRight. r bottomLeft - (1@0)}]! ! !BracketMorph methodsFor: 'initialization' stamp: 'gvc 9/19/2006 15:52'! initialize "Initialize the receiver." super initialize. self orientation: #horizontal! ! PluggableSliderMorph subclass: #BracketSliderMorph instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Widgets'! !BracketSliderMorph commentStamp: 'gvc 5/18/2007 13:39' prior: 0! Abstract superclass for morphs that are used to select a component (R, G, B or A) of a colour.! !BracketSliderMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/3/2009 13:40'! defaultFillStyle "Answer the defauolt fill style." ^Color gray! ! !BracketSliderMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/3/2009 13:40'! extent: aPoint "Update the gradient directions." super extent: aPoint. self updateFillStyle! ! !BracketSliderMorph methodsFor: 'as yet unclassified' stamp: 'gvc 8/7/2007 16:05'! fillStyleToUse "Answer the fillStyle that should be used for the receiver." ^self fillStyle! ! !BracketSliderMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/19/2006 14:06'! gradient "Answer the gradient." self subclassResponsibility! ! !BracketSliderMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/3/2009 13:39'! initialize "Initialize the receiver." super initialize. self fillStyle: self defaultFillStyle; borderStyle: (BorderStyle inset baseColor: self paneColor; width: 1); sliderColor: Color black; clipSubmorphs: true! ! !BracketSliderMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/19/2006 15:53'! initializeSlider "Make the slider raised." slider :=( BracketMorph newBounds: self totalSliderArea) horizontal: self bounds isWide; color: self thumbColor; borderStyle: (BorderStyle raised baseColor: Color white; width: 1). sliderShadow := (BracketMorph newBounds: self totalSliderArea) horizontal: self bounds isWide; color: self pagingArea color; borderStyle: (BorderStyle inset baseColor: (Color white alpha: 0.6); width: 1). slider on: #mouseMove send: #scrollAbsolute: to: self. slider on: #mouseDown send: #mouseDownInSlider: to: self. slider on: #mouseUp send: #mouseUpInSlider: to: self. "(the shadow must have the pagingArea as its owner to highlight properly)" self pagingArea addMorph: sliderShadow. sliderShadow hide. self addMorph: slider. self computeSlider. ! ! !BracketSliderMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/3/2009 13:41'! layoutBounds: aRectangle "Set the bounds for laying out children of the receiver. Note: written so that #layoutBounds can be changed without touching this method" super layoutBounds: aRectangle. self updateFillStyle. slider horizontal: self bounds isWide. sliderShadow horizontal: self bounds isWide! ! !BracketSliderMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/21/2006 11:34'! roomToMove "Allow to run off the edges a bit." ^self bounds isWide ifTrue: [self totalSliderArea insetBy: ((self sliderThickness // 2@0) negated corner: (self sliderThickness // 2 + 1)@0)] ifFalse: [self totalSliderArea insetBy: (0@(self sliderThickness // 2) negated corner: 0@(self sliderThickness // 2 - (self sliderThickness \\ 2) + 1))]! ! !BracketSliderMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/8/2009 13:29'! sliderColor: newColor "Set the slider colour." super sliderColor: (self enabled ifTrue: [Color black] ifFalse: [self sliderShadowColor]). slider ifNotNil: [slider borderStyle baseColor: Color white]! ! !BracketSliderMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/19/2006 15:43'! sliderShadowColor "Answer the color for the slider shadow." ^Color black alpha: 0.6! ! !BracketSliderMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/26/2006 12:02'! sliderThickness "Answer the thickness of the slider." ^((self bounds isWide ifTrue: [self height] ifFalse: [self width]) // 2 max: 8) // 2 * 2 + 1! ! !BracketSliderMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/3/2009 13:41'! updateFillStyle "Update the fill style directions." |b fs| fs := self fillStyle. fs isOrientedFill ifTrue: [ b := self innerBounds. fs origin: b topLeft. fs direction: (b isWide ifTrue: [b width@0] ifFalse: [0@b height])]! ! Halt subclass: #BreakPoint instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'System-Tools'! !BreakPoint commentStamp: 'md 11/18/2003 09:32' prior: 0! This exception is raised on executing a breakpoint. "BreakPoint signal" is called from "Object>>break".! Object subclass: #BreakpointManager instanceVariableNames: '' classVariableNames: 'Installed' poolDictionaries: '' category: 'System-Tools'! !BreakpointManager commentStamp: 'md 10/9/2008 20:17' prior: 0! This class manages methods that include breakpoints. It has several class methods to install and uninstall breakpoints. Evaluating "BreakpointManager clear" will remove all installed breakpoints in the system. Known issues: - currently, only break-on-entry type of breakpoints are supported - uninstalling the breakpoint doesn't auto-update other browsers - uninstalling a breakpoint while debugging should restart-simulate the current method Ernest Micklei, 2002 Send comments to emicklei@philemonworks.com! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! BreakpointManager class instanceVariableNames: ''! !BreakpointManager class methodsFor: 'examples' stamp: 'emm 5/30/2002 14:12'! testBreakpoint "In the menu of the methodList, click on -toggle break on entry- and evaluate the following:" "BreakpointManager testBreakpoint" Transcript cr; show: 'Breakpoint test'! ! !BreakpointManager class methodsFor: 'install-uninstall' stamp: 'nice 4/10/2008 22:00'! installInClass: aClass selector: aSymbol "Install a new method containing a breakpoint. The receiver will remember this for unstalling it later" | breakMethod | breakMethod := self compilePrototype: aSymbol in: aClass. breakMethod isNil ifTrue: [^ nil]. self installed at: breakMethod put: aClass >> aSymbol. "old method" aClass basicAddSelector: aSymbol withMethod: breakMethod.! ! !BreakpointManager class methodsFor: 'install-uninstall' stamp: 'md 2/15/2006 21:25'! unInstall: breakMethod | class selector oldMethod | oldMethod := self installed at: breakMethod ifAbsent:[^self]. class := breakMethod methodClass. selector := breakMethod selector. (class>>selector) == breakMethod ifTrue:[ class methodDictionary at: selector put: oldMethod]. self installed removeKey: breakMethod! ! !BreakpointManager class methodsFor: 'intialization-release' stamp: 'marcus.denker 10/9/2008 20:35'! clear "BreakpointManager clear" self installed associations do: [:entry | self unInstall: entry key]. ! ! !BreakpointManager class methodsFor: 'testing' stamp: 'emm 5/30/2002 09:22'! methodHasBreakpoint: aMethod ^self installed includesKey: aMethod! ! !BreakpointManager class methodsFor: 'private' stamp: 'emm 5/30/2002 09:36'! breakpointMethodSourceFor: aSymbol in: aClass "Compose new source containing a break statement (currently it will be the first, later we want to insert it in any place)" | oldSource methodNode breakOnlyMethodNode sendBreakMessageNode | oldSource := aClass sourceCodeAt: aSymbol. methodNode := aClass compilerClass new compile: oldSource in: aClass notifying: nil ifFail: [self error: '[breakpoint] unable to install breakpoint']. breakOnlyMethodNode := aClass compilerClass new compile: 'temporaryMethodSelectorForBreakpoint self break. ^self' in: aClass notifying: nil ifFail: [self error: '[breakpoint] unable to install breakpoint']. sendBreakMessageNode := breakOnlyMethodNode block statements first. methodNode block statements addFirst: sendBreakMessageNode. ^methodNode printString ! ! !BreakpointManager class methodsFor: 'private' stamp: 'md 10/9/2008 20:14'! compilePrototype: aSymbol in: aClass "Compile and return a new method containing a break statement" | source node method | source := self breakpointMethodSourceFor: aSymbol in: aClass. node := aClass compilerClass new compile: source in: aClass notifying: nil ifFail: [self error: '[breakpoint] unable to install breakpoint']. node isNil ifTrue: [^nil]. method := node generate: (aClass>>aSymbol) trailer. ^method! ! !BreakpointManager class methodsFor: 'private' stamp: 'emm 4/24/2002 23:24'! installed Installed isNil ifTrue:[Installed := IdentityDictionary new]. ^Installed! ! CodeHolder subclass: #Browser instanceVariableNames: 'systemOrganizer classOrganizer metaClassOrganizer systemCategoryListIndex classListIndex messageCategoryListIndex messageListIndex editSelection metaClassIndicated' classVariableNames: 'RecentClasses' poolDictionaries: '' category: 'Tools-Browser'! !Browser commentStamp: '' prior: 0! I represent a query path into the class descriptions, the software of the system.! !Browser methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 9/1/2008 16:37'! buildMorphicSwitches | instanceSwitch commentSwitch classSwitch row | instanceSwitch := PluggableButtonMorph on: self getState: #instanceMessagesIndicated action: #indicateInstanceMessages. instanceSwitch label: 'instance'; askBeforeChanging: true; borderWidth: 1; borderColor: Color gray. commentSwitch := PluggableButtonMorph on: self getState: #classCommentIndicated action: #plusButtonHit. commentSwitch label: '?' asText allBold; askBeforeChanging: true; setBalloonText: 'class comment'; borderWidth: 1; borderColor: Color gray. classSwitch := PluggableButtonMorph on: self getState: #classMessagesIndicated action: #indicateClassMessages. classSwitch label: 'class'; askBeforeChanging: true; borderWidth: 1; borderColor: Color gray. row := AlignmentMorph newRow hResizing: #spaceFill; vResizing: #spaceFill; cellInset: 0; borderWidth: 0; layoutInset: 0; addMorphBack: instanceSwitch; addMorphBack: commentSwitch; addMorphBack: classSwitch. row color: Color white. {instanceSwitch. commentSwitch. classSwitch} do: [:m | m color: Color transparent; hResizing: #spaceFill; vResizing: #spaceFill.]. ^ row ! ! !Browser methodsFor: '*services-base' stamp: 'rr 6/28/2005 15:50'! browseReference: ref self okToChange ifTrue: [ self selectCategoryForClass: ref actualClass theNonMetaClass. self selectClass: ref actualClass theNonMetaClass . ref actualClass isMeta ifTrue: [self indicateClassMessages]. self changed: #classSelectionChanged. self selectMessageCategoryNamed: ref category. self selectedMessageName: ref methodSymbol. ]! ! !Browser methodsFor: '*services-base' stamp: 'rr 8/5/2005 10:03'! methodReference | cls sel | cls := self selectedClassOrMetaClass. sel := self selectedMessageName. cls isNil | sel isNil ifTrue: [^nil]. ^ MethodReference class: cls selector: sel! ! !Browser methodsFor: '*services-base' stamp: 'rr 3/10/2006 16:01'! optionalButtonRow ^ServiceGui browserButtonRow: self inlinedIn: super optionalButtonRow! ! !Browser methodsFor: '*services-base' stamp: 'rr 8/3/2005 17:16'! selectReference: ref self browseReference: ref! ! !Browser methodsFor: 'accessing' stamp: 'al 12/6/2005 22:36'! contents "Depending on the current selection, different information is retrieved. Answer a string description of that information. This information is the method of the currently selected class and message." | comment theClass latestCompiledMethod | latestCompiledMethod := currentCompiledMethod. currentCompiledMethod := nil. editSelection == #newTrait ifTrue: [^Trait newTemplateIn: self selectedSystemCategoryName]. editSelection == #none ifTrue: [^ '']. editSelection == #editSystemCategories ifTrue: [^ systemOrganizer printString]. editSelection == #newClass ifTrue: [^ (theClass := self selectedClass) ifNil: [Class template: self selectedSystemCategoryName] ifNotNil: [Class templateForSubclassOf: theClass category: self selectedSystemCategoryName]]. editSelection == #editClass ifTrue: [^self classDefinitionText]. editSelection == #editComment ifTrue: [(theClass := self selectedClass) ifNil: [^ '']. comment := theClass comment. currentCompiledMethod := theClass organization commentRemoteStr. ^ comment size = 0 ifTrue: ['This class has not yet been commented.'] ifFalse: [comment]]. editSelection == #hierarchy ifTrue: [ self selectedClassOrMetaClass isTrait ifTrue: [^''] ifFalse: [^self selectedClassOrMetaClass printHierarchy]]. editSelection == #editMessageCategories ifTrue: [^ self classOrMetaClassOrganizer printString]. editSelection == #newMessage ifTrue: [^ (theClass := self selectedClassOrMetaClass) ifNil: [''] ifNotNil: [theClass sourceCodeTemplate]]. editSelection == #editMessage ifTrue: [self showingByteCodes ifTrue: [^ self selectedBytecodes]. currentCompiledMethod := latestCompiledMethod. ^ self selectedMessage]. self error: 'Browser internal error: unknown edit selection.'! ! !Browser methodsFor: 'accessing' stamp: 'tak 9/25/2008 14:58'! contentsSelection "Return the interval of text in the code pane to select when I set the pane's contents" messageCategoryListIndex > 0 & (messageListIndex = 0) ifTrue: [^ 1 to: 500] "entire empty method template" ifFalse: [^ 1 to: 0] "null selection"! ! !Browser methodsFor: 'accessing' stamp: 'al 4/24/2004 12:01'! contents: input notifying: aController "The retrieved information has changed and its source must now be updated. The information can be a variety of things, depending on the list selections (such as templates for class or message definition, methods) or the user menu commands (such as definition, comment, hierarchy). Answer the result of updating the source." | aString aText theClass | self changed: #annotation. aString := input asString. aText := input asText. editSelection == #newTrait ifTrue: [^self defineTrait: input asString notifying: aController]. editSelection == #editSystemCategories ifTrue: [^ self changeSystemCategories: aString]. editSelection == #editClass | (editSelection == #newClass) ifTrue: [^ self defineClass: aString notifying: aController]. editSelection == #editComment ifTrue: [theClass := self selectedClass. theClass ifNil: [self inform: 'You must select a class before giving it a comment.'. ^ false]. theClass comment: aText stamp: Utilities changeStamp. self changed: #classCommentText. ^ true]. editSelection == #hierarchy ifTrue: [^ true]. editSelection == #editMessageCategories ifTrue: [^ self changeMessageCategories: aString]. editSelection == #editMessage | (editSelection == #newMessage) ifTrue: [^ self okayToAccept ifFalse: [false] ifTrue: [self compileMessage: aText notifying: aController]]. editSelection == #none ifTrue: [self inform: 'This text cannot be accepted in this part of the browser.'. ^ false]. self error: 'unacceptable accept'! ! !Browser methodsFor: 'accessing' stamp: 'alain.plantec 6/11/2008 13:46'! couldBrowseAnyClass "Answer whether the receiver is equipped to browse any class. This is in support of the system-brower feature that allows the browser to be redirected at the selected class name. This implementation is clearly ugly, but the feature it enables is handsome enough. 3/1/96 sw" self dependents detect: [:d | (d isKindOf: PluggableListMorph) and: [d getListSelector == #systemCategoryList]] ifNone: [^ false]. ^ true! ! !Browser methodsFor: 'accessing' stamp: 'sma 5/28/2000 11:28'! doItReceiver "This class's classPool has been jimmied to be the classPool of the class being browsed. A doIt in the code pane will let the user see the value of the class variables." ^ self selectedClass ifNil: [FakeClassPool new]! ! !Browser methodsFor: 'accessing'! editSelection ^editSelection! ! !Browser methodsFor: 'accessing' stamp: 'sd 11/20/2005 21:26'! editSelection: aSelection "Set the editSelection as requested." editSelection := aSelection. self changed: #editSelection.! ! !Browser methodsFor: 'accessing' stamp: 'sd 11/20/2005 21:26'! noteSelectionIndex: anInteger for: aSymbol aSymbol == #systemCategoryList ifTrue: [systemCategoryListIndex := anInteger]. aSymbol == #classList ifTrue: [classListIndex := anInteger]. aSymbol == #messageCategoryList ifTrue: [messageCategoryListIndex := anInteger]. aSymbol == #messageList ifTrue: [messageListIndex := anInteger].! ! !Browser methodsFor: 'accessing' stamp: 'rbb 3/1/2005 10:26'! request: prompt initialAnswer: initialAnswer ^ UIManager default request: prompt initialAnswer: initialAnswer ! ! !Browser methodsFor: 'accessing' stamp: 'sw 9/26/2002 17:56'! suggestCategoryToSpawnedBrowser: aBrowser "aBrowser is a message-category browser being spawned from the receiver. Tell it what it needs to know to get its category info properly set up." (self isMemberOf: Browser) "yecch, but I didn't invent the browser hierarchy" ifTrue: [aBrowser messageCategoryListIndex: (self messageCategoryList indexOf: self categoryOfCurrentMethod ifAbsent: [2])] ifFalse: [aBrowser setOriginalCategoryIndexForCurrentMethod]! ! !Browser methodsFor: 'annotation' stamp: 'sd 11/20/2005 21:26'! annotation "Provide a line of content for an annotation pane, representing information about the method associated with the selected class and selector in the receiver." | aSelector aClass | (aClass := self selectedClassOrMetaClass) == nil ifTrue: [^ '------']. self editSelection == #editComment ifTrue: [^ self annotationForSelector: #Comment ofClass: aClass]. self editSelection == #editClass ifTrue: [^ self annotationForSelector: #Definition ofClass: aClass]. (aSelector := self selectedMessageName) ifNil: [^ '------']. ^ self annotationForSelector: aSelector ofClass: aClass! ! !Browser methodsFor: 'breakpoints' stamp: 'marcus.denker 10/9/2008 20:32'! toggleBreakOnEntry "Install or uninstall a halt-on-entry breakpoint" super toggleBreakOnEntry. self changed: #messageList ! ! !Browser methodsFor: 'class comment pane' stamp: 'nk 2/15/2004 13:20'! buildMorphicCommentPane "Construct the pane that shows the class comment. Respect the Preference for standardCodeFont." | commentPane | commentPane := BrowserCommentTextMorph on: self text: #classCommentText accept: #classComment:notifying: readSelection: nil menu: #codePaneMenu:shifted:. commentPane font: Preferences standardCodeFont. ^ commentPane! ! !Browser methodsFor: 'class comment pane' stamp: 'dew 3/5/2005 23:10'! classComment: aText notifying: aPluggableTextMorph "The user has just entered aText. It may be all red (a side-effect of replacing the default comment), so remove the color if it is." | theClass cleanedText redRange | theClass := self selectedClassOrMetaClass. theClass ifNotNil: [cleanedText := aText asText. redRange := cleanedText rangeOf: TextColor red startingAt: 1. redRange size = cleanedText size ifTrue: [cleanedText removeAttribute: TextColor red from: 1 to: redRange last ]. theClass comment: aText stamp: Utilities changeStamp]. self changed: #classCommentText. ^ true! ! !Browser methodsFor: 'class comment pane' stamp: 'md 2/24/2006 15:23'! noCommentNagString ^ Text string: 'THIS CLASS HAS NO COMMENT!!' translated attribute: TextColor red. ! ! !Browser methodsFor: 'class functions' stamp: 'sd 11/20/2005 21:26'! addAllMethodsToCurrentChangeSet "Add all the methods in the selected class or metaclass to the current change set. You ought to know what you're doing before you invoke this!!" | aClass | (aClass := self selectedClassOrMetaClass) ifNotNil: [aClass selectors do: [:sel | ChangeSet current adoptSelector: sel forClass: aClass]. self changed: #annotation] ! ! !Browser methodsFor: 'class functions'! buildClassBrowser "Create and schedule a new class category browser for the current class selection, if one exists." self buildClassBrowserEditString: nil! ! !Browser methodsFor: 'class functions' stamp: 'sd 11/20/2005 21:26'! classCommentText "return the text to display for the comment of the currently selected class" | theClass | theClass := self selectedClassOrMetaClass. theClass ifNil: [ ^'']. ^ theClass hasComment ifTrue: [ theClass comment ] ifFalse: [ self noCommentNagString ]! ! !Browser methodsFor: 'class functions' stamp: 'eem 5/7/2008 12:04'! classDefinitionText "return the text to display for the definition of the currently selected class" | theClass | ^(theClass := self selectedClassOrMetaClass) ifNil: [''] ifNotNil: [theClass definition]! ! !Browser methodsFor: 'class functions' stamp: 'sw 12/6/2000 16:32'! classListMenu: aMenu "For backward compatibility with old browers stored in image segments" ^ self classListMenu: aMenu shifted: false! ! !Browser methodsFor: 'class functions' stamp: 'dc 7/18/2008 11:40'! classListMenu: aMenu shifted: shifted "Set up the menu to apply to the receiver's class list, honoring the #shifted boolean" ServiceGui browser: self classMenu: aMenu. ServiceGui onlyServices ifTrue: [^aMenu]. shifted ifTrue: [^ self shiftedClassListMenu: aMenu]. aMenu addList: #( - ('browse full (b)' browseMethodFull) ('browse hierarchy (h)' spawnHierarchy) ('browse protocol (p)' browseFullProtocol) - ('fileOut' fileOutClass) - ('show hierarchy' hierarchy) ('show definition' editClass) ('show comment' editComment) - ('inst var refs...' browseInstVarRefs) ('inst var defs...' browseInstVarDefs) - ('class var refs...' browseClassVarRefs) ('class vars' browseClassVariables) ('class refs (N)' browseClassRefs) - ('rename class ...' renameClass) ('copy class' copyClass) ('remove class (x)' removeClass) - ('find method...' findMethod) ('find method wildcard...' findMethodWithWildcard) - ('more...' offerShiftedClassListMenu)). ^ aMenu ! ! !Browser methodsFor: 'class functions' stamp: 'DamienCassou 9/29/2009 09:05'! copyClass | copysName | classListIndex = 0 ifTrue: [^ self]. self okToChange ifFalse: [^ self]. copysName := self request: 'Please type new class name' initialAnswer: self selectedClass name. copysName isEmptyOrNil ifTrue: [^ self]. "Cancel returns ''" self selectedClass duplicateClassWithNewName: copysName. self classListIndex: 0. self changed: #classList! ! !Browser methodsFor: 'class functions' stamp: 'sd 11/20/2005 21:30'! createInstVarAccessors "Create getters and setters for all inst vars defined at the level of the current class selection, except do NOT clobber or override any selectors already understood by the instances of the selected class" | aClass newMessage setter | (aClass := self selectedClassOrMetaClass) ifNotNil: [aClass instVarNames do: [:aName | (aClass canUnderstand: aName asSymbol) ifFalse: [newMessage := aName, ' "Answer the value of ', aName, '" ^ ', aName. aClass compile: newMessage classified: 'accessing' notifying: nil]. (aClass canUnderstand: (setter := aName, ':') asSymbol) ifFalse: [newMessage := setter, ' anObject "Set the value of ', aName, '" ', aName, ' := anObject'. aClass compile: newMessage classified: 'accessing' notifying: nil]]]! ! !Browser methodsFor: 'class functions' stamp: 'md 3/3/2006 11:02'! defineClass: defString notifying: aController "The receiver's textual content is a request to define a new class. The source code is defString. If any errors occur in compilation, notify aController." | oldClass class newClassName defTokens keywdIx envt | oldClass := self selectedClassOrMetaClass. defTokens := defString findTokens: Character separators. ((defTokens first = 'Trait' and: [defTokens second = 'named:']) or: [defTokens second = 'classTrait']) ifTrue: [^self defineTrait: defString notifying: aController]. keywdIx := defTokens findFirst: [:x | x beginsWith: 'category']. envt := Smalltalk. keywdIx := defTokens findFirst: [:x | '*subclass*' match: x]. newClassName := (defTokens at: keywdIx+1) copyWithoutAll: '#()'. ((oldClass isNil or: [oldClass theNonMetaClass name asString ~= newClassName]) and: [envt includesKey: newClassName asSymbol]) ifTrue: ["Attempting to define new class over existing one when not looking at the original one in this browser..." (self confirm: ((newClassName , ' is an existing class in this system. Redefining it might cause serious problems. Is this really what you want to do?') asText makeBoldFrom: 1 to: newClassName size)) ifFalse: [^ false]]. "ar 8/29/1999: Use oldClass superclass for defining oldClass since oldClass superclass knows the definerClass of oldClass." oldClass ifNotNil:[oldClass := oldClass superclass]. class := oldClass subclassDefinerClass evaluate: defString notifying: aController logged: true. (class isKindOf: Behavior) ifTrue: [self changed: #systemCategoryList. self changed: #classList. self clearUserEditFlag. self setClass: class selector: nil. "self clearUserEditFlag; editClass." ^ true] ifFalse: [^ false]! ! !Browser methodsFor: 'class functions' stamp: 'nk 2/15/2004 13:23'! editClass "Retrieve the description of the class definition." classListIndex = 0 ifTrue: [^ self]. self okToChange ifFalse: [^ self]. self messageCategoryListIndex: 0. self editSelection: #editClass. self changed: #contents. self changed: #classCommentText. ! ! !Browser methodsFor: 'class functions' stamp: 'sd 11/20/2005 21:26'! editComment "Retrieve the description of the class comment." classListIndex = 0 ifTrue: [^ self]. self okToChange ifFalse: [^ self]. self messageCategoryListIndex: 0. metaClassIndicated := false. self editSelection: #editComment. self changed: #classSelectionChanged. self changed: #messageCategoryList. self changed: #messageList. self decorateButtons. self contentsChanged ! ! !Browser methodsFor: 'class functions' stamp: 'tk 4/2/98 13:50'! fileOutClass "Print a description of the selected class onto a file whose name is the category name followed by .st." Cursor write showWhile: [classListIndex ~= 0 ifTrue: [self selectedClass fileOut]]! ! !Browser methodsFor: 'class functions' stamp: 'alain.plantec 2/6/2009 16:29'! findMethod "Pop up a list of the current class's methods, and select the one chosen by the user" | aClass selectors reply cat messageCatIndex messageIndex choices | self classListIndex = 0 ifTrue: [^ self]. self okToChange ifFalse: [^ self]. aClass := self selectedClassOrMetaClass. selectors := aClass selectors asSortedArray. selectors isEmpty ifTrue: [self inform: aClass name, ' has no methods.' translated. ^ self]. choices := (Array with: 'Enter Wildcard' translated), selectors. reply := UIManager default chooseFrom: choices lines: #(1). reply = 0 ifTrue: [^self]. reply = 1 ifTrue: [ reply := UIManager default request: 'Enter partial method name:' translated. (reply isNil or: [reply isEmpty]) ifTrue: [^self]. (reply includes: $*) ifFalse: [reply := '*', reply, '*']. selectors := selectors select: [:each | reply match: each]. selectors isEmpty ifTrue: [self inform: aClass name, ' has no matching methods.' translated. ^ self]. reply := selectors size = 1 ifTrue: [selectors first] ifFalse: [ UIManager default chooseFrom: selectors values: selectors]. reply isNil ifTrue: [^self]] ifFalse: [reply := choices at: reply]. cat := aClass whichCategoryIncludesSelector: reply. messageCatIndex := self messageCategoryList indexOf: cat. self messageCategoryListIndex: messageCatIndex. messageIndex := (self messageList indexOf: reply). self messageListIndex: messageIndex! ! !Browser methodsFor: 'class functions' stamp: 'alain.plantec 2/6/2009 16:30'! findMethodWithWildcard "Pop up a list of the current class's methods, and select the one chosen by the user" | aClass selectors reply cat messageCatIndex messageIndex | self classListIndex = 0 ifTrue: [^ self]. self okToChange ifFalse: [^ self]. aClass := self selectedClassOrMetaClass. selectors := aClass selectors asSortedArray. selectors isEmpty ifTrue: [self inform: aClass name, ' has no methods.' translated. ^ self]. reply := UIManager default request: 'Enter partial method name:' translated. (reply isNil or: [reply isEmpty]) ifTrue: [^self]. (reply includes: $*) ifFalse: [reply := '*', reply, '*']. selectors := selectors select: [:each | reply match: each]. selectors isEmpty ifTrue: [self inform: aClass name, ' has no matching methods.'. ^ self]. reply := selectors size = 1 ifTrue: [selectors first] ifFalse: [UIManager default chooseFrom: selectors values: selectors]. reply == nil ifTrue: [^ self]. cat := aClass whichCategoryIncludesSelector: reply. messageCatIndex := self messageCategoryList indexOf: cat. self messageCategoryListIndex: messageCatIndex. messageIndex := (self messageList indexOf: reply). self messageListIndex: messageIndex! ! !Browser methodsFor: 'class functions' stamp: 'nk 2/14/2004 15:09'! hierarchy "Display the inheritance hierarchy of the receiver's selected class." classListIndex = 0 ifTrue: [^ self]. self okToChange ifFalse: [^ self]. self messageCategoryListIndex: 0. self editSelection: #hierarchy. self changed: #editComment. self contentsChanged. ^ self! ! !Browser methodsFor: 'class functions' stamp: 'nk 2/14/2004 15:07'! makeNewSubclass self selectedClassOrMetaClass ifNil: [^ self]. self okToChange ifFalse: [^ self]. self editSelection: #newClass. self contentsChanged! ! !Browser methodsFor: 'class functions' stamp: 'nk 2/14/2004 15:09'! plusButtonHit "Cycle among definition, comment, and hierachy" editSelection == #editComment ifTrue: [self hierarchy. ^ self]. editSelection == #hierarchy ifTrue: [self editSelection: #editClass. classListIndex = 0 ifTrue: [^ self]. self okToChange ifFalse: [^ self]. self changed: #editComment. self contentsChanged. ^ self]. self editComment! ! !Browser methodsFor: 'class functions' stamp: 'sw 3/5/2001 18:04'! removeClass "If the user confirms the wish to delete the class, do so" super removeClass ifTrue: [self classListIndex: 0]! ! !Browser methodsFor: 'class functions' stamp: 'DamienCassou 9/29/2009 09:05'! renameClass | oldName newName obs | classListIndex = 0 ifTrue: [^ self]. self okToChange ifFalse: [^ self]. oldName := self selectedClass name. newName := self request: 'Please type new class name' initialAnswer: oldName. newName isEmptyOrNil ifTrue: [^ self]. "Cancel returns ''" newName := newName asSymbol. newName = oldName ifTrue: [^ self]. (Smalltalk includesKey: newName) ifTrue: [^ self error: newName , ' already exists']. self selectedClass rename: newName. self changed: #classList. self classListIndex: ((systemOrganizer listAtCategoryNamed: self selectedSystemCategoryName) indexOf: newName). obs := self systemNavigation allCallsOn: (Smalltalk associationAt: newName). obs isEmpty ifFalse: [self systemNavigation browseMessageList: obs name: 'Obsolete References to ' , oldName autoSelect: oldName]! ! !Browser methodsFor: 'class functions' stamp: 'md 7/29/2005 15:59'! shiftedClassListMenu: aMenu "Set up the menu to apply to the receiver's class list when the shift key is down" ^ aMenu addList: #( - ('unsent methods' browseUnusedMethods 'browse all methods defined by this class that have no senders') ('unreferenced inst vars' showUnreferencedInstVars 'show a list of all instance variables that are not referenced in methods') ('unreferenced class vars' showUnreferencedClassVars 'show a list of all class variables that are not referenced in methods') ('subclass template' makeNewSubclass 'put a template into the code pane for defining of a subclass of this class') - ('sample instance' makeSampleInstance 'give me a sample instance of this class, if possible') ('inspect instances' inspectInstances 'open an inspector on all the extant instances of this class') ('inspect subinstances' inspectSubInstances 'open an inspector on all the extant instances of this class and of all of its subclasses') - ('add all meths to current chgs' addAllMethodsToCurrentChangeSet 'place all the methods defined by this class into the current change set') ('create inst var accessors' createInstVarAccessors 'compile instance-variable access methods for any instance variables that do not yet have them') - ('more...' offerUnshiftedClassListMenu 'return to the standard class-list menu'))! ! !Browser methodsFor: 'class list'! classList "Answer an array of the class names of the selected category. Answer an empty array if no selection exists." systemCategoryListIndex = 0 ifTrue: [^Array new] ifFalse: [^systemOrganizer listAtCategoryNumber: systemCategoryListIndex]! ! !Browser methodsFor: 'class list'! classListIndex "Answer the index of the current class selection." ^classListIndex! ! !Browser methodsFor: 'class list' stamp: 'sd 11/20/2005 21:26'! classListIndex: anInteger "Set anInteger to be the index of the current class selection." | className | classListIndex := anInteger. self setClassOrganizer. messageCategoryListIndex := 0. messageListIndex := 0. self classCommentIndicated ifTrue: [] ifFalse: [self editSelection: (anInteger = 0 ifTrue: [metaClassIndicated | (systemCategoryListIndex == 0) ifTrue: [#none] ifFalse: [#newClass]] ifFalse: [#editClass])]. contents := nil. self selectedClass isNil ifFalse: [className := self selectedClass name. (RecentClasses includes: className) ifTrue: [RecentClasses remove: className]. RecentClasses addFirst: className. RecentClasses size > 16 ifTrue: [RecentClasses removeLast]]. self changed: #classSelectionChanged. self changed: #classCommentText. self changed: #classListIndex. "update my selection" self changed: #messageCategoryList. self changed: #messageList. self changed: #relabel. self contentsChanged! ! !Browser methodsFor: 'class list' stamp: 'sd 11/20/2005 21:26'! classListSingleton | name | name := self selectedClassName. ^ name ifNil: [Array new] ifNotNil: [Array with: name]! ! !Browser methodsFor: 'class list' stamp: 'alain.plantec 2/6/2009 16:34'! recent "Let the user select from a list of recently visited classes. 11/96 stp. 12/96 di: use class name, not classes themselves. : dont fall into debugger in empty case" | className class recentList | recentList := RecentClasses select: [:n | Smalltalk includesKey: n]. recentList size == 0 ifTrue: [^ Beeper beep]. className := UIManager default chooseFrom: recentList values: recentList. className isNil ifTrue: [^ self]. class := Smalltalk at: className. self selectCategoryForClass: class. self classListIndex: (self classList indexOf: class name)! ! !Browser methodsFor: 'class list' stamp: 'sr 10/29/1999 20:28'! selectClass: classNotMeta self classListIndex: (self classList indexOf: classNotMeta name)! ! !Browser methodsFor: 'class list' stamp: 'sd 11/20/2005 21:26'! selectedClass "Answer the class that is currently selected. Answer nil if no selection exists." | name envt | (name := self selectedClassName) ifNil: [^ nil]. (envt := self selectedEnvironment) ifNil: [^ nil]. ^ envt at: name! ! !Browser methodsFor: 'class list' stamp: 'sd 11/20/2005 21:26'! selectedClassName | aClassList | "Answer the name of the current class. Answer nil if no selection exists." (classListIndex = 0 or: [classListIndex > (aClassList := self classList) size]) ifTrue: [^ nil]. ^ aClassList at: classListIndex! ! !Browser methodsFor: 'class list'! toggleClassListIndex: anInteger "If anInteger is the current class index, deselect it. Else make it the current class selection." self classListIndex: (classListIndex = anInteger ifTrue: [0] ifFalse: [anInteger])! ! !Browser methodsFor: 'code pane' stamp: 'rr 7/10/2006 11:48'! codePaneMenu: aMenu shifted: shifted ServiceGui browser: self codePaneMenu: aMenu. ServiceGui onlyServices ifTrue: [^ aMenu]. super codePaneMenu: aMenu shifted: shifted. ^ aMenu! ! !Browser methodsFor: 'code pane' stamp: 'sd 11/20/2005 21:26'! compileMessage: aText notifying: aController "Compile the code that was accepted by the user, placing the compiled method into an appropriate message category. Return true if the compilation succeeded, else false." | fallBackCategoryIndex fallBackMethodIndex originalSelectorName result | self selectedMessageCategoryName ifNil: [ self selectOriginalCategoryForCurrentMethod ifFalse:["Select the '--all--' category" self messageCategoryListIndex: 1]]. self selectedMessageCategoryName asSymbol = ClassOrganizer allCategory ifTrue: [ "User tried to save a method while the ALL category was selected" fallBackCategoryIndex := messageCategoryListIndex. fallBackMethodIndex := messageListIndex. editSelection == #newMessage ifTrue: [ "Select the 'as yet unclassified' category" messageCategoryListIndex := 0. (result := self defineMessageFrom: aText notifying: aController) ifNil: ["Compilation failure: reselect the original category & method" messageCategoryListIndex := fallBackCategoryIndex. messageListIndex := fallBackMethodIndex] ifNotNil: [self setSelector: result]] ifFalse: [originalSelectorName := self selectedMessageName. self setOriginalCategoryIndexForCurrentMethod. messageListIndex := fallBackMethodIndex := self messageList indexOf: originalSelectorName. (result := self defineMessageFrom: aText notifying: aController) ifNotNil: [self setSelector: result] ifNil: [ "Compilation failure: reselect the original category & method" messageCategoryListIndex := fallBackCategoryIndex. messageListIndex := fallBackMethodIndex. ^ result notNil]]. self changed: #messageCategoryList. ^ result notNil] ifFalse: [ "User tried to save a method while the ALL category was NOT selected" ^ (self defineMessageFrom: aText notifying: aController) notNil]! ! !Browser methodsFor: 'code pane' stamp: 'sw 5/18/2001 20:55'! showBytecodes "Show or hide the bytecodes of the selected method -- an older protocol now mostly not relevant." self toggleShowingByteCodes! ! !Browser methodsFor: 'construction' stamp: 'sd 11/20/2005 21:26'! addLowerPanesTo: window at: nominalFractions with: editString | commentPane | super addLowerPanesTo: window at: nominalFractions with: editString. commentPane := self buildMorphicCommentPane. window addMorph: commentPane fullFrame: (LayoutFrame fractions: (0@0.75 corner: 1@1)). self changed: #editSelection.! ! !Browser methodsFor: 'copying' stamp: 'sd 11/20/2005 21:26'! veryDeepInner: deepCopier "Copy all of my instance variables. Some need to be not copied at all, but shared. See DeepCopier class comment." super veryDeepInner: deepCopier. "systemOrganizer := systemOrganizer. clone has the old value. we share it" "classOrganizer := classOrganizer clone has the old value. we share it" "metaClassOrganizer := metaClassOrganizer clone has the old value. we share it" systemCategoryListIndex := systemCategoryListIndex veryDeepCopyWith: deepCopier. classListIndex := classListIndex veryDeepCopyWith: deepCopier. messageCategoryListIndex := messageCategoryListIndex veryDeepCopyWith: deepCopier. messageListIndex := messageListIndex veryDeepCopyWith: deepCopier. editSelection := editSelection veryDeepCopyWith: deepCopier. metaClassIndicated := metaClassIndicated veryDeepCopyWith: deepCopier. ! ! !Browser methodsFor: 'drag and drop' stamp: 'nk 6/12/2004 17:43'! acceptDroppingMorph: transferMorph event: evt inMorph: dstListMorph "Here we are fetching informations from the dropped transferMorph and performing the correct action for this drop." | srcType success srcBrowser | success := false. srcType := transferMorph dragTransferType. srcBrowser := transferMorph source model. srcType == #messageList ifTrue: [ | srcClass srcSelector srcCategory | srcClass := transferMorph passenger key. srcSelector := transferMorph passenger value. srcCategory := srcBrowser selectedMessageCategoryName. srcCategory ifNil: [srcCategory := srcClass organization categoryOfElement: srcSelector]. success := self acceptMethod: srcSelector messageCategory: srcCategory class: srcClass atListMorph: dstListMorph internal: self == srcBrowser copy: transferMorph shouldCopy]. srcType == #classList ifTrue: [success := self changeCategoryForClass: transferMorph passenger srcSystemCategory: srcBrowser selectedSystemCategoryName atListMorph: dstListMorph internal: self == srcBrowser copy: transferMorph shouldCopy]. ^ success! ! !Browser methodsFor: 'drag and drop' stamp: 'sd 11/20/2005 21:26'! acceptMethod: methodSel dstMessageCategory: dstMessageCategorySel srcMessageCategory: srcMessageCategorySel dstClass: dstClass dstClassOrMeta: dstClassOrMeta srcClassOrMeta: srcClassOrMeta internal: internal copySemantic: copyFlag | success hierarchyChange higher checkForOverwrite | (success := dstClassOrMeta ~~ nil) ifFalse: [^false]. checkForOverwrite := dstClassOrMeta selectors includes: methodSel. hierarchyChange := (higher := srcClassOrMeta inheritsFrom: dstClassOrMeta) | (dstClassOrMeta inheritsFrom: srcClassOrMeta). success := (checkForOverwrite not or: [self overwriteDialogHierarchyChange: hierarchyChange higher: higher sourceClassName: srcClassOrMeta name destinationClassName: dstClassOrMeta name methodSelector: methodSel]) and: [self message: methodSel compileInClass: dstClassOrMeta fromClass: srcClassOrMeta dstMessageCategory: dstMessageCategorySel srcMessageCategory: srcMessageCategorySel internal: internal copySemantic: copyFlag]. ^ success! ! !Browser methodsFor: 'drag and drop' stamp: 'al 4/24/2004 11:50'! acceptMethod: methodSel messageCategory: srcMessageCategorySel class: srcClassOrMeta atListMorph: dstListMorph internal: internal copy: copyFlag | success dstClassOrMeta dstClass dstMessageCategorySel | dstClass := self dstClassDstListMorph: dstListMorph. dstClassOrMeta := dstClass ifNotNil: [self metaClassIndicated ifTrue: [dstClass classSide] ifFalse: [dstClass]]. dstMessageCategorySel := self dstMessageCategoryDstListMorph: dstListMorph. success := (dstClassOrMeta notNil and: [dstClassOrMeta == srcClassOrMeta]) ifTrue: ["one class" self changeMessageCategoryForMethod: methodSel dstMessageCategory: dstMessageCategorySel srcMessageCategory: srcMessageCategorySel insideClassOrMeta: dstClassOrMeta internal: internal copySemantic: copyFlag] ifFalse: ["different classes" self acceptMethod: methodSel dstMessageCategory: dstMessageCategorySel srcMessageCategory: srcMessageCategorySel dstClass: dstClass dstClassOrMeta: dstClassOrMeta srcClassOrMeta: srcClassOrMeta internal: internal copySemantic: copyFlag]. ^ success! ! !Browser methodsFor: 'drag and drop' stamp: 'sd 11/20/2005 21:26'! changeCategoryForClass: class srcSystemCategory: srcSystemCategorySel atListMorph: dstListMorph internal: internal copy: copyFlag "only move semantic" | newClassCategory success | self flag: #stringSymbolProblem. success := copyFlag not ifFalse: [^ false]. newClassCategory := self dstCategoryDstListMorph: dstListMorph. (success := newClassCategory notNil & (newClassCategory ~= class category)) ifTrue: [class category: newClassCategory. self changed: #classList. internal ifFalse: [self selectClass: class]]. ^ success! ! !Browser methodsFor: 'drag and drop' stamp: 'nk 4/22/2004 18:00'! changeMessageCategoryForMethod: methodSel dstMessageCategory: dstMessageCategorySel srcMessageCategory: srcMessageCategorySel insideClassOrMeta: classOrMeta internal: internal copySemantic: copyFlag "Recategorize the method named by methodSel. If the dstMessageCategorySel is the allCategory, then recategorize it from its parents." | success messageCategorySel | copyFlag ifTrue: [^ false]. "only move semantic" messageCategorySel := dstMessageCategorySel ifNil: [srcMessageCategorySel]. (success := messageCategorySel notNil and: [messageCategorySel ~= srcMessageCategorySel]) ifTrue: [success := messageCategorySel == ClassOrganizer allCategory ifTrue: [self recategorizeMethodSelector: methodSel] ifFalse: [(classOrMeta organization categories includes: messageCategorySel) and: [classOrMeta organization classify: methodSel under: messageCategorySel suppressIfDefault: false. true]]]. success ifTrue: [self changed: #messageList. internal ifFalse: [self setSelector: methodSel]]. ^ success! ! !Browser methodsFor: 'drag and drop' stamp: 'sd 11/20/2005 21:26'! dragPassengerFor: item inMorph: dragSource | transferType smn | (dragSource isKindOf: PluggableListMorph) ifFalse: [^nil]. transferType := self dragTransferTypeForMorph: dragSource. transferType == #classList ifTrue: [^self selectedClass]. transferType == #messageList ifFalse: [ ^nil ]. smn := self selectedMessageName ifNil: [ ^nil ]. (MessageSet isPseudoSelector: smn) ifTrue: [ ^nil ]. ^ self selectedClassOrMetaClass -> smn. ! ! !Browser methodsFor: 'drag and drop' stamp: 'panda 4/28/2000 16:18'! dragTransferTypeForMorph: dragSource ^(dragSource isKindOf: PluggableListMorph) ifTrue: [dragSource getListSelector]! ! !Browser methodsFor: 'drag and drop' stamp: 'ls 6/22/2001 23:21'! dstCategoryDstListMorph: dstListMorph ^(dstListMorph getListSelector == #systemCategoryList) ifTrue: [dstListMorph potentialDropItem ] ifFalse: [self selectedSystemCategoryName]! ! !Browser methodsFor: 'drag and drop' stamp: 'sd 11/20/2005 21:26'! dstClassDstListMorph: dstListMorph | dropItem | ^(dstListMorph getListSelector == #classList) ifTrue: [(dropItem := dstListMorph potentialDropItem) ifNotNil: [Smalltalk at: dropItem withBlanksCondensed asSymbol]] ifFalse: [dstListMorph model selectedClass]! ! !Browser methodsFor: 'drag and drop' stamp: 'sd 11/20/2005 21:26'! dstMessageCategoryDstListMorph: dstListMorph | dropItem | ^dstListMorph getListSelector == #messageCategoryList ifTrue: [dropItem := dstListMorph potentialDropItem. dropItem ifNotNil: [dropItem asSymbol]] ifFalse: [self selectedMessageCategoryName ifNil: [ Categorizer default ]]! ! !Browser methodsFor: 'drag and drop' stamp: 'sd 11/20/2005 21:26'! message: messageSel compileInClass: dstClassOrMeta fromClass: srcClassOrMeta dstMessageCategory: dstMessageCategorySel srcMessageCategory: srcMessageCategorySel internal: internal copySemantic: copyFlag | source messageCategorySel tm success oldOrNoMethod newMethod | source := srcClassOrMeta sourceCodeAt: messageSel. messageCategorySel := dstMessageCategorySel ifNil: [srcMessageCategorySel]. self selectClass: dstClassOrMeta theNonMetaClass. (self messageCategoryList includes: messageCategorySel) ifFalse: ["create message category" self classOrMetaClassOrganizer addCategory: messageCategorySel]. self selectMessageCategoryNamed: messageCategorySel. tm := self codeTextMorph. tm setText: source. tm setSelection: (0 to: 0). tm hasUnacceptedEdits: true. oldOrNoMethod := srcClassOrMeta compiledMethodAt: messageSel ifAbsent: []. tm accept. "compilation successful?" newMethod := dstClassOrMeta compiledMethodAt: messageSel ifAbsent: []. success := newMethod ~~ nil & (newMethod ~~ oldOrNoMethod). " success ifFalse: [TransferMorph allInstances do: [:e | e delete]]. " success ifTrue: [copyFlag not ifTrue: ["remove old method in move semantic if new exists" srcClassOrMeta removeSelector: messageSel].internal ifTrue: [self selectClass: srcClassOrMeta] ifFalse: [self selectClass: dstClassOrMeta]. self setSelector: messageSel]. ^ success! ! !Browser methodsFor: 'drag and drop' stamp: 'alain.plantec 2/6/2009 16:33'! overwriteDialogHierarchyChange: hierarchyChange higher: higherFlag sourceClassName: srcClassName destinationClassName: dstClassName methodSelector: methodSelector | lf | lf := Character cr asString. ^ UIManager default confirm: 'There is a conflict.' translated, ' Overwrite' translated, (hierarchyChange ifTrue: [higherFlag ifTrue: [' superclass' translated] ifFalse: [' subclass' translated]] ifFalse: ['']) , ' method' translated, lf , dstClassName , '>>' , methodSelector , lf , 'by ' translated, (hierarchyChange ifTrue: ['moving' translated] ifFalse: ['copying' translated]) , ' method' translated, lf , srcClassName name , '>>' , methodSelector , ' ?'. ! ! !Browser methodsFor: 'drag and drop' stamp: 'sd 11/20/2005 21:26'! wantsDroppedMorph: transferMorph event: anEvent inMorph: destinationLM "We are only interested in TransferMorphs as wrappers for informations. If their content is really interesting for us, will determined later in >>acceptDroppingMorph:event:." | srcType dstType | "only want drops on lists (not, for example, on pluggable texts)" (destinationLM isKindOf: PluggableListMorph) ifFalse: [^ false]. srcType := transferMorph dragTransferType. dstType := destinationLM getListSelector. (srcType == #messageList and: [dstType == #messageCategoryList or: [dstType == #classList]]) ifTrue: [^true]. (srcType == #classList and: [dstType == #systemCategoryList]) ifTrue: [^true]. " [ srcLS == #messageList ifTrue: [^ dstLS == #messageList | (dstLS == #messageCategoryList) | (dstLS == #classList)]. srcLS == #classList ifTrue: [^ dstLS == #classList | (dstLS == #systemCategoryList)]]. " ^ false! ! !Browser methodsFor: 'initialization' stamp: 'md 2/24/2006 15:24'! addAListPane: aListPane to: window at: nominalFractions plus: verticalOffset | row switchHeight divider | row := AlignmentMorph newColumn hResizing: #spaceFill; vResizing: #spaceFill; layoutInset: 1; borderWidth: 1; layoutPolicy: ProportionalLayout new. switchHeight := 25. self addMorphicSwitchesTo: row at: ( LayoutFrame fractions: (0@1 corner: 1@1) offsets: (0@(1-switchHeight) corner: 0@0) ). divider := BorderedSubpaneDividerMorph forTopEdge. divider extent: 4@4; color: Color transparent; borderColor: #raised; borderWidth: 0. row addMorph: divider fullFrame: ( LayoutFrame fractions: (0@1 corner: 1@1) offsets: (0@switchHeight negated corner: 0@(1-switchHeight)) ). row addMorph: aListPane fullFrame: ( LayoutFrame fractions: (0@0 corner: 1@1) offsets: (0@0 corner: 0@(switchHeight negated)) ). window addMorph: row fullFrame: ( LayoutFrame fractions: nominalFractions offsets: (0@verticalOffset corner: 0@0) ). row on: #mouseEnter send: #paneTransition: to: window. row on: #mouseLeave send: #paneTransition: to: window. ! ! !Browser methodsFor: 'initialization' stamp: 'RAA 1/10/2001 11:46'! addClassAndSwitchesTo: window at: nominalFractions plus: verticalOffset ^self addAListPane: self buildMorphicClassList to: window at: nominalFractions plus: verticalOffset ! ! !Browser methodsFor: 'initialization' stamp: 'rr 6/21/2005 13:24'! addMorphicSwitchesTo: window at: aLayoutFrame window addMorph: self buildMorphicSwitches fullFrame: aLayoutFrame. ! ! !Browser methodsFor: 'initialization' stamp: 'rww 8/18/2002 09:31'! browseSelectionInPlace "In place code - incomplete" " self systemCategoryListIndex: (self systemCategoryList indexOf: self selectedClass category). self classListIndex: (self classList indexOf: self selectedClass name)" self spawnHierarchy.! ! !Browser methodsFor: 'initialization'! browserWindowActivated "Called when a window whose model is the receiver is reactivated, giving the receiver an opportunity to take steps if it wishes. The default is to do nothing. 8/5/96 sw"! ! !Browser methodsFor: 'initialization' stamp: 'alain.plantec 5/15/2009 09:36'! buildMorphicClassList | myClassList | (myClassList := PluggableListMorph new) on: self list: #classList selected: #classListIndex changeSelected: #classListIndex: menu: #classListMenu:shifted: keystroke: #classListKey:from:. myClassList borderWidth: 0. myClassList enableDragNDrop: true. myClassList doubleClickSelector: #browseSelectionInPlace. "For doubleClick to work best disable autoDeselect" myClassList autoDeselect: false . ^myClassList ! ! !Browser methodsFor: 'initialization' stamp: 'alain.plantec 5/15/2009 09:36'! buildMorphicMessageCatList | myMessageCatList | (myMessageCatList := PluggableMessageCategoryListMorph new) on: self list: #messageCategoryList selected: #messageCategoryListIndex changeSelected: #messageCategoryListIndex: menu: #messageCategoryMenu: keystroke: #arrowKey:from: getRawListSelector: #rawMessageCategoryList. myMessageCatList enableDragNDrop: true. ^myMessageCatList ! ! !Browser methodsFor: 'initialization' stamp: 'alain.plantec 5/15/2009 09:36'! buildMorphicMessageList "Build a morphic message list, with #messageList as its list-getter" | aListMorph | (aListMorph := PluggableListMorph new) on: self list: #messageList selected: #messageListIndex changeSelected: #messageListIndex: menu: #messageListMenu:shifted: keystroke: #messageListKey:from:. aListMorph enableDragNDrop: true. aListMorph menuTitleSelector: #messageListSelectorTitle. ^aListMorph ! ! !Browser methodsFor: 'initialization' stamp: 'alain.plantec 5/15/2009 09:36'! buildMorphicSystemCatList | dragNDropFlag myCatList | dragNDropFlag := true. (myCatList := PluggableListMorph new) on: self list: #systemCategoryList selected: #systemCategoryListIndex changeSelected: #systemCategoryListIndex: menu: #systemCategoryMenu: keystroke: #systemCatListKey:from:. myCatList enableDragNDrop: dragNDropFlag. ^myCatList ! ! !Browser methodsFor: 'initialization' stamp: 'sw 1/13/2000 16:45'! defaultBrowserTitle ^ 'System Browser'! ! !Browser methodsFor: 'initialization' stamp: 'ar 1/31/2001 20:56'! highlightClassList: list with: morphList! ! !Browser methodsFor: 'initialization' stamp: 'ar 1/31/2001 20:56'! highlightMessageCategoryList: list with: morphList! ! !Browser methodsFor: 'initialization' stamp: 'ar 1/31/2001 20:56'! highlightSystemCategoryList: list with: morphList! ! !Browser methodsFor: 'initialization' stamp: 'AdrianLienhard 8/26/2009 21:07'! labelString ^self selectedClass ifNil: [ self defaultBrowserTitle ] ifNotNil: [ self selectedClass printString ]. ! ! !Browser methodsFor: 'initialization' stamp: 'sw 9/22/1999 17:13'! methodCategoryChanged self changed: #messageCategoryList. self changed: #messageList. self changed: #annotation. self messageListIndex: 0! ! !Browser methodsFor: 'initialization' stamp: 'marcus.denker 11/26/2008 14:24'! openAsMorphClassEditing: editString "Create a pluggable version a Browser on just a single class." | window dragNDropFlag hSepFrac switchHeight mySingletonClassList | window := (SystemWindow labelled: 'later') model: self. dragNDropFlag := true. hSepFrac := 0.3. switchHeight := 25. mySingletonClassList := PluggableListMorph on: self list: #classListSingleton selected: #indexIsOne changeSelected: #indexIsOne: menu: #classListMenu:shifted: keystroke: #classListKey:from:. mySingletonClassList enableDragNDrop: dragNDropFlag. self addLowerPanesTo: window at: (0@hSepFrac corner: 1@1) with: editString. window addMorph: mySingletonClassList fullFrame: ( LayoutFrame fractions: (0@0 corner: 0.5@0) offsets: (0@0 corner: 0@switchHeight) ). self addMorphicSwitchesTo: window at: ( LayoutFrame fractions: (0.5@0 corner: 1.0@0) offsets: (0@0 corner: 0@switchHeight) ). window addMorph: self buildMorphicMessageCatList fullFrame: ( LayoutFrame fractions: (0@0 corner: 0.5@hSepFrac) offsets: (0@switchHeight corner: 0@0) ). window addMorph: self buildMorphicMessageList fullFrame: ( LayoutFrame fractions: (0.5@0 corner: 1.0@hSepFrac) offsets: (0@switchHeight corner: 0@0) ). window setUpdatablePanesFrom: #(messageCategoryList messageList). ^ window ! ! !Browser methodsFor: 'initialization' stamp: 'sd 11/20/2005 21:26'! openAsMorphEditing: editString "Create a pluggable version of all the morphs for a Browser in Morphic" | window hSepFrac | hSepFrac := 0.4. window := (SystemWindow labelled: 'later') model: self. "The method SystemWindow>>addMorph:fullFrame: checks scrollBarsOnRight, then adds the morph at the back if true, otherwise it is added in front. But flopout hScrollbars need the lowerpanes to be behind the upper ones in the draw order. Hence the value of scrollBarsOnRight affects the order in which the lowerpanes are added. " Preferences scrollBarsOnRight ifFalse: [self addLowerPanesTo: window at: (0@hSepFrac corner: 1@1) with: editString]. window addMorph: self buildMorphicSystemCatList frame: (0@0 corner: 0.25@hSepFrac). self addClassAndSwitchesTo: window at: (0.25@0 corner: 0.5@hSepFrac) plus: 0. window addMorph: self buildMorphicMessageCatList frame: (0.5@0 extent: 0.25@hSepFrac). window addMorph: self buildMorphicMessageList frame: (0.75@0 extent: 0.25@hSepFrac). Preferences scrollBarsOnRight ifTrue: [self addLowerPanesTo: window at: (0@hSepFrac corner: 1@1) with: editString]. window setUpdatablePanesFrom: #(systemCategoryList classList messageCategoryList messageList). ^ window ! ! !Browser methodsFor: 'initialization' stamp: 'marcus.denker 11/26/2008 14:24'! openAsMorphMessageEditing: editString "Create a pluggable version a Browser that shows just one message" | window mySingletonMessageList verticalOffset nominalFractions | window := (SystemWindow labelled: 'later') model: self. mySingletonMessageList := PluggableListMorph on: self list: #messageListSingleton selected: #indexIsOne changeSelected: #indexIsOne: menu: #messageListMenu:shifted: keystroke: #messageListKey:from:. mySingletonMessageList enableDragNDrop: true. verticalOffset := 25. nominalFractions := 0@0 corner: 1@0. window addMorph: mySingletonMessageList fullFrame: ( LayoutFrame fractions: nominalFractions offsets: (0@0 corner: 0@verticalOffset) ). verticalOffset := self addOptionalAnnotationsTo: window at: nominalFractions plus: verticalOffset. verticalOffset := self addOptionalButtonsTo: window at: nominalFractions plus: verticalOffset. window addMorph: (self buildMorphicCodePaneWith: editString) fullFrame: ( LayoutFrame fractions: (0@0 corner: 1@1) offsets: (0@verticalOffset corner: 0@0) ). ^ window! ! !Browser methodsFor: 'initialization' stamp: 'marcus.denker 11/26/2008 14:24'! openAsMorphMsgCatEditing: editString "Create a pluggable version a Browser on just a message category." | window hSepFrac | window := (SystemWindow labelled: 'later') model: self. hSepFrac := 0.3. window addMorph: ((PluggableListMorph on: self list: #messageCatListSingleton selected: #indexIsOne changeSelected: #indexIsOne: menu: #messageCategoryMenu:) enableDragNDrop: true) fullFrame: ( LayoutFrame fractions: (0@0 corner: 1@0) offsets: (0@0 corner: 0@25) ). window addMorph: self buildMorphicMessageList fullFrame: ( LayoutFrame fractions: (0@0 corner: 1@hSepFrac) offsets: (0@25 corner: 0@0) ). self addLowerPanesTo: window at: (0@hSepFrac corner: 1@1) with: editString. window setUpdatablePanesFrom: #(messageCatListSingleton messageList). ^ window! ! !Browser methodsFor: 'initialization' stamp: 'marcus.denker 11/26/2008 14:24'! openAsMorphSysCatEditing: editString "Create a pluggable version of all the views for a Browser, including views and controllers." | window hSepFrac switchHeight mySingletonList nextOffsets | window := (SystemWindow labelled: 'later') model: self. hSepFrac := 0.30. switchHeight := 25. mySingletonList := PluggableListMorph on: self list: #systemCategorySingleton selected: #indexIsOne changeSelected: #indexIsOne: menu: #systemCatSingletonMenu: keystroke: #systemCatSingletonKey:from:. mySingletonList enableDragNDrop: true. mySingletonList hideScrollBarsIndefinitely. window addMorph: mySingletonList fullFrame: ( LayoutFrame fractions: (0@0 corner: 1@0) offsets: (0@0 corner: 0@switchHeight) ). self addClassAndSwitchesTo: window at: (0@0 corner: 0.3333@hSepFrac) plus: switchHeight. nextOffsets := 0@switchHeight corner: 0@0. window addMorph: self buildMorphicMessageCatList fullFrame: ( LayoutFrame fractions: (0.3333@0 corner: 0.6666@hSepFrac) offsets: nextOffsets ). window addMorph: self buildMorphicMessageList fullFrame: ( LayoutFrame fractions: (0.6666@0 corner: 1@hSepFrac) offsets: nextOffsets ). self addLowerPanesTo: window at: (0@hSepFrac corner: 1@1) with: editString. window setUpdatablePanesFrom: #( classList messageCategoryList messageList). ^ window! ! !Browser methodsFor: 'initialization' stamp: 'alain.plantec 6/10/2008 18:33'! openEditString: aString "Create a pluggable version of all the views for a Browser, including views and controllers." ^ self openAsMorphEditing: aString! ! !Browser methodsFor: 'initialization' stamp: 'alain.plantec 6/10/2008 18:34'! openMessageCatEditString: aString "Create a pluggable version of the views for a Browser that just shows one message category." ^ self openAsMorphMsgCatEditing: aString! ! !Browser methodsFor: 'initialization' stamp: 'alain.plantec 5/30/2008 10:08'! openMessageEditString: aString "Create a pluggable version of the views for a Browser that just shows one message." ^ self openAsMorphMessageEditing: aString! ! !Browser methodsFor: 'initialization' stamp: 'alain.plantec 5/30/2008 10:13'! openOnClassWithEditString: aString "Create a pluggable version of all the views for a Browser, including views and controllers." ^ self openAsMorphClassEditing: aString. ! ! !Browser methodsFor: 'initialization' stamp: 'alain.plantec 5/30/2008 10:16'! openSystemCatEditString: aString "Create a pluggable version of all the views for a Browser, including views and controllers. The top list view is of the currently selected system class category--a single item list." ^ self openAsMorphSysCatEditing: aString! ! !Browser methodsFor: 'initialization' stamp: 'sd 11/20/2005 21:26'! setClass: aBehavior selector: aSymbol "Set the state of a new, uninitialized Browser." | isMeta aClass messageCatIndex | aBehavior ifNil: [^ self]. (aBehavior isKindOf: Metaclass) ifTrue: [ isMeta := true. aClass := aBehavior soleInstance] ifFalse: [ isMeta := false. aClass := aBehavior]. self selectCategoryForClass: aClass. self classListIndex: ( (systemOrganizer listAtCategoryNamed: self selectedSystemCategoryName) indexOf: aClass name). self metaClassIndicated: isMeta. aSymbol ifNil: [^ self]. messageCatIndex := aBehavior organization numberOfCategoryOfElement: aSymbol. self messageCategoryListIndex: (messageCatIndex > 0 ifTrue: [messageCatIndex + 1] ifFalse: [0]). messageCatIndex = 0 ifTrue: [^ self]. self messageListIndex: ( (aBehavior organization listAtCategoryNumber: messageCatIndex) indexOf: aSymbol).! ! !Browser methodsFor: 'initialization' stamp: 'sd 11/20/2005 21:26'! setSelector: aSymbol "Make the receiver point at the given selector, in the currently chosen class" | aClass messageCatIndex | aSymbol ifNil: [^ self]. (aClass := self selectedClassOrMetaClass) ifNil: [^ self]. messageCatIndex := aClass organization numberOfCategoryOfElement: aSymbol. self messageCategoryListIndex: messageCatIndex + 1. messageCatIndex = 0 ifTrue: [^ self]. self messageListIndex: ((aClass organization listAtCategoryNumber: messageCatIndex) indexOf: aSymbol)! ! !Browser methodsFor: 'initialization' stamp: 'sw 11/8/1999 13:36'! systemCatSingletonKey: aChar from: aView ^ self messageListKey: aChar from: aView! ! !Browser methodsFor: 'initialization' stamp: 'sd 11/20/2005 21:26'! systemOrganizer: aSystemOrganizer "Initialize the receiver as a perspective on the system organizer, aSystemOrganizer. Typically there is only one--the system variable SystemOrganization." contents := nil. systemOrganizer := aSystemOrganizer. systemCategoryListIndex := 0. classListIndex := 0. messageCategoryListIndex := 0. messageListIndex := 0. metaClassIndicated := false. self setClassOrganizer. self editSelection: #none.! ! !Browser methodsFor: 'message category functions' stamp: 'DamienCassou 9/29/2009 09:04'! addCategory "Present a choice of categories or prompt for a new category name and add it before the current selection, or at the end if no current selection" | labels reject lines cats menuIndex oldIndex newName | self okToChange ifFalse: [^ self]. classListIndex = 0 ifTrue: [^ self]. labels := OrderedCollection with: 'new...'. reject := Set new. reject addAll: self selectedClassOrMetaClass organization categories; add: ClassOrganizer nullCategory; add: ClassOrganizer default. lines := OrderedCollection new. self selectedClassOrMetaClass allSuperclasses do: [:cls | cls = Object ifFalse: [ cats := cls organization categories reject: [:cat | reject includes: cat]. cats isEmpty ifFalse: [ lines add: labels size. labels addAll: cats asSortedCollection. reject addAll: cats]]]. newName := (labels size = 1 or: [ menuIndex := (UIManager default chooseFrom: labels lines: lines title: 'Add Category'). menuIndex = 0 ifTrue: [^ self]. menuIndex = 1]) ifTrue: [ self request: 'Please type new category name' initialAnswer: 'category name'] ifFalse: [ labels at: menuIndex]. oldIndex := messageCategoryListIndex. newName isEmptyOrNil ifTrue: [^ self] ifFalse: [newName := newName asSymbol]. self classOrMetaClassOrganizer addCategory: newName before: (messageCategoryListIndex = 0 ifTrue: [nil] ifFalse: [self selectedMessageCategoryName]). self changed: #messageCategoryList. self messageCategoryListIndex: (oldIndex = 0 ifTrue: [self classOrMetaClassOrganizer categories size + 1] ifFalse: [oldIndex]). self changed: #messageCategoryList. ! ! !Browser methodsFor: 'message category functions' stamp: 'NS 4/7/2004 22:47'! alphabetizeMessageCategories classListIndex = 0 ifTrue: [^ false]. self okToChange ifFalse: [^ false]. self classOrMetaClassOrganizer sortCategories. self clearUserEditFlag. self editClass. self classListIndex: classListIndex. ^ true! ! !Browser methodsFor: 'message category functions'! buildMessageCategoryBrowser "Create and schedule a message category browser for the currently selected message category." self buildMessageCategoryBrowserEditString: nil! ! !Browser methodsFor: 'message category functions' stamp: 'sd 11/20/2005 21:26'! buildMessageCategoryBrowserEditString: aString "Create and schedule a message category browser for the currently selected message category. The initial text view contains the characters in aString." "wod 6/24/1998: set newBrowser classListIndex so that it works whether the receiver is a standard or a Hierarchy Browser." | newBrowser | messageCategoryListIndex ~= 0 ifTrue: [newBrowser := Browser new. newBrowser systemCategoryListIndex: systemCategoryListIndex. newBrowser classListIndex: (newBrowser classList indexOf: self selectedClassName). newBrowser metaClassIndicated: metaClassIndicated. newBrowser messageCategoryListIndex: messageCategoryListIndex. newBrowser messageListIndex: messageListIndex. self class openBrowserView: (newBrowser openMessageCatEditString: aString) label: 'Message Category Browser (' , newBrowser selectedClassOrMetaClassName , ')']! ! !Browser methodsFor: 'message category functions' stamp: 'sw 10/8/2001 14:10'! canShowMultipleMessageCategories "Answer whether the receiver is capable of showing multiple message categories" ^ true! ! !Browser methodsFor: 'message category functions' stamp: 'sd 11/20/2005 21:26'! categoryOfCurrentMethod "Determine the method category associated with the receiver at the current moment, or nil if none" | aCategory | ^ super categoryOfCurrentMethod ifNil: [(aCategory := self messageCategoryListSelection) == ClassOrganizer allCategory ifTrue: [nil] ifFalse: [aCategory]]! ! !Browser methodsFor: 'message category functions' stamp: 'NS 4/7/2004 22:56'! changeMessageCategories: aString "The characters in aString represent an edited version of the the message categories for the selected class. Update this information in the system and inform any dependents that the categories have been changed. This message is invoked because the user had issued the categories command and edited the message categories. Then the user issued the accept command." self classOrMetaClassOrganizer changeFromString: aString. self clearUserEditFlag. self editClass. self classListIndex: classListIndex. ^ true! ! !Browser methodsFor: 'message category functions' stamp: 'nk 2/14/2004 15:06'! editMessageCategories "Indicate to the receiver and its dependents that the message categories of the selected class have been changed." self okToChange ifFalse: [^ self]. classListIndex ~= 0 ifTrue: [self messageCategoryListIndex: 0. self editSelection: #editMessageCategories. self changed: #editMessageCategories. self contentsChanged]! ! !Browser methodsFor: 'message category functions' stamp: 'tk 4/2/98 13:53'! fileOutMessageCategories "Print a description of the selected message category of the selected class onto an external file." Cursor write showWhile: [messageCategoryListIndex ~= 0 ifTrue: [self selectedClassOrMetaClass fileOutCategory: self selectedMessageCategoryName]]! ! !Browser methodsFor: 'message category functions' stamp: 'marcus.denker 10/20/2008 20:53'! messageCategoryMenu: aMenu ServiceGui browser: self messageCategoryMenu: aMenu. ServiceGui onlyServices ifTrue: [^aMenu]. ^ aMenu labels: 'browse fileOut reorganize alphabetize remove empty categories categorize all uncategorized new category... rename... remove' lines: #(3 8) selections: #(buildMessageCategoryBrowser fileOutMessageCategories editMessageCategories alphabetizeMessageCategories removeEmptyCategories categorizeAllUncategorizedMethods addCategory renameCategory removeMessageCategory) ! ! !Browser methodsFor: 'message category functions' stamp: 'nk 4/23/2004 09:18'! removeEmptyCategories self okToChange ifFalse: [^ self]. self selectedClassOrMetaClass organization removeEmptyCategories. self changed: #messageCategoryList ! ! !Browser methodsFor: 'message category functions' stamp: 'sd 11/20/2005 21:26'! removeMessageCategory "If a message category is selected, create a Confirmer so the user can verify that the currently selected message category should be removed from the system. If so, remove it." | messageCategoryName | messageCategoryListIndex = 0 ifTrue: [^ self]. self okToChange ifFalse: [^ self]. messageCategoryName := self selectedMessageCategoryName. (self messageList size = 0 or: [self confirm: 'Are you sure you want to remove this method category and all its methods?']) ifTrue: [self selectedClassOrMetaClass removeCategory: messageCategoryName. self messageCategoryListIndex: 0. self changed: #classSelectionChanged]. self changed: #messageCategoryList. ! ! !Browser methodsFor: 'message category functions' stamp: 'DamienCassou 9/29/2009 09:05'! renameCategory "Prompt for a new category name and add it before the current selection, or at the end if no current selection" | oldIndex oldName newName | classListIndex = 0 ifTrue: [^ self]. self okToChange ifFalse: [^ self]. (oldIndex := messageCategoryListIndex) = 0 ifTrue: [^ self]. oldName := self selectedMessageCategoryName. newName := self request: 'Please type new category name' initialAnswer: oldName. newName isEmptyOrNil ifTrue: [^ self] ifFalse: [newName := newName asSymbol]. newName = oldName ifTrue: [^ self]. self classOrMetaClassOrganizer renameCategory: oldName toBe: newName. self classListIndex: classListIndex. self messageCategoryListIndex: oldIndex. self changed: #messageCategoryList. ! ! !Browser methodsFor: 'message category functions' stamp: 'sd 11/20/2005 21:26'! showHomeCategory "Show the home category of the selected method. This is only really useful if one is in a tool that supports the showing of categories. Thus, it's good in browsers and hierarchy browsers but not in message-list browsers" | aSelector | self okToChange ifTrue: [(aSelector := self selectedMessageName) ifNotNil: [self selectOriginalCategoryForCurrentMethod. self selectedMessageName: aSelector]]! ! !Browser methodsFor: 'message category list' stamp: 'sd 11/20/2005 21:26'! categorizeAllUncategorizedMethods "Categorize methods by looking in parent classes for a method category." | organizer organizers | organizer := self classOrMetaClassOrganizer. organizers := self selectedClassOrMetaClass withAllSuperclasses collect: [:ea | ea organization]. (organizer listAtCategoryNamed: ClassOrganizer default) do: [:sel | | found | found := (organizers collect: [ :org | org categoryOfElement: sel]) detect: [:ea | ea ~= ClassOrganizer default and: [ ea ~= nil]] ifNone: []. found ifNotNil: [organizer classify: sel under: found]]. self changed: #messageCategoryList! ! !Browser methodsFor: 'message category list' stamp: 'sd 11/20/2005 21:26'! messageCatListSingleton | name | name := self selectedMessageCategoryName. ^ name ifNil: [Array new] ifNotNil: [Array with: name]! ! !Browser methodsFor: 'message category list' stamp: 'ccn 3/22/1999 17:56'! messageCategoryList "Answer the selected category of messages." classListIndex = 0 ifTrue: [^ Array new] ifFalse: [^ (Array with: ClassOrganizer allCategory), self classOrMetaClassOrganizer categories]! ! !Browser methodsFor: 'message category list'! messageCategoryListIndex "Answer the index of the selected message category." ^messageCategoryListIndex! ! !Browser methodsFor: 'message category list' stamp: 'sd 11/20/2005 21:26'! messageCategoryListIndex: anInteger "Set the selected message category to be the one indexed by anInteger." messageCategoryListIndex := anInteger. messageListIndex := 0. self changed: #messageCategorySelectionChanged. self changed: #messageCategoryListIndex. "update my selection" self changed: #messageList. self editSelection: (anInteger > 0 ifTrue: [#newMessage] ifFalse: [self classListIndex > 0 ifTrue: [#editClass] ifFalse: [#newClass]]). contents := nil. self contentsChanged.! ! !Browser methodsFor: 'message category list' stamp: 'ccn 3/24/1999 11:02'! messageCategoryListSelection "Return the selected category name or nil." ^ ((self messageCategoryList size = 0 or: [self messageCategoryListIndex = 0]) or: [self messageCategoryList size < self messageCategoryListIndex]) ifTrue: [nil] ifFalse: [self messageCategoryList at: (self messageCategoryListIndex max: 1)]! ! !Browser methodsFor: 'message category list' stamp: 'sw 10/16/1999 22:56'! rawMessageCategoryList ^ classListIndex = 0 ifTrue: [Array new] ifFalse: [self classOrMetaClassOrganizer categories]! ! !Browser methodsFor: 'message category list' stamp: 'nk 4/22/2004 17:59'! recategorizeMethodSelector: sel "Categorize method named sel by looking in parent classes for a method category. Answer true if recategorized." | thisCat | self selectedClassOrMetaClass allSuperclasses do: [:ea | thisCat := ea organization categoryOfElement: sel. (thisCat ~= ClassOrganizer default and: [thisCat notNil]) ifTrue: [self classOrMetaClassOrganizer classify: sel under: thisCat. self changed: #messageCategoryList. ^ true]]. ^ false! ! !Browser methodsFor: 'message category list' stamp: 'nk 6/13/2004 06:20'! selectMessageCategoryNamed: aSymbol "Given aSymbol, select the category with that name. Do nothing if aSymbol doesn't exist." self messageCategoryListIndex: (self messageCategoryList indexOf: aSymbol ifAbsent: [ 1])! ! !Browser methodsFor: 'message category list' stamp: 'sd 11/20/2005 21:26'! selectOriginalCategoryForCurrentMethod "private - Select the message category for the current method. Note: This should only be called when somebody tries to save a method that they are modifying while ALL is selected. Returns: true on success, false on failure." | aSymbol selectorName | aSymbol := self categoryOfCurrentMethod. selectorName := self selectedMessageName. (aSymbol notNil and: [aSymbol ~= ClassOrganizer allCategory]) ifTrue: [messageCategoryListIndex := (self messageCategoryList indexOf: aSymbol). messageListIndex := (self messageList indexOf: selectorName). self changed: #messageCategorySelectionChanged. self changed: #messageCategoryListIndex. "update my selection" self changed: #messageList. self changed: #messageListIndex. ^ true]. ^ false! ! !Browser methodsFor: 'message category list'! selectedMessageCategoryName "Answer the name of the selected message category, if any. Answer nil otherwise." messageCategoryListIndex = 0 ifTrue: [^nil]. ^self messageCategoryList at: messageCategoryListIndex! ! !Browser methodsFor: 'message category list' stamp: 'sd 11/20/2005 21:26'! setOriginalCategoryIndexForCurrentMethod "private - Set the message category index for the currently selected method. Note: This should only be called when somebody tries to save a method that they are modifying while ALL is selected." messageCategoryListIndex := self messageCategoryList indexOf: self categoryOfCurrentMethod ! ! !Browser methodsFor: 'message functions' stamp: 'sw 1/11/2001 07:22'! addExtraShiftedItemsTo: aMenu "The shifted selector-list menu is being built; some menu items are appropriate only for certain kinds of browsers, and this gives a hook for them to be added as approrpiate. If any is added here, a line should be added first -- browse reimplementors of this message for examples." ! ! !Browser methodsFor: 'message functions'! buildMessageBrowser "Create and schedule a message browser on the currently selected message. Do nothing if no message is selected. The initial text view contains nothing." self buildMessageBrowserEditString: nil! ! !Browser methodsFor: 'message functions' stamp: 'sd 1/5/2002 21:11'! buildMessageBrowserEditString: aString "Create and schedule a message browser for the receiver in which the argument, aString, contains characters to be edited in the text view." messageListIndex = 0 ifTrue: [^ self]. ^ self class openMessageBrowserForClass: self selectedClassOrMetaClass selector: self selectedMessageName editString: aString! ! !Browser methodsFor: 'message functions' stamp: 'sd 11/20/2005 21:26'! defineMessage: aString notifying: aController "Compile the expressions in aString. Notify aController if a syntax error occurs. Install the compiled method in the selected class classified under the currently selected message category name. Answer true if compilation succeeds, false otherwise." | selectedMessageName selector category oldMessageList | selectedMessageName := self selectedMessageName. oldMessageList := self messageList. contents := nil. selector := self selectedClassOrMetaClass compile: aString classified: (category := self selectedMessageCategoryName) notifying: aController. selector == nil ifTrue: [^ false]. contents := aString copy. selector ~~ selectedMessageName ifTrue: [category = ClassOrganizer nullCategory ifTrue: [self changed: #classSelectionChanged. self changed: #classList. self messageCategoryListIndex: 1]. self setClassOrganizer. "In case organization not cached" (oldMessageList includes: selector) ifFalse: [self changed: #messageList]. self messageListIndex: (self messageList indexOf: selector)]. ^ true! ! !Browser methodsFor: 'message functions' stamp: 'lr 7/3/2009 20:59'! defineMessageFrom: aString notifying: aController "Compile the expressions in aString. Notify aController if a syntax error occurs. Install the compiled method in the selected class classified under the currently selected message category name. Answer the selector obtained if compilation succeeds, nil otherwise." | selectedMessageName selector category oldMessageList | selectedMessageName := self selectedMessageName. oldMessageList := self messageList. contents := nil. selector := self selectedClassOrMetaClass compile: aString classified: (category := self selectedMessageCategoryName) notifying: aController. selector == nil ifTrue: [^ nil]. contents := aString copy. selector ~~ selectedMessageName ifTrue: [category = ClassOrganizer nullCategory ifTrue: [self changed: #classSelectionChanged. self changed: #classList. self messageCategoryListIndex: 1]. self setClassOrganizer. "In case organization not cached" (oldMessageList includes: selector) ifFalse: [self changed: #messageList]. self messageListIndex: (self messageList indexOf: selector)]. ^ selector! ! !Browser methodsFor: 'message functions' stamp: 'al 4/24/2004 12:48'! inspectInstances "Inspect all instances of the selected class. 1/26/96 sw" | myClass | ((myClass := self selectedClassOrMetaClass) isNil or: [myClass isTrait]) ifFalse: [myClass theNonMetaClass inspectAllInstances] ! ! !Browser methodsFor: 'message functions' stamp: 'al 4/24/2004 12:48'! inspectSubInstances "Inspect all instances of the selected class and all its subclasses 1/26/96 sw" | aClass | ((aClass := self selectedClassOrMetaClass) isNil or: [aClass isTrait]) ifFalse: [ aClass := aClass theNonMetaClass. aClass inspectSubInstances]. ! ! !Browser methodsFor: 'message functions' stamp: 'marcus.denker 9/20/2008 20:27'! messageListMenu: aMenu shifted: shifted "Answer the message-list menu" ServiceGui browser: self messageListMenu: aMenu. ServiceGui onlyServices ifTrue: [^ aMenu]. shifted ifTrue: [^ self shiftedMessageListMenu: aMenu]. aMenu addList: #( ('what to show...' offerWhatToShowMenu) ('toggle break on entry' toggleBreakOnEntry) - ('browse full (b)' browseMethodFull) ('browse hierarchy (h)' classHierarchy) ('browse method (O)' openSingleMessageBrowser) ('browse protocol (p)' browseFullProtocol) - ('fileOut' fileOutMessage) - ('senders of... (n)' browseSendersOfMessages) ('implementors of... (m)' browseMessages) ('inheritance (i)' methodHierarchy) ('versions (v)' browseVersions) - ('inst var refs...' browseInstVarRefs) ('inst var defs...' browseInstVarDefs) ('class var refs...' browseClassVarRefs) ('class variables' browseClassVariables) ('class refs (N)' browseClassRefs) - ('remove method (x)' remove