Dream 52/Amiga_Dream_52.iso/RiscOS/APP/DEVS/SMALLT/SQ123B.ZIP/Sq123b/sq123

Text File | 1997-10-14 | 2MB | 7 lines

'From Squeak 1.23 of October 4, 1997 on 5 October 1997 at 11:09:00 am'!!AbstractSound methodsFor: 'initialization'!setPitch: p dur: d loudness: l    self subclassResponsibility.! !!AbstractSound methodsFor: 'playing' stamp: 'jm 8/24/97 20:48'!pause    "Pause this sound. It can be resumed from this point, or reset and resumed to start from the beginning."    SoundPlayer pauseSound: self.! !!AbstractSound methodsFor: 'playing'!playSampleCount: n into: aSoundBuffer startingAt: startIndex stereo: stereoFlag    "Mixes the next count samples of this sound into the given buffer starting at the given index, updating the receiver's control parameters at periodic intervals."    | leftRightPan samplesBetweenControlUpdates pastEnd i remainingSamples count |    stereoFlag ifTrue: [leftRightPan _ 500] ifFalse: [leftRightPan _ 1000].    samplesBetweenControlUpdates _ self samplingRate // self controlRate.    pastEnd _ startIndex + n.  "index just index of after last sample"    i _ startIndex.    [i < pastEnd] whileTrue: [        remainingSamples _ self samplesRemaining.        remainingSamples <= 0 ifTrue: [ ^ self ].        count _ pastEnd - i.        samplesUntilNextControl < count ifTrue: [ count _ samplesUntilNextControl ].        remainingSamples < count        ifTrue: [ count _ remainingSamples ].        self mixSampleCount: count into: aSoundBuffer startingAt: i pan: leftRightPan.        samplesUntilNextControl _ samplesUntilNextControl - count.        samplesUntilNextControl <= 0 ifTrue: [            self doControl.            samplesUntilNextControl _ samplesBetweenControlUpdates.        ].        i _ i + count.    ].! !!AbstractSound methodsFor: 'playing' stamp: 'jm 9/17/97 12:58'!playSilently    "Compute the samples of this sound without outputting them. Used for performance analysis."    | buf |    self reset.    buf _ SoundBuffer newStereoSampleCount: (self samplingRate // 10).    [self samplesRemaining > 0] whileTrue: [        buf primFill: 0.        self playSampleCount: buf stereoSampleCount into: buf startingAt: 1 stereo: true].! !!AbstractSound methodsFor: 'playing' stamp: 'jm 9/13/97 19:46'!resumePlaying    "Pause this sound. It can be resumed from this point, or reset and resumed to start from the beginning."    SoundPlayer pauseSound: self.  "be sure it isn't already playing"    SoundPlayer resumePlaying: self.! !!AbstractSound methodsFor: 'sampling rates' stamp: 'jm 9/18/97 18:43'!controlRate    "Answer the number of control changes per second."    ^ 40! !!AbstractSound methodsFor: 'copying' stamp: 'jm 10/4/97 16:39'!copy    "A sound should copy all of the state needed to play itself. Thus, two copies of a sound can be played at the same time. These semantics require a recursive copy down to the level of immutable data. For example, a SampledSound need not copy its sample buffer."    self subclassResponsibility.! !!AbstractSound class methodsFor: 'examples' stamp: 'jm 8/23/97 22:15'!bachFugue    "Play a fugue by J. S. Bach using the receiver as the sound for all four voices."    "BoinkSound bachFugue play"    ^ MixedSound new        add: self bachFugueVoice1 pan: 1000;        add: self bachFugueVoice2 pan: 0;        add: self bachFugueVoice3 pan: 1000;        add: self bachFugueVoice4 pan: 0.! !!AbstractSound class methodsFor: 'examples' stamp: 'jm 8/23/97 22:15'!stereoBachFugue    "Play fugue by J. S. Bach in stereo using different timbres."    "AbstractSound stereoBachFugue play"    "BoinkSound            bachFugueVoice1 play"    "WaveTableSound    bachFugueVoice1 play"    "PluckedSound        bachFugueVoice1 play"    "FMSound            bachFugueVoice1 play"    ^ MixedSound new        add: BoinkSound bachFugueVoice1 pan: 200;        add: WaveTableSound bachFugueVoice2 pan: 800;        add: FMSound bachFugueVoice3 pan: 400;        add: FMSound bachFugueVoice4 pan: 600.! !!AbstractSound class methodsFor: 'examples'!testFMInteractively    "Experiment with different settings of the FM modulation and multiplier settings interactively by moving the mouse. The top-left corner of the screen is 0 for both parameters. Stop when the mouse is pressed."    "AbstractSound testFMInteractively"    | s mousePt lastVal status |    SoundPlayer startPlayerProcessBufferSize: 1100 rate: 22050 stereo: false.    s _ FMSound pitch: 440.0 dur: 200.0 loudness: 200.    s  decayRate: 1.0; modulationDecay: 1.0.    SoundPlayer playSound: s.    [Sensor anyButtonPressed] whileFalse: [        mousePt _ Sensor cursorPoint.        mousePt ~= lastVal ifTrue: [            s modulation: mousePt x * 3 multiplier: mousePt y asFloat / 100.0.            lastVal _ mousePt.            status _'mod: ', (mousePt x * 3) printString, 'mult: ', (mousePt y asFloat / 100.0) printString.            status asParagraph displayOn: Display at: 10@10.        ].    ].    SoundPlayer shutDown.! !!AbstractSound class methodsFor: 'primitive generation'!cCodeForSoundPrimitives    "Return a string containing the C code for the sound primitives. This string is pasted into a file, compiled, and linked into the virtual machine. Note that the virtual machine's primitive table must also be edited to make new primitives available."    ^ CCodeGenerator new codeStringForPrimitives: #(        (WaveTableSound mixSampleCount:into:startingAt:pan:)        (FMSound mixSampleCount:into:startingAt:pan:)        (PluckedSound mixSampleCount:into:startingAt:pan:)        (SampledSound mixSampleCount:into:startingAt:pan:)    ).! !!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' stamp: 'di 7/17/97 10:18'!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)) asIntegerPoint.            line endPoint: (center + (xn1 asInteger @ yn1 asInteger)) asIntegerPoint.            line                displayOn: aDisplayMedium                at: aPoint                clippingBox: clipRect                rule: anInteger                fillColor: aForm.            xn _ xn1.            yn _ yn1]! !!Array methodsFor: 'printing' stamp: 'di 6/20/97 09:09'!printOn: aStream    aStream nextPut: $(.    self do: [:element | element printOn: aStream. aStream space].    aStream nextPut: $)! !!Array2D methodsFor: 'access'!atCol: i put: list    "Put in a whole column.     hold first index constant"    list size = self height ifFalse: [self error: 'wrong size'].    list doWithIndex: [:value :j |        self at: i at: j put: value].! !!Array2D methodsFor: 'access'!atRow: j put: list    "Put in a whole row.     hold second index constant"    list size = self width ifFalse: [self error: 'wrong size'].    list doWithIndex: [:value :i |        self at: i at: j put: value].! !!AssignmentNode methodsFor: 'C translation'!asTranslatorNode    ^TAssignmentNode new        setVariable: variable asTranslatorNode        expression: value asTranslatorNode! !!AtomMorph methodsFor: 'all'!bounceIn: aRect    | p vx vy px py |    p _ self position.    vx _ velocity x.  vy _ velocity y.    px _ p x + vx.  py _ p y + vy.    px > aRect right ifTrue: [        px _ aRect right - (px - aRect right).        vx _ velocity x negated.    ].    py > aRect bottom ifTrue: [        py _  aRect bottom - (py - aRect bottom).        vy _ velocity y negated.    ].    px < aRect left ifTrue: [        px _ aRect left - (px - aRect left).        vx _ velocity x negated.    ].    py < aRect top ifTrue: [        py _  aRect top - (py - aRect top).        vy _ velocity y negated.    ].    self position: px @ py.    self velocity: vx @ vy.! !!AtomMorph methodsFor: 'all'!drawOn: aCanvas    "Note: Set 'drawAsRect' to true to make the atoms draw faster. When testing the speed of other aspects of Morphic, such as its damage handling efficiency for large numbers of atoms, it is useful to make drawing faster."    | drawAsRect |    drawAsRect _ false.  "rectangles are faster to draw"    drawAsRect        ifTrue: [aCanvas fillRectangle: self bounds color: color]        ifFalse: [super drawOn: aCanvas].! !!AtomMorph methodsFor: 'all'!infected    ^ color = Color red! !!AtomMorph methodsFor: 'all'!infected: aBoolean    aBoolean        ifTrue: [self color: Color red]        ifFalse: [self color: Color blue].! !!AtomMorph methodsFor: 'all'!initialize    "Make a new atom with a random position and velocity."    super initialize.    self extent: 8@7.    self color: Color blue.    self borderWidth: 0.    self randomPositionIn: (0@0 corner: 300@300) maxVelocity: 10.! !!AtomMorph methodsFor: 'all'!randomPositionIn: aRectangle maxVelocity: maxVelocity    "Give this atom a random position and velocity."    | origin extent |    origin _ aRectangle origin.    extent _ aRectangle extent - self bounds extent.    self position:        (origin x + extent x atRandom) @        (origin y + extent y atRandom).    velocity _        (maxVelocity - (2 * maxVelocity) atRandom) @        (maxVelocity - (2 * maxVelocity) atRandom).! !!AtomMorph methodsFor: 'all'!velocity    ^ velocity! !!AtomMorph methodsFor: 'all'!velocity: newVelocity    velocity _ newVelocity.! !!AtomMorph class methodsFor: 'instance creation' stamp: 'di 6/22/97 09:07'!includeInNewMorphMenu    "Not to be instantiated from the menu"    ^ false! !BackgroundMorph comment:'This morph incorporates tiling and regular motion with the intent of supporting, eg, panning of endless (toroidal) backgrounds.The idea is that embedded morphs get displayed at a moving offset relative to my position.  Moreover this display is tiled according to the bounding box of the submorphs (subBounds), as much as necesary to fill the rest of my bounds.'!!BackgroundMorph methodsFor: 'all' stamp: 'jm 9/28/97 14:44'!addCustomMenuItems: aCustomMenu hand: aHandMorph    running        ifTrue: [aCustomMenu add: 'stop' action: #stopRunning]        ifFalse: [aCustomMenu add: 'start' action: #startRunning].! !!BackgroundMorph methodsFor: 'all'!drawOn: aCanvas    "The tiling is solely determined by bounds, subBounds and offset.    The extent of display is determined by bounds and the clipRect of the canvas."    | start tileCanvas d subBnds |    submorphs isEmpty ifTrue: [^ super drawOn: aCanvas].    subBnds _ self subBounds.    running ifFalse:        [super drawOn: aCanvas.        ^ aCanvas fillRectangle: subBnds color: Color lightBlue].    start _ subBnds topLeft + offset - bounds topLeft - (1@1) \\ subBnds extent - subBnds extent + (1@1).    d _ subBnds topLeft - bounds topLeft."Sensor redButtonPressed ifTrue: [self halt]."    start x to: bounds width - 1 by: subBnds width do:        [:x |        start y to: bounds height - 1 by: subBnds height do:            [:y | tileCanvas _ aCanvas copyOffset: (x@y) - d clipRect: bounds.            submorphs reverseDo: [:m | m fullDrawOn: tileCanvas]]]! !!BackgroundMorph methodsFor: 'all'!fullBounds    ^ self bounds! !!BackgroundMorph methodsFor: 'all'!fullDrawOn: aCanvas    running ifFalse: [^ super fullDrawOn: (aCanvas copyClipRect: (bounds translateBy: aCanvas origin))].    (aCanvas isVisible: bounds) ifTrue: [self drawOn: aCanvas].! !!BackgroundMorph methodsFor: 'all'!initialize    super initialize.    offset _ 0@0.    delta _ 1@0.    running _ true! !!BackgroundMorph methodsFor: 'all'!layoutChanged    "Do nothing, since I clip my submorphs"! !!BackgroundMorph methodsFor: 'all'!rootForGrabOf: aMorph    "Be sticky."    ^ nil! !!BackgroundMorph methodsFor: 'all'!slideBy: inc    submorphs isEmpty ifTrue: [^ self].    offset _ offset + inc \\ self subBounds extent.    self changed! !!BackgroundMorph methodsFor: 'all'!startRunning    running _ true.    self changed! !!BackgroundMorph methodsFor: 'all'!step    "Answer the desired time between steps in milliseconds."    running ifTrue: [self slideBy: delta]! !!BackgroundMorph methodsFor: 'all'!stepTime    "Answer the desired time between steps in milliseconds."    ^ 20! !!BackgroundMorph methodsFor: 'all'!stopRunning    running _ false.    self changed! !!BackgroundMorph methodsFor: 'all'!subBounds    "calculate the submorph bounds"    | subBounds |    subBounds _ nil.    self submorphsDo:        [:m | subBounds == nil            ifTrue: [subBounds _ m fullBounds]            ifFalse: [subBounds _ subBounds merge: m fullBounds]].    ^ subBounds! !!BackgroundMorph class methodsFor: 'as yet unclassified'!test    ^ self new image: Form fromUser! !!Bag methodsFor: 'accessing' stamp: 'di 9/11/97 16:14'!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]! !!BalloonHelpMorph methodsFor: 'initialization' stamp: 'di 6/14/97 00:51'!initialize    super initialize.    active _ true! !!BalloonHelpMorph methodsFor: 'events' stamp: 'di 6/14/97 01:06'!mouseEnter: event    super mouseEnter: event.    self balloonsEnabled ifFalse: [^ self].    self mouseEnter: event inMorph: self.    self submorphsDo:        [:m | m on: #mouseEnter send: #mouseEnter:inMorph: to: self;                on: #mouseLeave send: #mouseLeave:fromMorph: to: self].! !!BalloonHelpMorph methodsFor: 'events' stamp: 'di 6/14/97 00:39'!mouseEnter: event inMorph: m    theBalloon ifNotNil: [theBalloon delete].    self disabled ifTrue: [^ self].    theBalloon _ self buildBalloonFor: m.    theBalloon position: m bottomRight.    ticksToGo _ 15.  "Delay in units of .1 seconds"    self world startStepping: self! !!BalloonHelpMorph methodsFor: 'events' stamp: 'di 6/14/97 01:07'!mouseLeave: event    super mouseLeave: event.    self balloonsEnabled ifFalse: [^ self].    self mouseLeave: event fromMorph: self.    active _ true! !!BalloonHelpMorph methodsFor: 'events' stamp: '6/11/97 09:18 di'!mouseLeave: event fromMorph: m    theBalloon ifNotNil: [theBalloon delete].    theBalloon _ nil.    (self containsPoint: event cursorPoint) ifTrue:        [self mouseEnter: event inMorph: self]! !!BalloonHelpMorph methodsFor: 'geometry' stamp: '6/11/97 09:56 di'!containsPoint: aPoint    "This method is overridden so that the help baloon doesn't really extend     the bounds as an outer rectangle."    | handleBounds |    theBalloon ifNil: [^ super containsPoint: aPoint].    handleBounds _ bounds.    self submorphsDo:        [:m | m == theBalloon ifFalse: [handleBounds _ handleBounds merge: m bounds]].    ^ handleBounds containsPoint: aPoint! !!BalloonHelpMorph methodsFor: 'stepping' stamp: '6/11/97 09:57 di'!step    ticksToGo _ ticksToGo - 1.    ticksToGo > 0 ifTrue: [^ self].    theBalloon ifNotNil: [self addMorph: theBalloon; changed].    self world stopStepping: self! !!BalloonHelpMorph methodsFor: 'stepping' stamp: '6/11/97 07:31 di'!stepTime    ^ 100! !!BalloonHelpMorph methodsFor: 'stepping' stamp: 'di 6/12/97 11:40'!wantsSteps    ^ theBalloon ~~ nil and: [ticksToGo ~~ nil]! !!BalloonHelpMorph methodsFor: 'private' stamp: 'di 6/11/97 11:54'!balloonHelpText    | str addOn className |    className _ (owner isWorldMorph ifTrue: [self] ifFalse: [owner]) class name.    str _ super balloonHelpText.    addOn _ 'This ' , className , ' is showingcontrol handles.  Move the handover them if you want to know more.'.    str isEmpty ifTrue: [^ addOn].    ^ str , Character cr asString , addOn! !!BalloonHelpMorph methodsFor: 'private' stamp: 'di 6/14/97 01:06'!balloonsEnabled    ^ BalloonsEnabled! !!BalloonHelpMorph methodsFor: 'private' stamp: 'di 6/14/97 00:57'!buildBalloonFor: morph    | str s e |    str _ morph == self        ifTrue: [self balloonHelpText]        ifFalse: ['If you click on this handle, it will' , (#('probably not do anything.'        'let you drag this morph.'        'let you rotate this morph.'        'bring up a menu for this morph.'        'let you resize this morph.'        'let you duplicate this morph.')    at: (#(none black blue red yellow green) indexOf: morph color name ifAbsent: [1]))].    s _ TextMorph new contents: (Text string: str attribute: (TextFontReference toFont: ((TextConstants at: #ClairVaux) fontAt: 5))).    s centered.    e _ EllipseMorph newBounds: (s bounds expandBy: 20) color: (Color r: 1.0 g: 1.0 b: 0.6).    e addMorph: s.    e on: #mouseDown send: #disable to: self.    ^ e position: morph bottomRight! !!BalloonHelpMorph methodsFor: 'private' stamp: 'di 6/14/97 00:40'!disable    active _ false.    theBalloon ifNotNil: [theBalloon delete].    theBalloon _ ticksToGo _ nil.    self world stopStepping: self! !!BalloonHelpMorph methodsFor: 'private' stamp: 'di 6/14/97 00:50'!disabled    active ifNil: [^ false].    ^ active not! !!BalloonHelpMorph methodsFor: 'private' stamp: 'di 6/14/97 00:40'!removeAllHandles    self disable.    super removeAllHandles! !!BalloonHelpMorph class methodsFor: 'all' stamp: 'di 6/14/97 01:12'!balloonsEnabled: trueOrFalse    "BalloonHelpMorph balloonsEnabled: true"    "BalloonHelpMorph balloonsEnabled: false"    BalloonsEnabled _ trueOrFalse! !!Behavior methodsFor: 'initialize-release'!obsolete    "Invalidate and recycle local messages. Remove the receiver from its     superclass' subclass list."    methodDict _ MethodDictionary new.    superclass == nil ifFalse: [superclass removeSubclass: self]! !!Behavior methodsFor: 'accessing' stamp: 'sw 3/10/97'!confirmRemovalOf: aSelector    "Determine if it is okay to remove the given selector.  Answer 1 if it should be removed, 2 if it should be removed followed by a senders browse, and 3 if it should not be removed.     9/18/96 sw: made the wording more delicate    : bug fix -- auto select string needs to be first keyword only"    | count aMenu answer caption allCalls |    (count _ (allCalls _ Smalltalk allCallsOn: aSelector) size) > 0        ifTrue:            [aMenu _ PopUpMenu labels: 'Remove itRemove, then browse sendersDon''t remove, but show me those sendersForget it -- do nothing -- sorry I asked'.            caption _ 'This message has ', count printString, ' sender'.            count > 1 ifTrue:                [caption _ caption copyWith: $s].            answer _ aMenu startUpWithCaption: caption.            answer == 3 ifTrue:                [Smalltalk browseMessageList: allCalls                    name: 'Senders of ', aSelector                    autoSelect: aSelector keywords first].            answer == 0 ifTrue: [answer _ 3].  "If user didn't answer, treat it as cancel"            ^ answer min: 3]        ifFalse:            [^ 1]    ! !!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: 'creating class hierarchy'!superclass: aClass     "Change the receiver's superclass to be aClass."    (aClass == nil or: [aClass isKindOf: Behavior])        ifTrue: [superclass _ aClass]        ifFalse: [self error: 'superclass must be a class-describing object']! !!Behavior methodsFor: 'creating method dictionary'!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."    | method selector methodNode |    method _ self        compile: code        notifying: requestor        trailer: #(0 0 0 0)        ifFail: [^nil]        elseSetSelectorAndNode:             [:sel :parseNode | selector _ sel.  methodNode _ parseNode].    method putSource: code asString fromParseNode: methodNode inFile: 2            withPreamble: [:f | f cr; nextPut: $!!; nextChunkPut: 'Behavior method'; cr].    ^selector! !!Behavior methodsFor: 'creating method dictionary'!compress    "Compact the method dictionary of the receiver."    methodDict rehash! !!Behavior methodsFor: 'creating method dictionary'!recompile: selector from: oldClass    "Compile the method associated with selector in the receiver's method dictionary."    | method trailer methodNode |    method _ self compiledMethodAt: selector.    trailer _ (method size - 3 to: method size) collect: [:i | method at: i].    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 addSelector: selector withMethod: (methodNode generate: trailer).! !!Behavior methodsFor: 'instance creation'!new    "Answer a new instance of the receiver (which is a class) with no indexable variables. Fail if the class is indexable."    "Essential Primitive. See Object documentation whatIsAPrimitive."    <primitive: 70>    self isVariable ifTrue: [^ self basicNew: 0].    "space must be low"    Smalltalk signalLowSpace.    ^ self basicNew  "retry if user proceeds"! !!Behavior methodsFor: 'instance creation'!new: anInteger     "Primitive. Answer an instance of the receiver (which is a class) with the     number of indexable variables specified by the argument, anInteger. Fail     if the class is not indexable or if the argument is not a positive Integer.     Essential. See Object documentation whatIsAPrimitive."    <primitive: 71>    (anInteger isInteger and: [anInteger >= 0]) ifTrue: [        "arg okay; space must be low"        Smalltalk signalLowSpace.        ^ self basicNew: anInteger  "retry if user proceeds"    ].    self primitiveFailed! !!Behavior methodsFor: 'accessing class hierarchy'!allSubclassesWithLevelDo: classAndLevelBlock startingLevel: level     "Walk the tree of subclasses, giving the class and its level"    | subclassNames subclass |    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 | (Smalltalk at: name)            allSubclassesWithLevelDo: classAndLevelBlock            startingLevel: level+1]! !!Behavior methodsFor: 'accessing method dictionary'!sourceCodeAt: selector    ^ (methodDict at: selector) getSourceFor: selector in: self! !!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: 'testing method dictionary'!whichSelectorsReferTo: literal special: specialFlag byte: specialByte    "Answer a set of selectors whose methods access the argument as a literal."    | who method |    who _ Set new.    methodDict associationsDo:        [:assn |        method _ assn value.        ((method pointsTo: literal "faster than hasLiteral:") or:                [specialFlag and: [method scanFor: specialByte]])            ifTrue:            [((literal isKindOf: Association) not                or: [method sendsToSuper not                    or: [method literals allButLast includes: literal]])                ifTrue: [who add: assn key]]].    ^who! !!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: 'private'!format: nInstVars variable: isVar words: isWords pointers: isPointers     "Set the format for the receiver (a Class)."    | cClass instSpec sizeHiBits |    self flag: #instSizeChange."Smalltalk browseAllCallsOn: #instSizeChange.Smalltalk browseAllImplementorsOf: #fixedFieldsOf:.Smalltalk browseAllImplementorsOf: #instantiateClass:indexableSize:.""    NOTE: This code supports the backward-compatible extension to 8 bits of instSize.    For now the format word is...        <2 bits=instSize//64><5 bits=cClass><4 bits=instSpec><6 bits=instSize\\64><1 bit=0>    But when we revise the image format, it should become...        <5 bits=cClass><4 bits=instSpec><8 bits=instSize><1 bit=0>"    sizeHiBits _ (nInstVars+1) // 64.    cClass _ 0.  "for now"    instSpec _ isPointers        ifTrue: [isVar                ifTrue: [nInstVars>0 ifTrue: [3] ifFalse: [2]]                ifFalse: [nInstVars>0 ifTrue: [1] ifFalse: [0]]]        ifFalse: [isWords ifTrue: [6] ifFalse: [8]].    format _ sizeHiBits.    format _ (format bitShift: 5) + cClass.    format _ (format bitShift: 4) + instSpec.    format _ (format bitShift: 6) + ((nInstVars+1)\\64).  "+1 since prim size field includes header"    format _ (format bitShift: 1) "This shift plus integer bit lets wordSize work like byteSize"! !BitBlt comment:'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.  Sum of color components    22    rgbDiff: sourceWord with: destinationWord.  Sum of abs of differences in components    23    tallyIntoMap: destinationWord    24    alphaBlend: sourceWord with: destinationWord    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)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 word array (ie Bitmap) with 2^n elements, where n is the pixel depth of the source.  For every source pixel, BitBlt will then index this array, 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: 'accessing'!colorMap    ^ colorMap! !!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'!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'!fillColor    ^ halftoneForm! !!BitBlt methodsFor: 'accessing'!sourceForm    ^ sourceForm! !!BitBlt methodsFor: 'copying'!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"    <primitive: 96>    "Check for unimplmented rules"    combinationRule = Form oldPaint ifTrue: [^ self paintBits].    combinationRule = Form oldErase1bitShape ifTrue: [^ self eraseBits].    self halt: 'Bad BitBlt arg (Fraction?); proceed to convert.'.    "Convert all numeric parameters to integers and try again."    destX _ destX asInteger.    destY _ destY asInteger.    width _ width asInteger.    height _ height asInteger.    sourceX _ sourceX asInteger.    sourceY _ sourceY asInteger.    clipX _ clipX asInteger.    clipY _ clipY asInteger.    clipWidth _ clipWidth asInteger.    clipHeight _ clipHeight asInteger.    ^ self copyBitsAgain! !!BitBlt methodsFor: 'copying' stamp: 'di 7/17/97 10:04'!copyForm: srcForm to: destPt rule: rule    ^ self copyForm: srcForm to: destPt rule: rule        colorMap: (srcForm colormapIfNeededForDepth: destForm depth)! !!BitBlt methodsFor: 'copying' stamp: 'di 7/17/97 10:04'!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: 'di 7/1/97 14:09'!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 colormapIfNeededForDepth: destForm depth.    self copyBits! !!BitBlt methodsFor: 'copying'!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 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: '6/8/97 15:41 di'!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."    | offset point1 point2 forwards |    "Always draw down, or at least left-to-right"    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: [forwards  "ie this is stopPoint"])        ifTrue: [self copyBits].! !!BitBlt methodsFor: 'line drawing'!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 |    <primitive: 104>    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: 'private'!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: 16rFFFFFFFF).    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'!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.    colorMap _ sourceForm colormapIfNeededForDepth: destForm depth.! !!BitBlt class methodsFor: 'examples'!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"    | brush buff dispToBuff buffToDisplay mapDto32 map32toD prevP p brushToBuff theta buffRect buffSize buffToBuff brushRect delta newBuffRect updateRect |      "compute color maps if needed"    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 farFrom: prevP by: 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: 'di 6/23/97 12:05'!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"    | brush buff dispToBuff buffToDisplay mapDto32 map32toD prevP p brushToBuff theta buffRect buffSize buffToBuff brushRect delta newBuffRect updateRect scale p0 |      "compute color maps if needed"    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)  "From Display to buff - magnify by 2"        sourceForm: Display;        colorMap: mapDto32;        combinationRule: Form over.    brushToBuff _ (BitBlt toForm: buff)  "From brush to buff"        sourceForm: brush;        sourceOrigin: 0@0;        combinationRule: Form blend.    buffToDisplay _ (WarpBlt toForm: Display)  "From buff to Display - shrink by 2"        sourceForm: buff;        colorMap: map32toD;        cellSize: scale;  "...and use smoothing"        combinationRule: Form over.    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 farFrom: prevP by: 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'!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)."    | path |    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: Color black]    "BitBlt exampleOne"! !!BitBlt class methodsFor: 'private'!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."    | 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: Form over fillColor: Display gray"! !BitBltSimulation comment:'This class implements BitBlt, much as specified in the Blue Book spec.Performance has been enhanced through the use of pointer variables such as sourceIndex and destIndex, and by separating several special cases of the inner loop.Operation has been extended to color, with support for 1, 2, 4, 8, 16, and 32-bit pixel sizes.  Conversion between different pixel sizes is facilitated by accepting an optional color map.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: destinationWordThis implementation has also been fitted with an experimental "warp drive" that allows abritrary scaling and rotation (and even limited affine deformations) with all BitBlt storage modes supported.'!!BitBltSimulation methodsFor: 'interpreter interface'!drawLoopX: xDelta Y: yDelta     "This is the primitive implementation of the line-drawing loop.    See the comments in BitBlt>>drawLoopX:Y:"    | dx1 dy1 px py P affL affR affT affB |    xDelta > 0        ifTrue: [dx1 _ 1]        ifFalse: [xDelta = 0                ifTrue: [dx1 _ 0]                ifFalse: [dx1 _ -1]].    yDelta > 0        ifTrue: [dy1 _ 1]        ifFalse: [yDelta = 0                ifTrue: [dy1 _ 0]                ifFalse: [dy1 _ -1]].    px _ yDelta abs.    py _ xDelta abs.    affL _ affT _ 9999.  "init null rectangle"    affR _ affB _ -9999.    py > px        ifTrue:             ["more horizontal"            P _ py // 2.            1 to: py do:                 [:i |                destX _ destX + dx1.                (P _ P - px) < 0 ifTrue:                     [destY _ destY + dy1.                    P _ P + py].                i < py ifTrue:                    [self copyBits.                    (affectedL < affectedR and: [affectedT < affectedB]) ifTrue:                        ["Affected rectangle grows along the line"                        affL _ affL min: affectedL.                        affR _ affR max: affectedR.                        affT _ affT min: affectedT.                        affB _ affB max: affectedB.                        (affR - affL) * (affB - affT) > 4000 ifTrue:                            ["If affected rectangle gets large, update it in chunks"                            affectedL _ affL.  affectedR _ affR.                            affectedT _ affT.  affectedB _ affB.                            interpreterProxy showDisplayBits.                            affL _ affT _ 9999.  "init null rectangle"                            affR _ affB _ -9999]].                    ]]]        ifFalse:             ["more vertical"            P _ px // 2.            1 to: px do:                [:i |                destY _ destY + dy1.                (P _ P - py) < 0 ifTrue:                     [destX _ destX + dx1.                    P _ P + px].                i < px ifTrue:                    [self copyBits.                    (affectedL < affectedR and: [affectedT < affectedB]) ifTrue:                        ["Affected rectangle grows along the line"                        affL _ affL min: affectedL.                        affR _ affR max: affectedR.                        affT _ affT min: affectedT.                        affB _ affB max: affectedB.                        (affR - affL) * (affB - affT) > 4000 ifTrue:                            ["If affected rectangle gets large, update it in chunks"                            affectedL _ affL.  affectedR _ affR.                            affectedT _ affT.  affectedB _ affB.                            interpreterProxy showDisplayBits.                            affL _ affT _ 9999.  "init null rectangle"                            affR _ affB _ -9999]].                    ]]].    "Remaining affected rect"    affectedL _ affL.  affectedR _ affR.    affectedT _ affT.  affectedB _ affB.    "store destX, Y back"        interpreterProxy storeInteger: BBDestXIndex ofObject: bitBltOop withValue: destX.    interpreterProxy storeInteger: BBDestYIndex ofObject: bitBltOop withValue: destY.! !!BitBltSimulation methodsFor: 'interpreter interface'!loadBitBltFrom: bbObj    "Load context from BitBlt instance.  Return false if anything is amiss"    "NOTE this should all be changed to minX/maxX coordinates for simpler clipping        -- once it works!!"    | destBitsSize destWidth destHeight sourceBitsSize sourcePixPerWord cmSize halftoneBits |    bitBltOop _ bbObj.    combinationRule _ interpreterProxy fetchInteger: BBRuleIndex ofObject: bitBltOop.    (interpreterProxy failed        or: [combinationRule < 0 or: [combinationRule > 29]])         ifTrue: [^ false  "operation out of range"].    (combinationRule >= 16 and: [combinationRule <= 17])         ifTrue: [^ false  "fail for old simulated paint, erase modes"].    sourceForm _ interpreterProxy fetchPointer: BBSourceFormIndex ofObject: bitBltOop.    noSource _ self ignoreSourceOrHalftone: sourceForm.    halftoneForm _ interpreterProxy fetchPointer: BBHalftoneFormIndex ofObject: bitBltOop.    noHalftone _ self ignoreSourceOrHalftone: halftoneForm.    destForm _ interpreterProxy fetchPointer: BBDestFormIndex ofObject: bitBltOop.        ((interpreterProxy isPointers: destForm) and: [(interpreterProxy lengthOf: destForm) >= 4])            ifFalse: [^ false].        destBits _ interpreterProxy fetchPointer: FormBitsIndex ofObject: destForm.        destBitsSize _ interpreterProxy byteLengthOf: destBits.        destWidth _ interpreterProxy fetchInteger: FormWidthIndex ofObject: destForm.        destHeight _ interpreterProxy fetchInteger: FormHeightIndex ofObject: destForm.        (destWidth >= 0 and: [destHeight >= 0])            ifFalse: [^ false].        destPixSize _ interpreterProxy fetchInteger: FormDepthIndex ofObject: destForm.        pixPerWord _ 32 // destPixSize.        destRaster _ destWidth + (pixPerWord-1) // pixPerWord.        ((interpreterProxy isWordsOrBytes: destBits)            and: [destBitsSize = (destRaster * destHeight * 4)])            ifFalse: [^ false].        destX _ interpreterProxy fetchIntegerOrTruncFloat: BBDestXIndex ofObject: bitBltOop.    destY _ interpreterProxy fetchIntegerOrTruncFloat: BBDestYIndex ofObject: bitBltOop.    width _ interpreterProxy fetchIntegerOrTruncFloat: BBWidthIndex ofObject: bitBltOop.    height _ interpreterProxy fetchIntegerOrTruncFloat: BBHeightIndex ofObject: bitBltOop.        interpreterProxy failed ifTrue: [^ false  "non-integer value"].    noSource ifTrue:        [sourceX _ sourceY _ 0]        ifFalse:         [((interpreterProxy isPointers: sourceForm) and: [(interpreterProxy lengthOf: sourceForm) >= 4])            ifFalse: [^ false].        sourceBits _ interpreterProxy fetchPointer: FormBitsIndex ofObject: sourceForm.        sourceBitsSize _ interpreterProxy byteLengthOf: sourceBits.        srcWidth _ interpreterProxy fetchIntegerOrTruncFloat: FormWidthIndex ofObject: sourceForm.        srcHeight _ interpreterProxy fetchIntegerOrTruncFloat: FormHeightIndex ofObject: sourceForm.        (srcWidth >= 0 and: [srcHeight >= 0])            ifFalse: [^ false].        sourcePixSize _ interpreterProxy fetchInteger: FormDepthIndex ofObject: sourceForm.        sourcePixPerWord _ 32 // sourcePixSize.        sourceRaster _ srcWidth + (sourcePixPerWord-1) // sourcePixPerWord.        ((interpreterProxy isWordsOrBytes: sourceBits)            and: [sourceBitsSize = (sourceRaster * srcHeight * 4)])            ifFalse: [^ false].        colorMap _ interpreterProxy fetchPointer: BBColorMapIndex ofObject: bitBltOop.        "ColorMap, if not nil, must be longWords, and         2^N long, where N = sourcePixSize for 1, 2, 4, 8 bits,         or N = 9, 12, or 15 (3, 4, 5 bits per color) for 16 or 32 bits."        colorMap = interpreterProxy nilObject ifFalse:            [(interpreterProxy isWords: colorMap)            ifTrue:            [cmSize _ interpreterProxy lengthOf: colorMap.            cmBitsPerColor _ 0.            cmSize = 512 ifTrue: [cmBitsPerColor _ 3].            cmSize = 4096 ifTrue: [cmBitsPerColor _ 4].            cmSize = 32768 ifTrue: [cmBitsPerColor _ 5].            interpreterProxy primIndex ~= 147 ifTrue:                ["WarpBlt has different checks on the color map"                sourcePixSize <= 8                ifTrue: [cmSize = (1 << sourcePixSize) ifFalse: [^ false] ]                ifFalse: [cmBitsPerColor = 0 ifTrue: [^ false] ]]            ]            ifFalse: [^ false]].        sourceX _ interpreterProxy fetchIntegerOrTruncFloat: BBSourceXIndex ofObject: bitBltOop.        sourceY _ interpreterProxy fetchIntegerOrTruncFloat: BBSourceYIndex ofObject: bitBltOop].    noHalftone ifFalse:         [((interpreterProxy isPointers: halftoneForm) and: [(interpreterProxy lengthOf: halftoneForm) >= 4])        ifTrue:        ["Old-style 32xN monochrome halftone Forms"        halftoneBits _ interpreterProxy fetchPointer: FormBitsIndex ofObject: halftoneForm.        halftoneHeight _ interpreterProxy fetchInteger: FormHeightIndex ofObject: halftoneForm.        (interpreterProxy isWords: halftoneBits)            ifFalse: [noHalftone _ true]]        ifFalse:        ["New spec accepts, basically, a word array"        ((interpreterProxy isPointers: halftoneForm) not            and: [interpreterProxy isWords: halftoneForm])            ifFalse: [^ false].        halftoneBits _ halftoneForm.        halftoneHeight _ interpreterProxy lengthOf: halftoneBits].    halftoneBase _ halftoneBits + 4].    clipX _ interpreterProxy fetchIntegerOrTruncFloat: BBClipXIndex ofObject: bitBltOop.    clipY _ interpreterProxy fetchIntegerOrTruncFloat: BBClipYIndex ofObject: bitBltOop.    clipWidth _ interpreterProxy fetchIntegerOrTruncFloat: BBClipWidthIndex ofObject: bitBltOop.    clipHeight _ interpreterProxy fetchIntegerOrTruncFloat: BBClipHeightIndex ofObject: bitBltOop.        interpreterProxy failed ifTrue: [^ false  "non-integer value"].    clipX < 0 ifTrue: [clipWidth _ clipWidth + clipX.  clipX _ 0].    clipY < 0 ifTrue: [clipHeight _ clipHeight + clipY.  clipY _ 0].    clipX+clipWidth > destWidth ifTrue: [clipWidth _ destWidth - clipX].    clipY+clipHeight > destHeight ifTrue: [clipHeight _ destHeight - clipY].    ^ true! !!BitBltSimulation methodsFor: 'interpreter interface'!loadScannerFrom: bbObj    start: start stop: stop string: string rightX: rightX    stopArray: stopArray displayFlag: displayFlag    self inline: false.    "Load arguments and Scanner state"    scanStart _ start.    scanStop _ stop.    scanString _ string.    scanRightX _ rightX.    scanStopArray _ stopArray.    scanDisplayFlag _ displayFlag.    interpreterProxy success: (        (interpreterProxy isPointers: scanStopArray)            and: [(interpreterProxy lengthOf: scanStopArray) >= 1]).    scanXTable _ interpreterProxy fetchPointer: BBXTableIndex ofObject: bbObj.    interpreterProxy success: (        (interpreterProxy isPointers: scanXTable)            and: [(interpreterProxy lengthOf: scanXTable) >= 1]).    "width and sourceX may not be set..."    interpreterProxy storeInteger: BBWidthIndex ofObject: bbObj withValue: 0.    interpreterProxy storeInteger: BBSourceXIndex ofObject: bbObj withValue: 0.    "Now load BitBlt state if displaying"    scanDisplayFlag        ifTrue: [interpreterProxy success: (self loadBitBltFrom: bbObj)]        ifFalse: [bitBltOop _ bbObj.                destX _ interpreterProxy fetchIntegerOrTruncFloat: BBDestXIndex ofObject: bbObj].    ^interpreterProxy failed not! !!BitBltSimulation methodsFor: 'interpreter interface'!scanCharacters    | left top lastIndex charVal ascii sourceX2 nextDestX |    scanDisplayFlag ifTrue:        [self clipRange.  "Need to get true x, y for affectedRectangle"        left _ dx.        top _ dy].    lastIndex _ scanStart.    [lastIndex <= scanStop]        whileTrue: [            charVal _ interpreterProxy stObject: scanString at: lastIndex.            ascii _ interpreterProxy integerValueOf: charVal.            interpreterProxy failed ifTrue: [^ nil].            stopCode _ interpreterProxy stObject: scanStopArray at: ascii + 1.            interpreterProxy failed ifTrue: [^ nil].            stopCode = interpreterProxy nilObject                ifFalse: [^ self returnAt: ascii + 1                             lastIndex: lastIndex                                  left: left                                  top: top].            sourceX _ interpreterProxy stObject: scanXTable at: ascii + 1.            sourceX2 _ interpreterProxy stObject: scanXTable at: ascii + 2.            interpreterProxy failed ifTrue: [^ nil].            (interpreterProxy isIntegerObject: sourceX) & (interpreterProxy isIntegerObject: sourceX2)                ifTrue: [sourceX _ interpreterProxy integerValueOf: sourceX.                        sourceX2 _ interpreterProxy integerValueOf: sourceX2]                ifFalse: [interpreterProxy primitiveFail. ^ nil].            nextDestX _ destX + (width _ sourceX2 - sourceX).            nextDestX > scanRightX                ifTrue: [^ self returnAt: CrossedX                             lastIndex: lastIndex                                  left: left                                  top: top].            scanDisplayFlag ifTrue: [self copyBits].            destX _ nextDestX.            interpreterProxy storeInteger: BBDestXIndex ofObject: bitBltOop withValue: destX.            lastIndex _ lastIndex + 1].    self returnAt: EndOfRun         lastIndex: scanStop              left: left              top: top! !!BitBltSimulation methodsFor: 'interpreter interface'!setInterpreter: anInterpreter    "Interface for InterpreterSimulator. Allows BitBltSimulation object to send messages to the interpreter. The translator will replace sends to 'interpreterProxy' with sends to self, as if BitBltSimulation were part of the interpreter."    interpreterProxy _ anInterpreter.! !!BitBltSimulation methodsFor: 'accessing'!affectedBottom    ^affectedB! !!BitBltSimulation methodsFor: 'accessing'!affectedLeft    ^affectedL! !!BitBltSimulation methodsFor: 'accessing'!affectedRight    ^affectedR! !!BitBltSimulation methodsFor: 'accessing'!affectedTop    ^affectedT! !!BitBltSimulation methodsFor: 'accessing'!stopReason    ^stopCode! !!BitBltSimulation methodsFor: 'accessing'!targetForm    "Return the destination form of a copyBits or scanCharacters operation."    ^destForm! !!BitBltSimulation methodsFor: 'setup'!checkSourceOverlap    | t |    "check for possible overlap of source and destination"    (sourceForm = destForm and: [dy >= sy]) ifTrue:        [dy > sy ifTrue:            ["have to start at bottom"            vDir _ -1.            sy _ sy + bbH - 1.            dy _ dy + bbH - 1]        ifFalse:            [dx > sx ifTrue:                ["y's are equal, but x's are backward"                hDir _ -1.                sx _ sx + bbW - 1.                "start at right"                dx _ dx + bbW - 1.                "and fix up masks"                nWords > 1 ifTrue:                     [t _ mask1.                    mask1 _ mask2.                    mask2 _ t]]].        "Dest inits may be affected by this change"        destIndex _ (destBits + 4) + (dy * destRaster + (dx // pixPerWord) *4).        destDelta _ 4 * ((destRaster * vDir) - (nWords * hDir))]! !!BitBltSimulation methodsFor: 'setup'!clipRange    "clip and adjust source origin and extent appropriately"    "first in x"    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))].    noSource ifTrue: [^ nil].    sx < 0        ifTrue: [dx _ dx - sx.                bbW _ bbW + sx.                sx _ 0].    sx + bbW > srcWidth        ifTrue: [bbW _ bbW - (sx + bbW - srcWidth)].    sy < 0        ifTrue: [dy _ dy - sy.                bbH _ bbH + sy.                sy _ 0].    sy + bbH > srcHeight        ifTrue: [bbH _ bbH - (sy + bbH - srcHeight)]! !!BitBltSimulation methodsFor: 'setup'!copyBits    self clipRange.    (bbW <= 0 or: [bbH <= 0]) ifTrue:        ["zero width or height; noop"        affectedL _ affectedR _ affectedT _ affectedB _ 0.        ^ nil].     self destMaskAndPointerInit.    bitCount _ 0.    noSource        ifTrue: [self copyLoopNoSource]        ifFalse: [self checkSourceOverlap.                (sourcePixSize ~= destPixSize                    or: [colorMap ~= interpreterProxy nilObject])                    ifTrue: [self copyLoopPixMap]                    ifFalse: [self sourceSkewAndPointerInit.                            self copyLoop]].     combinationRule = 22 ifTrue:        ["zero width and height; return the count"        affectedL _ affectedR _ affectedT _ affectedB _ 0.        interpreterProxy pop: 1.        ^ interpreterProxy pushInteger: bitCount].     hDir > 0        ifTrue: [affectedL _ dx.                affectedR _ dx + bbW]        ifFalse: [affectedL _ dx - bbW + 1.                affectedR _ dx + 1].    vDir > 0        ifTrue: [affectedT _ dy.                affectedB _ dy + bbH]        ifFalse: [affectedT _ dy - bbH + 1.                affectedB _ dy + 1]! !!BitBltSimulation methodsFor: 'setup'!destMaskAndPointerInit    "Compute masks for left and right destination words"    | startBits pixPerM1 endBits |    pixPerM1 _ pixPerWord - 1.  "A mask, assuming power of two"    "how many pixels in first word"    startBits _ pixPerWord - (dx bitAnd: pixPerM1).    mask1 _ AllOnes >> (32 - (startBits*destPixSize)).    "how many pixels in last word"    endBits _ ((dx + bbW - 1) bitAnd: pixPerM1) + 1.    mask2 _ AllOnes << (32 - (endBits*destPixSize)).    "determine number of words stored per line; merge masks if only 1"    bbW < startBits        ifTrue: [mask1 _ mask1 bitAnd: mask2.                mask2 _ 0.                nWords _ 1]        ifFalse: [nWords _ (bbW - startBits) + pixPerM1 // pixPerWord + 1].    hDir _ vDir _ 1. "defaults for no overlap with source"    "calculate byte addr and delta, based on first word of data"    "Note raster and nwords are longs, not bytes"    destIndex _ (destBits + 4) + (dy * destRaster + (dx // pixPerWord) *4).    destDelta _ 4 * ((destRaster * vDir) - (nWords * hDir)).  "byte addr delta"! !!BitBltSimulation methodsFor: 'setup'!ignoreSourceOrHalftone: formPointer    formPointer = interpreterProxy nilObject ifTrue: [ ^true ].    combinationRule = 0 ifTrue: [ ^true ].    combinationRule = 5 ifTrue: [ ^true ].    combinationRule = 10 ifTrue: [ ^true ].    combinationRule = 15 ifTrue: [ ^true ].    ^false! !!BitBltSimulation methodsFor: 'setup'!returnAt: stopIndex lastIndex: lastIndex left: left top: top    stopCode _ interpreterProxy stObject: scanStopArray at: stopIndex.    interpreterProxy failed ifTrue: [^ nil].    interpreterProxy storeInteger: BBLastIndex ofObject: bitBltOop withValue: lastIndex.    scanDisplayFlag ifTrue: [        "Now we know extent of affected rectangle"        affectedL _ left.        affectedR _ bbW + dx.        affectedT _ top.        affectedB _ bbH + dy.    ].! !!BitBltSimulation methodsFor: 'setup'!sourceSkewAndPointerInit    "This is only used when source and dest are same depth,    ie, when the barrel-shift copy loop is used."    | dWid sxLowBits dxLowBits pixPerM1 |    pixPerM1 _ pixPerWord - 1.  "A mask, assuming power of two"    sxLowBits _ sx bitAnd: pixPerM1.    dxLowBits _ dx bitAnd: pixPerM1.    "check if need to preload buffer    (i.e., two words of source needed for first word of destination)"    hDir > 0 ifTrue:        ["n Bits stored in 1st word of dest"        dWid _ bbW min: pixPerWord - dxLowBits.        preload _ (sxLowBits + dWid) > pixPerM1]    ifFalse:        [dWid _ bbW min: dxLowBits + 1.        preload _ (sxLowBits - dWid + 1) < 0].    "calculate right-shift skew from source to dest"    skew _ (sxLowBits - dxLowBits) * destPixSize.  " -32..32 "    preload ifTrue:         [skew < 0            ifTrue: [skew _ skew+32]            ifFalse: [skew _ skew-32]].    "Calc byte addr and delta from longWord info"    sourceIndex _ (sourceBits + 4) + (sy * sourceRaster + (sx // (32//sourcePixSize)) *4).    "calculate increments from end of 1 line to start of next"    sourceDelta _ 4 * ((sourceRaster * vDir) - (nWords * hDir)).    preload ifTrue:        ["Compensate for extra source word fetched"        sourceDelta _ sourceDelta - (4*hDir)].! !!BitBltSimulation methodsFor: 'setup'!warpBits    | ns |    ns _ noSource.  noSource _ true.        self clipRange.  "noSource suppresses sourceRect clipping"        noSource _ ns.    (noSource or: [bbW <= 0 or: [bbH <= 0]]) ifTrue:        ["zero width or height; noop"        affectedL _ affectedR _ affectedT _ affectedB _ 0.        ^ nil].     self destMaskAndPointerInit.    self warpLoop.     hDir > 0        ifTrue: [affectedL _ dx.                affectedR _ dx + bbW]        ifFalse: [affectedL _ dx - bbW + 1.                affectedR _ dx + 1].    vDir > 0        ifTrue: [affectedT _ dy.                affectedB _ dy + bbH]        ifFalse: [affectedT _ dy - bbH + 1.                affectedB _ dy + 1]! !!BitBltSimulation methodsFor: 'inner loop'!copyLoop     | prevWord thisWord skewWord halftoneWord mergeWord hInc y unskew skewMask notSkewMask |    "This version of the inner loop assumes noSource = false."    self inline: false.    hInc _ hDir*4.  "Byte delta"    "degenerate skew fixed for Sparc. 10/20/96 ikp"    skew == -32        ifTrue: [skew _ unskew _ skewMask _ 0]        ifFalse: [skew < 0            ifTrue:                [unskew _ skew+32.                skewMask _ AllOnes << (0-skew)]            ifFalse:                [skew == 0                    ifTrue:                        [unskew _ 0.                        skewMask _ AllOnes]                    ifFalse:                        [unskew _ skew-32.                        skewMask _ AllOnes >> skew]]].    notSkewMask _ skewMask bitInvert32.    noHalftone        ifTrue: [halftoneWord _ AllOnes.  halftoneHeight _ 0]        ifFalse: [halftoneWord _ interpreterProxy longAt: halftoneBase].    y _ dy.    1 to: bbH do: "here is the vertical loop"        [ :i |        halftoneHeight > 1 ifTrue:  "Otherwise, its always the same"            [halftoneWord _ interpreterProxy longAt:                        (halftoneBase + (y \\ halftoneHeight * 4)).            y _ y + vDir].        preload ifTrue:            ["load the 64-bit shifter"            prevWord _ interpreterProxy longAt: sourceIndex.            sourceIndex _ sourceIndex + hInc]            ifFalse:            [prevWord _ 0].    "Note: the horizontal loop has been expanded into three parts for speed:"            "This first section requires masking of the destination store..."            thisWord _ interpreterProxy longAt: sourceIndex.  "pick up next word"            skewWord _ ((prevWord bitAnd: notSkewMask) bitShift: unskew)                            bitOr:  "32-bit rotate"                        ((thisWord bitAnd: skewMask) bitShift: skew).            prevWord _ thisWord.            sourceIndex _ sourceIndex + hInc.            mergeWord _ self merge: (skewWord bitAnd: halftoneWord)                                with: (interpreterProxy longAt: destIndex).            interpreterProxy longAt: destIndex                put: ((mask1 bitAnd: mergeWord)                    bitOr: (mask1 bitInvert32 bitAnd: (interpreterProxy longAt: destIndex))).            destIndex _ destIndex + hInc.        "This central horizontal loop requires no store masking"combinationRule = 3ifTrue: [2 to: nWords-1 do: "Special inner loop for STORE"            [ :word |            thisWord _ interpreterProxy longAt: sourceIndex.  "pick up next word"            skewWord _ ((prevWord bitAnd: notSkewMask) bitShift: unskew)                            bitOr:  "32-bit rotate"                        ((thisWord bitAnd: skewMask) bitShift: skew).            prevWord _ thisWord.            sourceIndex _ sourceIndex + hInc.            interpreterProxy longAt: destIndex put: (skewWord bitAnd: halftoneWord).            destIndex _ destIndex + hInc]] ifFalse: [2 to: nWords-1 do: "Normal inner loop does merge:"            [ :word |            thisWord _ interpreterProxy longAt: sourceIndex.  "pick up next word"            skewWord _ ((prevWord bitAnd: notSkewMask) bitShift: unskew)                            bitOr:  "32-bit rotate"                        ((thisWord bitAnd: skewMask) bitShift: skew).            prevWord _ thisWord.            sourceIndex _ sourceIndex + hInc.            mergeWord _ self merge: (skewWord bitAnd: halftoneWord)                                with: (interpreterProxy longAt: destIndex).            interpreterProxy longAt: destIndex put: mergeWord.            destIndex _ destIndex + hInc]].        "This last section, if used, requires masking of the destination store..."        nWords > 1 ifTrue:            [thisWord _ interpreterProxy longAt: sourceIndex.  "pick up next word"            skewWord _ ((prevWord bitAnd: notSkewMask) bitShift: unskew)                            bitOr:  "32-bit rotate"                        ((thisWord bitAnd: skewMask) bitShift: skew).            prevWord _ thisWord.            sourceIndex _ sourceIndex + hInc.            mergeWord _ self merge: (skewWord bitAnd: halftoneWord)                                with: (interpreterProxy longAt: destIndex).            interpreterProxy longAt: destIndex                put: ((mask2 bitAnd: mergeWord)                    bitOr: (mask2 bitInvert32 bitAnd: (interpreterProxy longAt: destIndex))).            destIndex _ destIndex + hInc].    sourceIndex _ sourceIndex + sourceDelta.    destIndex _ destIndex + destDelta]! !!BitBltSimulation methodsFor: 'inner loop'!copyLoopNoSource    | halftoneWord mergeWord |    "Faster copyLoop when source not used.  hDir and vDir are both    positive, and perload and skew are unused"    self inline: false.    1 to: bbH do: "here is the vertical loop"        [ :i |        noHalftone            ifTrue: [halftoneWord _ AllOnes]            ifFalse: [halftoneWord _ interpreterProxy longAt: (halftoneBase + (dy+i-1 \\ halftoneHeight * 4))].    "Note: the horizontal loop has been expanded into three parts for speed:"            "This first section requires masking of the destination store..."            mergeWord _ self merge: halftoneWord with: (interpreterProxy longAt: destIndex).            interpreterProxy longAt: destIndex                put: ((mask1 bitAnd: mergeWord)                    bitOr: (mask1 bitInvert32 bitAnd: (interpreterProxy longAt: destIndex))).            destIndex _ destIndex + 4.        "This central horizontal loop requires no store masking"combinationRule = 3ifTrue: [2 to: nWords-1 do: "Special inner loop for STORE"            [ :word |            interpreterProxy longAt: destIndex put: halftoneWord.            destIndex _ destIndex + 4].] ifFalse: [2 to: nWords-1 do: "Normal inner loop does merge"            [ :word |            mergeWord _ self merge: halftoneWord with: (interpreterProxy longAt: destIndex).            interpreterProxy longAt: destIndex put: mergeWord.            destIndex _ destIndex + 4].].        "This last section, if used, requires masking of the destination store..."        nWords > 1 ifTrue:            [mergeWord _ self merge: halftoneWord with: (interpreterProxy longAt: destIndex).            interpreterProxy longAt: destIndex                put: ((mask2 bitAnd: mergeWord)                    bitOr: (mask2 bitInvert32 bitAnd: (interpreterProxy longAt: destIndex))).            destIndex _ destIndex + 4].    destIndex _ destIndex + destDelta]! !!BitBltSimulation methodsFor: 'inner loop' stamp: 'di 6/23/97 15:07'!copyLoopPixMap    "This version of the inner loop maps source pixels    to a destination form with different depth.  Because it is already    unweildy, the loop is not unrolled as in the other versions.    Preload, skew and skewMask are all overlooked, since pickSourcePixels    delivers its destination word already properly aligned.    Note that pickSourcePixels could be copied in-line at the top of    the horizontal loop, and some of its inits moved out of the loop."    | skewWord halftoneWord mergeWord destMask srcPixPerWord scrStartBits nSourceIncs startBits endBits sourcePixMask destPixMask nullMap |    self inline: false.    "Additional inits peculiar to unequal source and dest pix size..."    srcPixPerWord _ 32//sourcePixSize.    "Check for degenerate shift values 4/28/97 ar"    sourcePixSize = 32         ifTrue: [ sourcePixMask _ -1]        ifFalse: [ sourcePixMask _ (1 << sourcePixSize) - 1].    destPixSize = 32        ifTrue: [ destPixMask _ -1]        ifFalse: [ destPixMask _ (1 << destPixSize) - 1].    nullMap _ colorMap = interpreterProxy nilObject.    sourceIndex _ (sourceBits + 4) +                    (sy * sourceRaster + (sx // srcPixPerWord) *4).    scrStartBits _ srcPixPerWord - (sx bitAnd: srcPixPerWord-1).    bbW < scrStartBits        ifTrue: [nSourceIncs _ 0]        ifFalse: [nSourceIncs _ (bbW - scrStartBits)//srcPixPerWord + 1].    sourceDelta _ (sourceRaster - nSourceIncs) * 4.    "Note following two items were already calculated in destmask setup!!"    startBits _ pixPerWord - (dx bitAnd: pixPerWord-1).    endBits _ ((dx + bbW - 1) bitAnd: pixPerWord-1) + 1.    1 to: bbH do: "here is the vertical loop"        [ :i |        noHalftone            ifTrue: [halftoneWord _ AllOnes]            ifFalse: [halftoneWord _ interpreterProxy longAt: (halftoneBase + (dy+i-1 \\ halftoneHeight * 4))].        srcBitIndex _ (sx bitAnd: srcPixPerWord - 1)*sourcePixSize.        destMask _ mask1.        "pick up first word"        bbW < startBits            ifTrue: [skewWord _ self pickSourcePixels: bbW nullMap: nullMap                                    srcMask: sourcePixMask destMask: destPixMask.                    skewWord _ skewWord   "See note below"                            bitShift: (startBits - bbW)*destPixSize]            ifFalse: [skewWord _ self pickSourcePixels: startBits nullMap: nullMap                                    srcMask: sourcePixMask destMask: destPixMask].         "Here is the horizontal loop..."        1 to: nWords do: "here is the inner horizontal loop"            [ :word |            mergeWord _ self merge: (skewWord bitAnd: halftoneWord)                with: ((interpreterProxy longAt: destIndex) bitAnd: destMask).            interpreterProxy longAt: destIndex                put: ((destMask bitAnd: mergeWord)                    bitOr:                    (destMask bitInvert32 bitAnd: (interpreterProxy longAt: destIndex))).            destIndex _ destIndex + 4.            word >= (nWords - 1) ifTrue:                [word = nWords ifFalse:                    ["set mask for last word in this row"                    destMask _ mask2.                    skewWord _ self pickSourcePixels: endBits nullMap: nullMap                                    srcMask: sourcePixMask destMask: destPixMask.                    skewWord _ skewWord   "See note below"                            bitShift: (pixPerWord-endBits)*destPixSize]]                ifFalse:                 ["use fullword mask for inner loop"                destMask _ AllOnes.                skewWord _ self pickSourcePixels: pixPerWord nullMap: nullMap srcMask: sourcePixMask destMask: destPixMask]].    sourceIndex _ sourceIndex + sourceDelta.    destIndex _ destIndex + destDelta]"NOTE: in both noted shifts above, we are shifting the right-justified output of pickSourcePixels so that it is aligned with the destination word.  Since it gets masked anyway, we could have just picked more pixels (startBits in the first case and destPixSize in the second), and it would have been simpler, but it is slower to run the pickSourcePixels loop.  CopyLoopAlphaHack takes advantage of this to avoid having to shift full-words in its alphaSource buffer" ! !!BitBltSimulation methodsFor: 'inner loop'!warpLoop    | skewWord halftoneWord mergeWord destMask startBits      deltaP12x deltaP12y deltaP43x deltaP43y pAx pAy      xDelta yDelta pBx pBy smoothingCount sourceMapOop nSteps t |    "This version of the inner loop traverses an arbirary quadrilateral    source, thus producing a general affine transformation."     (interpreterProxy fetchWordLengthOf: bitBltOop) >= (BBWarpBase+12)        ifFalse: [^ interpreterProxy primitiveFail].    nSteps _ height-1.  nSteps <= 0 ifTrue: [nSteps _ 1].    pAx _ interpreterProxy fetchIntegerOrTruncFloat: BBWarpBase ofObject: bitBltOop.    t _ interpreterProxy fetchIntegerOrTruncFloat: BBWarpBase+3 ofObject: bitBltOop.    deltaP12x _ self deltaFrom: pAx to: t nSteps: nSteps.    deltaP12x < 0 ifTrue: [pAx _ t - (nSteps*deltaP12x)].    pAy _ interpreterProxy fetchIntegerOrTruncFloat: BBWarpBase+1 ofObject: bitBltOop.    t _ interpreterProxy fetchIntegerOrTruncFloat: BBWarpBase+4 ofObject: bitBltOop.    deltaP12y _ self deltaFrom: pAy to: t nSteps: nSteps.    deltaP12y < 0 ifTrue: [pAy _ t - (nSteps*deltaP12y)].    pBx _ interpreterProxy fetchIntegerOrTruncFloat: BBWarpBase+9 ofObject: bitBltOop.    t _ interpreterProxy fetchIntegerOrTruncFloat: BBWarpBase+6 ofObject: bitBltOop.    deltaP43x _ self deltaFrom: pBx to: t nSteps: nSteps.    deltaP43x < 0 ifTrue: [pBx _ t - (nSteps*deltaP43x)].    pBy _ interpreterProxy fetchIntegerOrTruncFloat: BBWarpBase+10 ofObject: bitBltOop.    t _ interpreterProxy fetchIntegerOrTruncFloat: BBWarpBase+7 ofObject: bitBltOop.    deltaP43y _ self deltaFrom: pBy to: t nSteps: nSteps.    deltaP43y < 0 ifTrue: [pBy _ t - (nSteps*deltaP43y)].    interpreterProxy failed ifTrue: [^ false].  "ie if non-integers above"    interpreterProxy argCount = 2        ifTrue: [smoothingCount _ interpreterProxy stackIntegerValue: 1.                sourceMapOop _ interpreterProxy stackValue: 0.                sourceMapOop = interpreterProxy nilObject                ifTrue: [sourcePixSize < 16 ifTrue:                    ["color map is required to smooth non-RGB dest"                    ^ interpreterProxy primitiveFail]]                ifFalse: [(interpreterProxy fetchWordLengthOf: sourceMapOop)                            < (1 << sourcePixSize) ifTrue:                    ["sourceMap must be long enough for sourcePixSize"                    ^ interpreterProxy primitiveFail]]]        ifFalse: [smoothingCount _ 1.                sourceMapOop _ interpreterProxy nilObject].    startBits _ pixPerWord - (dx bitAnd: pixPerWord-1).    nSteps _ width-1.  nSteps <= 0 ifTrue: [nSteps _ 1].     destY to: clipY-1 do:        [ :i |    "Advance increments if there was clipping in y"        pAx _ pAx + deltaP12x.        pAy _ pAy + deltaP12y.        pBx _ pBx + deltaP43x.        pBy _ pBy + deltaP43y].    1 to: bbH do:        [ :i |        "here is the vertical loop..."        xDelta _ self deltaFrom: pAx to: pBx nSteps: nSteps.         xDelta >= 0 ifTrue: [sx _ pAx] ifFalse: [sx _ pBx - (nSteps*xDelta)].        yDelta _ self deltaFrom: pAy to: pBy nSteps: nSteps.         yDelta >= 0 ifTrue: [sy _ pAy] ifFalse: [sy _ pBy - (nSteps*yDelta)].        destX to: clipX-1 do:            [:word |    "Advance increments if there was clipping in x"            sx _ sx + xDelta.            sy _ sy + yDelta].        noHalftone            ifTrue: [halftoneWord _ AllOnes]            ifFalse: [halftoneWord _ interpreterProxy longAt: (halftoneBase + (dy+i-1 \\ halftoneHeight * 4))].        destMask _ mask1.        "pick up first word"        bbW < startBits            ifTrue: [skewWord _ self warpSourcePixels: bbW                                    xDeltah: xDelta yDeltah: yDelta                                    xDeltav: deltaP12x yDeltav: deltaP12y                                    smoothing: smoothingCount sourceMap: sourceMapOop.                    skewWord _ skewWord                            bitShift: (startBits - bbW)*destPixSize]            ifFalse: [skewWord _ self warpSourcePixels: startBits                                    xDeltah: xDelta yDeltah: yDelta                                    xDeltav: deltaP12x yDeltav: deltaP12y                                    smoothing: smoothingCount sourceMap: sourceMapOop].         1 to: nWords do:            [ :word |        "here is the inner horizontal loop..."            mergeWord _ self merge: (skewWord bitAnd: halftoneWord)                with: ((interpreterProxy longAt: destIndex) bitAnd: destMask).            interpreterProxy longAt: destIndex                put: ((destMask bitAnd: mergeWord)                    bitOr:                    (destMask bitInvert32 bitAnd: (interpreterProxy longAt: destIndex))).            destIndex _ destIndex + 4.            word >= (nWords - 1) ifTrue:                [word = nWords ifFalse:                    ["set mask for last word in this row"                    destMask _ mask2.                    skewWord _ self warpSourcePixels: pixPerWord                                    xDeltah: xDelta yDeltah: yDelta                                    xDeltav: deltaP12x yDeltav: deltaP12y                                    smoothing: smoothingCount sourceMap: sourceMapOop]]                ifFalse:                ["use fullword mask for inner loop"                destMask _ AllOnes.                skewWord _ self warpSourcePixels: pixPerWord                                    xDeltah: xDelta yDeltah: yDelta                                    xDeltav: deltaP12x yDeltav: deltaP12y                                    smoothing: smoothingCount sourceMap: sourceMapOop].            ].        pAx _ pAx + deltaP12x.        pAy _ pAy + deltaP12y.        pBx _ pBx + deltaP43x.        pBy _ pBy + deltaP43y.        destIndex _ destIndex + destDelta]! !!BitBltSimulation methodsFor: 'combination rules'!alphaBlend: sourceWord with: destinationWord    "Blend sourceWord with destinationWord, assuming both are 32-bit pixels.    The source is assumed to have 255*alpha in the high 8 bits of each pixel,    while the high 8 bits of the destinationWord will be ignored.    The blend produced is alpha*source + (1-alpha)*dest, with    the computation being performed independently on each color    component.  The high byte of the result will be 0."    | alpha unAlpha colorMask result blend shift |    self inline: false.    alpha _ sourceWord >> 24.  "High 8 bits of source pixel"    unAlpha _ 255 - alpha.    colorMask _ 16rFF.    result _ 0.    1 to: 3 do:        [:i | shift _ (i-1)*8.        blend _ (((sourceWord>>shift bitAnd: colorMask) * alpha)                    + ((destinationWord>>shift bitAnd: colorMask) * unAlpha))                 + 254 // 255 bitAnd: colorMask.        result _ result bitOr: blend<<shift].    ^ result! !!BitBltSimulation methodsFor: 'combination rules' stamp: 'di 6/23/97 22:41'!merge: sourceWord with: destinationWord"    ^ self dispatchOn: combinationRule        with: sourceWord with: destinationWord        in: RuleTable."    self inline: true.    "These are the combination rules..."combinationRule < 16 ifTrue:[combinationRule < 8 ifTrue:    [combinationRule < 4 ifTrue:        [combinationRule < 2 ifTrue:            [combinationRule < 1 ifTrue:                ["0" ^ 0]                ifFalse:                ["1" ^ sourceWord bitAnd: destinationWord]]            ifFalse:            [combinationRule < 3 ifTrue:                ["2" ^ sourceWord bitAnd: destinationWord bitInvert32]                ifFalse:                ["3" ^ sourceWord]]]        ifFalse:        [combinationRule < 6 ifTrue:            [combinationRule < 5 ifTrue:                ["4" ^ sourceWord bitInvert32 bitAnd: destinationWord]                ifFalse:                ["5" ^ destinationWord]]            ifFalse:            [combinationRule < 7 ifTrue:                ["6" ^ sourceWord bitXor: destinationWord]                ifFalse:                ["7" ^ sourceWord bitOr: destinationWord]]]]    ifFalse:    [combinationRule < 12 ifTrue:        [combinationRule < 10 ifTrue:            [combinationRule < 9 ifTrue:                ["8" ^ sourceWord bitInvert32 bitAnd: destinationWord bitInvert32]                ifFalse:                ["9" ^ sourceWord bitInvert32 bitXor: destinationWord]]            ifFalse:            [combinationRule < 11 ifTrue:                ["10" ^ destinationWord bitInvert32]                ifFalse:                ["11" ^ sourceWord bitOr: destinationWord bitInvert32]]]        ifFalse:        [combinationRule < 14 ifTrue:            [combinationRule < 13 ifTrue:                ["12" ^ sourceWord bitInvert32]                ifFalse:                ["13" ^ sourceWord bitInvert32 bitOr: destinationWord]]            ifFalse:            [combinationRule < 15 ifTrue:                ["14" ^ sourceWord bitInvert32 bitOr: destinationWord bitInvert32]                ifFalse:                ["15" ^ destinationWord]]]]]ifFalse:[combinationRule < 24 ifTrue:    [combinationRule < 20 ifTrue:        [combinationRule < 18 ifTrue:            [combinationRule < 17 ifTrue:                ["16" ^ destinationWord "no op"]                ifFalse:                ["17" ^ destinationWord "no op"]]            ifFalse:            [combinationRule < 19 ifTrue:                ["18" ^ sourceWord + destinationWord]                ifFalse:                ["19" ^ sourceWord - destinationWord]]]        ifFalse:        [combinationRule < 22 ifTrue:            [combinationRule < 21 ifTrue:                ["20" ^ self rgbAdd: sourceWord with: destinationWord]                ifFalse:                ["21" ^ self rgbSub: sourceWord with: destinationWord]]            ifFalse:            [combinationRule < 23 ifTrue:                ["22" ^ self rgbDiff: sourceWord with: destinationWord]                ifFalse:                ["23" ^ self tallyIntoMap: destinationWord]]]]    ifFalse:    [combinationRule < 28 ifTrue:        [combinationRule < 26 ifTrue:            [combinationRule < 25 ifTrue:                ["24" ^ self alphaBlend: sourceWord with: destinationWord]                ifFalse:                ["25"  sourceWord = 0 ifTrue: [^ destinationWord].                ^ self pixPaint: sourceWord with: destinationWord]]            ifFalse:            [combinationRule < 27 ifTrue:                ["26" ^ self pixMask: sourceWord with: destinationWord]                ifFalse:                ["27" ^ self rgbMax: sourceWord with: destinationWord]]]        ifFalse:        [combinationRule < 30 ifTrue:            [combinationRule < 29 ifTrue:                ["28" ^ self rgbMin: sourceWord with: destinationWord]                ifFalse:                ["29" ^ self rgbMin: sourceWord bitInvert32 with: destinationWord]]            ifFalse:            [combinationRule < 31 ifTrue:                ["30" ^ destinationWord "no op"]                ifFalse:                ["31" ^ destinationWord "no op"]]]]]! !!BitBltSimulation methodsFor: 'combination rules'!partitionedAdd: word1 to: word2 nBits: nBits nPartitions: nParts    "Add word1 to word2 as nParts partitions of nBits each.    This is useful for packed pixels, or packed colors"    | mask sum result |    mask _ (1 << nBits) - 1.  "partition mask starts at the right"    result _ 0.    1 to: nParts do:        [:i |        sum _ (word1 bitAnd: mask) + (word2 bitAnd: mask).        sum <= mask  "result must not carry out of partition"            ifTrue: [result _ result bitOr: sum]            ifFalse: [result _ result bitOr: mask].        mask _ mask << nBits  "slide left to next partition"].    ^ result! !!BitBltSimulation methodsFor: 'combination rules'!partitionedAND: word1 to: word2 nBits: nBits nPartitions: nParts    "AND word1 to word2 as nParts partitions of nBits each.    Any field of word1 not all-ones is treated as all-zeroes.    Used for erasing, eg, brush shapes prior to ORing in a color"    | mask result |    mask _ (1 << nBits) - 1.  "partition mask starts at the right"    result _ 0.    1 to: nParts do:        [:i |        (word1 bitAnd: mask) = mask            ifTrue: [result _ result bitOr: (word2 bitAnd: mask)].        mask _ mask << nBits  "slide left to next partition"].    ^ result! !!BitBltSimulation methodsFor: 'combination rules'!partitionedMax: word1 with: word2 nBits: nBits nPartitions: nParts    "Max word1 to word2 as nParts partitions of nBits each"    | mask result |    mask _ (1 << nBits) - 1.  "partition mask starts at the right"    result _ 0.    1 to: nParts do:        [:i |        result _ result bitOr: ((word2 bitAnd: mask) max: (word1 bitAnd: mask)).        mask _ mask << nBits  "slide left to next partition"].    ^ result! !!BitBltSimulation methodsFor: 'combination rules'!partitionedMin: word1 with: word2 nBits: nBits nPartitions: nParts    "Min word1 to word2 as nParts partitions of nBits each"    | mask result |    mask _ (1 << nBits) - 1.  "partition mask starts at the right"    result _ 0.    1 to: nParts do:        [:i |        result _ result bitOr: ((word2 bitAnd: mask) min: (word1 bitAnd: mask)).        mask _ mask << nBits  "slide left to next partition"].    ^ result! !!BitBltSimulation methodsFor: 'combination rules'!partitionedSub: word1 from: word2 nBits: nBits nPartitions: nParts    "Subtract word1 from word2 as nParts partitions of nBits each.    This is useful for packed pixels, or packed colors"    | mask result p1 p2 |    mask _ (1 << nBits) - 1.  "partition mask starts at the right"    result _ 0.    1 to: nParts do:        [:i |        p1 _ word1 bitAnd: mask.        p2 _ word2 bitAnd: mask.        p1 < p2  "result is really abs value of thedifference"            ifTrue: [result _ result bitOr: p2 - p1]            ifFalse: [result _ result bitOr: p1 - p2].        mask _ mask << nBits  "slide left to next partition"].    ^ result! !!BitBltSimulation methodsFor: 'combination rules'!pixMask: sourceWord with: destinationWord    self inline: false.    ^ self partitionedAND: sourceWord bitInvert32 to: destinationWord                    nBits: destPixSize nPartitions: pixPerWord! !!BitBltSimulation methodsFor: 'combination rules'!pixPaint: sourceWord with: destinationWord    self inline: false.    ^ sourceWord bitOr:        (self partitionedAND: sourceWord bitInvert32 to: destinationWord                        nBits: destPixSize nPartitions: pixPerWord)! !!BitBltSimulation methodsFor: 'combination rules'!rgbAdd: sourceWord with: destinationWord    self inline: false.    destPixSize < 16 ifTrue:        ["Add each pixel separately"        ^ self partitionedAdd: sourceWord to: destinationWord                        nBits: destPixSize nPartitions: pixPerWord].    destPixSize = 16 ifTrue:        ["Add RGB components of each pixel separately"        ^ (self partitionedAdd: sourceWord to: destinationWord                        nBits: 5 nPartitions: 3)        + ((self partitionedAdd: sourceWord>>16 to: destinationWord>>16                        nBits: 5 nPartitions: 3) << 16)]    ifFalse:        ["Add RGB components of the pixel separately"        ^ self partitionedAdd: sourceWord to: destinationWord                        nBits: 8 nPartitions: 3]! !!BitBltSimulation methodsFor: 'combination rules'!rgbDiff: sourceWord with: destinationWord    "Subract the pixels in the source and destination, color by color,    and return the sum of the absolute value of all the differences.    For non-rgb, XOR the two and return the number of differing pixels.    Note that the region is not clipped to bit boundaries, but only to the    nearest (enclosing) word.  This is because copyLoop does not do    pre-merge masking.  For accurate results, you must subtract the    values obtained from the left and right fringes."    | diff pixMask |    self inline: false.    destPixSize < 16 ifTrue:        ["Just xor and count differing bits if not RGB"        diff _ sourceWord bitXor: destinationWord.        pixMask _ (1 bitShift: destPixSize) - 1.        [diff = 0] whileFalse:            [(diff bitAnd: pixMask) ~= 0 ifTrue: [bitCount _ bitCount + 1].            diff _ diff >> destPixSize].        ^ destinationWord "for no effect"].     destPixSize = 16        ifTrue:        [diff _ (self partitionedSub: sourceWord from: destinationWord                        nBits: 5 nPartitions: 3).        bitCount _ bitCount + (diff bitAnd: 16r1F)                            + (diff>>5 bitAnd: 16r1F)                            + (diff>>10 bitAnd: 16r1F).        diff _ (self partitionedSub: sourceWord>>16 from: destinationWord>>16                        nBits: 5 nPartitions: 3).        bitCount _ bitCount + (diff bitAnd: 16r1F)                            + (diff>>5 bitAnd: 16r1F)                            + (diff>>10 bitAnd: 16r1F)]        ifFalse:        [diff _ (self partitionedSub: sourceWord from: destinationWord                        nBits: 8 nPartitions: 3).        bitCount _ bitCount + (diff bitAnd: 16rFF)                            + (diff>>8 bitAnd: 16rFF)                            + (diff>>16 bitAnd: 16rFF)].    ^ destinationWord  "For no effect on dest"! !!BitBltSimulation methodsFor: 'combination rules'!rgbMax: sourceWord with: destinationWord    self inline: false.    destPixSize < 16 ifTrue:        ["Max each pixel separately"        ^ self partitionedMax: sourceWord with: destinationWord                        nBits: destPixSize nPartitions: pixPerWord].    destPixSize = 16 ifTrue:        ["Max RGB components of each pixel separately"        ^ (self partitionedMax: sourceWord with: destinationWord                        nBits: 5 nPartitions: 3)        + ((self partitionedMax: sourceWord>>16 with: destinationWord>>16                        nBits: 5 nPartitions: 3) << 16)]    ifFalse:        ["Max RGB components of the pixel separately"        ^ self partitionedMax: sourceWord with: destinationWord                        nBits: 8 nPartitions: 3]! !!BitBltSimulation methodsFor: 'combination rules'!rgbMin: sourceWord with: destinationWord    self inline: false.    destPixSize < 16 ifTrue:        ["Min each pixel separately"        ^ self partitionedMin: sourceWord with: destinationWord                        nBits: destPixSize nPartitions: pixPerWord].    destPixSize = 16 ifTrue:        ["Min RGB components of each pixel separately"        ^ (self partitionedMin: sourceWord with: destinationWord                        nBits: 5 nPartitions: 3)        + ((self partitionedMin: sourceWord>>16 with: destinationWord>>16                        nBits: 5 nPartitions: 3) << 16)]    ifFalse:        ["Min RGB components of the pixel separately"        ^ self partitionedMin: sourceWord with: destinationWord                        nBits: 8 nPartitions: 3]! !!BitBltSimulation methodsFor: 'combination rules'!rgbSub: sourceWord with: destinationWord    self inline: false.    destPixSize < 16 ifTrue:        ["Sub each pixel separately"        ^ self partitionedSub: sourceWord from: destinationWord                        nBits: destPixSize nPartitions: pixPerWord].    destPixSize = 16 ifTrue:        ["Sub RGB components of each pixel separately"        ^ (self partitionedSub: sourceWord from: destinationWord                        nBits: 5 nPartitions: 3)        + ((self partitionedSub: sourceWord>>16 from: destinationWord>>16                        nBits: 5 nPartitions: 3) << 16)]    ifFalse:        ["Sub RGB components of the pixel separately"        ^ self partitionedSub: sourceWord from: destinationWord                        nBits: 8 nPartitions: 3]! !!BitBltSimulation methodsFor: 'combination rules' stamp: '6/9/97 20:45 di'!tallyIntoMap: destinationWord    "Tally pixels into the color map.  Note that the source should be     specified = destination, in order for the proper color map checks     to be performed at setup.    Note that the region is not clipped to bit boundaries, but only to the    nearest (enclosing) word.  This is because copyLoop does not do    pre-merge masking.  For accurate results, you must subtract the    values obtained from the left and right fringes."    | mapIndex pixMask shiftWord |    self inline: false.    colorMap = interpreterProxy nilObject        ifTrue: [^ destinationWord "no op"].    destPixSize < 16 ifTrue:        ["loop through all packed pixels."        pixMask _ (1<<destPixSize) - 1.        shiftWord _ destinationWord.        1 to: pixPerWord do:            [:i |            mapIndex _ shiftWord bitAnd: pixMask.            interpreterProxy storeWord: mapIndex ofObject: colorMap                withValue: (interpreterProxy fetchWord: mapIndex ofObject: colorMap) + 1.            shiftWord _ shiftWord >> destPixSize].        ^ destinationWord].    destPixSize = 16 ifTrue:        ["Two pixels  Tally the right half..."        mapIndex _ self rgbMap: (destinationWord bitAnd: 16rFFFF) from: 5 to: cmBitsPerColor.        interpreterProxy storeWord: mapIndex ofObject: colorMap            withValue: (interpreterProxy fetchWord: mapIndex ofObject: colorMap) + 1.        "... and then left half"        mapIndex _ self rgbMap: destinationWord>>16 from: 5 to: cmBitsPerColor.        interpreterProxy storeWord: mapIndex ofObject: colorMap            withValue: (interpreterProxy fetchWord: mapIndex ofObject: colorMap) + 1]    ifFalse:        ["Just one pixel."        mapIndex _ self rgbMap: destinationWord from: 8 to: cmBitsPerColor.        interpreterProxy storeWord: mapIndex ofObject: colorMap            withValue: (interpreterProxy fetchWord: mapIndex ofObject: colorMap) + 1].    ^ destinationWord  "For no effect on dest"! !!BitBltSimulation methodsFor: 'pixel mapping'!deltaFrom: x1 to: x2 nSteps: n    "Utility routine for computing Warp increments."    x2 > x1        ifTrue: [^ x2 - x1 + FixedPt1 // (n+1) + 1]        ifFalse: [x2 = x1 ifTrue: [^ 0].                ^ 0 - (x1 - x2 + FixedPt1 // (n+1) + 1)]! !!BitBltSimulation methodsFor: 'pixel mapping'!pickSourcePixels: nPix nullMap: nullMap srcMask: sourcePixMask destMask: destPixMask    "This is intended to be expanded in-line; it merely calls the others"    sourcePixSize >= 16 ifTrue:        [^ self pickSourcePixelsRGB: nPix nullMap: nullMap srcMask: sourcePixMask destMask: destPixMask].    nullMap ifTrue:        [^ self pickSourcePixelsNullMap: nPix srcMask: sourcePixMask destMask: destPixMask].    ^ self pickSourcePixels: nPix srcMask: sourcePixMask destMask: destPixMask! !!BitBltSimulation methodsFor: 'pixel mapping'!pickSourcePixels: nPix srcMask: sourcePixMask destMask: destPixMask    "This version of pickSourcePixels is for sourcePixSize <= 8        and colorMap notNil"    "Pick nPix pixels from the source, mapped by the    color map, and right-justify them in the resulting destWord."    | sourceWord destWord sourcePix destPix |    sourceWord _ (interpreterProxy longAt: sourceIndex).    destWord _ 0.    1 to: nPix do:        [:i |        sourcePix _ sourceWord >> ((32-sourcePixSize) - srcBitIndex)                    bitAnd: sourcePixMask.        "look up sourcePix in colorMap"        destPix _ (interpreterProxy fetchWord: sourcePix ofObject: colorMap) bitAnd: destPixMask.        destWord _ (destWord << destPixSize) bitOr: destPix.        (srcBitIndex _ srcBitIndex + sourcePixSize) > 31 ifTrue:            [srcBitIndex _ srcBitIndex - 32.            sourceIndex _ sourceIndex + 4.            sourceWord _ interpreterProxy longAt: sourceIndex]].    ^ destWord! !!BitBltSimulation methodsFor: 'pixel mapping'!pickSourcePixelsNullMap: nPix srcMask: sourcePixMask destMask: destPixMask    "This version of pickSourcePixels is for colorMap==nil.        SourcePixelSize is also known to be 8 bits or less."    "With no color map, pixels are just masked or zero-filled."    | sourceWord destWord sourcePix |    sourceWord _ (interpreterProxy longAt: sourceIndex).    destWord _ 0.    1 to: nPix do:        [:i |        sourcePix _ sourceWord >> ((32-sourcePixSize) - srcBitIndex)                    bitAnd: sourcePixMask.        destWord _ (destWord << destPixSize)                     bitOr: (sourcePix bitAnd: destPixMask).        (srcBitIndex _ srcBitIndex + sourcePixSize) > 31 ifTrue:            [srcBitIndex _ srcBitIndex - 32.            sourceIndex _ sourceIndex + 4.            sourceWord _ interpreterProxy longAt: sourceIndex]].    ^ destWord! !!BitBltSimulation methodsFor: 'pixel mapping' stamp: 'di 6/23/97 14:28'!pickSourcePixelsRGB: nPix nullMap: nullMap srcMask: sourcePixMask destMask: destPixMask    "This version of pickSourcePixels is for sourcePixSize >= 16"    "Pick nPix pixels from the source, mapped by the    color map, and right-justify them in the resulting destWord.    Incoming pixels of 16 or 32 bits are first reduced to cmBitsPerColor.    With no color map, pixels are just masked or zero-filled or    if 16- or 32-bit pixels, the r, g, and b are so treated individually."    | sourceWord destWord sourcePix destPix |    sourceWord _ (interpreterProxy longAt: sourceIndex).    destWord _ 0.    1 to: nPix do:        [:i |        sourcePix _ sourceWord >> ((32-sourcePixSize) - srcBitIndex)                    bitAnd: sourcePixMask.        nullMap        ifTrue:            ["Map between RGB pixels"            sourcePixSize = 16                ifTrue: [destPix _ self rgbMap: sourcePix from: 5 to: 8]                ifFalse: [destPix _ self rgbMap: sourcePix from: 8 to: 5]]        ifFalse:            ["RGB pixels first get reduced to cmBitsPerColor"            sourcePixSize = 16                ifTrue: [sourcePix _ self rgbMap: sourcePix from: 5 to: cmBitsPerColor]                ifFalse: [sourcePix _ self rgbMap: sourcePix from: 8 to: cmBitsPerColor].            "Then look up sourcePix in colorMap"            destPix _ (interpreterProxy fetchWord: sourcePix ofObject: colorMap) bitAnd: destPixMask].        destWord _ (destWord << destPixSize) bitOr: destPix.        (srcBitIndex _ srcBitIndex + sourcePixSize) > 31 ifTrue:            [srcBitIndex _ srcBitIndex - 32.            sourceIndex _ sourceIndex + 4.            sourceWord _ interpreterProxy longAt: sourceIndex]].    ^ destWord! !!BitBltSimulation methodsFor: 'pixel mapping'!rgbMap: sourcePixel from: nBitsIn to: nBitsOut    "Convert the given pixel value with nBitsIn bits for each color component to a pixel value with nBitsOut bits for each color component. Typical values for nBitsIn/nBitsOut are 3, 5, or 8."    | mask d srcPix destPix |    self inline: true.    (d _ nBitsOut - nBitsIn) > 0        ifTrue:            ["Expand to more bits by zero-fill"            mask _ (1 << nBitsIn) - 1.  "Transfer mask"            srcPix _ sourcePixel << d.            mask _ mask << d.            destPix _ srcPix bitAnd: mask.            mask _ mask << nBitsOut.            srcPix _ srcPix << d.            ^ destPix + (srcPix bitAnd: mask)                     + (srcPix << d bitAnd: mask << nBitsOut)]        ifFalse:            ["Compress to fewer bits by truncation"            d = 0 ifTrue: [^ sourcePixel].  "no compression"            sourcePixel = 0 ifTrue: [^ sourcePixel].  "always map 0 (transparent) to 0"            d _ nBitsIn - nBitsOut.            mask _ (1 << nBitsOut) - 1.  "Transfer mask"            srcPix _ sourcePixel >> d.            destPix _ srcPix bitAnd: mask.            mask _ mask << nBitsOut.            srcPix _ srcPix >> d.            destPix _ destPix + (srcPix bitAnd: mask)                    + (srcPix >> d bitAnd: mask << nBitsOut).            destPix = 0 ifTrue: [^ 1].  "Dont fall into transparent by truncation"            ^ destPix]! !!BitBltSimulation methodsFor: 'pixel mapping'!smoothPix: n atXf: xf yf: yf dxh: dxh dyh: dyh dxv: dxv dyv: dyv    pixPerWord: srcPixPerWord pixelMask: sourcePixMask    sourceMap: sourceMap    | sourcePix r g b x y rgb bitsPerColor d nPix maxPix |    r _ g _ b _ 0.  "Separate r, g, b components"    maxPix _ n*n.    x _ xf.  y _ yf.    nPix _ 0.  "actual number of pixels (not clipped and not transparent)"    0 to: n-1 do:        [:i |        0 to: n-1 do:            [:j |            sourcePix _ (self sourcePixAtX: x + (dxh*i) + (dxv*j)  >> BinaryPoint                                    y: y + (dyh*i) + (dyv*j)  >> BinaryPoint                                    pixPerWord: srcPixPerWord)                                    bitAnd: sourcePixMask.            (combinationRule=25 "PAINT" and: [sourcePix = 0]) ifFalse:              ["If not clipped and not transparent, then tally rgb values"            nPix _ nPix + 1.            sourcePixSize < 16                ifTrue: ["Get 24-bit RGB values from sourcemap table"                        rgb _ (interpreterProxy fetchWord: sourcePix ofObject: sourceMap) bitAnd: 16rFFFFFF]                ifFalse: ["Already in RGB format"                        sourcePixSize = 32                        ifTrue: [rgb _ sourcePix bitAnd: 16rFFFFFF]                        ifFalse: ["Note could be faster"                                rgb _ self rgbMap: sourcePix from: 5 to: 8]].            r _ r + ((rgb >> 16) bitAnd: 16rFF).            g _ g + ((rgb >> 8) bitAnd: 16rFF).            b _ b + (rgb bitAnd: 16rFF).            ]].        ].    (nPix = 0 or: [combinationRule=25 "PAINT" and: [nPix < (maxPix//2)]])        ifTrue: [^ 0  "All pixels were 0, or most were transparent"].    colorMap ~= interpreterProxy nilObject        ifTrue: [bitsPerColor _ cmBitsPerColor]        ifFalse: [destPixSize = 16 ifTrue: [bitsPerColor _ 5].                destPixSize = 32 ifTrue: [bitsPerColor _ 8]].    d _ 8 - bitsPerColor.    rgb _ ((r // nPix >> d) << (bitsPerColor*2))        + ((g // nPix >> d) << bitsPerColor)        + ((b // nPix >> d)).    rgb = 0 ifTrue: [        "only generate zero if pixel is really transparent"        (r + g + b) > 0 ifTrue: [rgb _ 1]].    colorMap ~= interpreterProxy nilObject        ifTrue: [^ interpreterProxy fetchWord: rgb ofObject: colorMap]        ifFalse: [^ rgb]! !!BitBltSimulation methodsFor: 'pixel mapping'!sourcePixAtX: x y: y pixPerWord: srcPixPerWord    | sourceWord index |    self inline: true.    (x < 0 or: [x >= srcWidth]) ifTrue: [^ 0].    (y < 0 or: [y >= srcHeight]) ifTrue: [^ 0].    index _ (y * sourceRaster + (x // srcPixPerWord) *4).                                                "4 = BaseHeaderSize"    sourceWord _ interpreterProxy longAt: sourceBits + 4 + index.    ^ sourceWord >> ((32-sourcePixSize) - (x\\srcPixPerWord*sourcePixSize))! !!BitBltSimulation methodsFor: 'pixel mapping'!warpSourcePixels: nPix xDeltah: xDeltah yDeltah: yDeltah    xDeltav: xDeltav yDeltav: yDeltav    smoothing: n sourceMap: sourceMapOop    "Pick nPix pixels using these x- and y-incs, and map color if necess."    | destWord sourcePix sourcePixMask destPixMask srcPixPerWord destPix |    "Fix degenerate shift values 4/28/97 ar"    sourcePixSize = 32        ifTrue: [ sourcePixMask _ -1]        ifFalse: [ sourcePixMask _ (1 << sourcePixSize) - 1].    destPixSize = 32        ifTrue: [ destPixMask _ -1]        ifFalse: [ destPixMask _ (1 << destPixSize) - 1].    srcPixPerWord _ 32 // sourcePixSize.    destWord _ 0.    1 to: nPix do:        [:i |        n > 1        ifTrue:            ["Average n pixels and compute dest pixel from color map"            destPix _ (self smoothPix: n atXf: sx yf: sy                dxh: xDeltah//n dyh: yDeltah//n dxv: xDeltav//n dyv: yDeltav//n                pixPerWord: srcPixPerWord pixelMask: sourcePixMask                sourceMap: sourceMapOop)                    bitAnd: destPixMask]        ifFalse:            ["No smoothing -- just pick pixel and map if difft depths or color map supplied"            sourcePix _ (self sourcePixAtX: sx >> BinaryPoint                                    y: sy >> BinaryPoint                                    pixPerWord: srcPixPerWord)                        bitAnd: sourcePixMask.            colorMap = interpreterProxy nilObject                ifTrue:                [destPixSize = sourcePixSize                ifTrue:                    [destPix _ sourcePix]                ifFalse:                    [sourcePixSize >= 16 ifTrue:                        ["Map between RGB pixels"                        sourcePixSize = 16                            ifTrue: [destPix _ self rgbMap: sourcePix from: 5 to: 8]                            ifFalse: [destPix _ self rgbMap: sourcePix from: 8 to: 5]]                    ifFalse: [destPix _ sourcePix bitAnd: destPixMask]]]            ifFalse:                [sourcePixSize >= 16 ifTrue:                    ["RGB pixels first get reduced to cmBitsPerColor"                    sourcePixSize = 16                        ifTrue: [sourcePix _ self rgbMap: sourcePix from: 5 to: cmBitsPerColor]                        ifFalse: [sourcePix _ self rgbMap: sourcePix from: 8 to: cmBitsPerColor]].                "Then look up sourcePix in colorMap"                destPix _ (interpreterProxy fetchWord: sourcePix ofObject: colorMap) bitAnd: destPixMask]].        destWord _ (destWord << destPixSize) bitOr: destPix.        sx _ sx + xDeltah.        sy _ sy + yDeltah.        ].    ^ destWord! !!BitBltSimulation class methodsFor: 'initialization'!initialize    "BitBltSimulation initialize"     "Mask constants"    AllOnes _ 16rFFFFFFFF.    BinaryPoint _ 14.    FixedPt1 _ 1 << BinaryPoint.  "Value of 1.0 in Warp's fixed-point representation"     "Indices into stopConditions for scanning"    EndOfRun _ 257.    CrossedX _ 258.     "Form fields"    FormBitsIndex _ 0.    FormWidthIndex _ 1.    FormHeightIndex _ 2.    FormDepthIndex _ 3.     "BitBlt fields"    BBDestFormIndex _ 0.    BBSourceFormIndex _ 1.    BBHalftoneFormIndex _ 2.    BBRuleIndex _ 3.    BBDestXIndex _ 4.    BBDestYIndex _ 5.    BBWidthIndex _ 6.    BBHeightIndex _ 7.    BBSourceXIndex _ 8.    BBSourceYIndex _ 9.    BBClipXIndex _ 10.    BBClipYIndex _ 11.    BBClipWidthIndex _ 12.    BBClipHeightIndex _ 13.    BBColorMapIndex _ 14.    BBWarpBase _ 15.    BBLastIndex _ 15.    BBXTableIndex _ 16.! !!BitBltSimulation class methodsFor: 'initialization'!test2  "BitBltSimulation test2"    | f |    Display fillWhite: (0@0 extent: 300@140).    1 to: 12 do:        [:i | f _ (Form extent: i@5) fillBlack.        0 to: 20 do:            [:x | f displayOn: Display                    at: (x*13) @ (i*10)]]! !!BitBltSimulation class methodsFor: 'initialization'!timingTest: extent  "BitBltSimulation timingTest: 640@480"    | f f2 map |    f _ Form extent: extent depth: 8.    f2 _ Form extent: extent depth: 8.    map _ Bitmap new: 1 << f2 depth.    ^ Array with:    (Time millisecondsToRun: [100 timesRepeat:        [f fillWithColor: Color white]])    with:    (Time millisecondsToRun: [100 timesRepeat:        [f copy: f boundingBox from: 0@0 in: f2 rule: Form over]])    with:    (Time millisecondsToRun: [100 timesRepeat:        [f copyBits: f boundingBox from: f2 at: 0@0 colorMap: map]])! !!BitBltSimulation class methodsFor: 'translation'!declareCVarsIn: aCCodeGenerator    "Nothing to declare..."! !!BitEditor methodsFor: 'control defaults'!redButtonActivity    | formPoint displayPoint |    model depth = 1 ifTrue:        ["If this is just a black&white form, then set the color to be        the opposite of what it was where the mouse was clicked"        formPoint _ (view inverseDisplayTransform: sensor cursorPoint - (scale//2)) rounded.        color _ 1-(view workingForm pixelValueAt: formPoint).        squareForm fillColor: (color=1 ifTrue: [Color black] ifFalse: [Color white])].    [sensor redButtonPressed]      whileTrue:         [formPoint _ (view inverseDisplayTransform: sensor cursorPoint - (scale//2)) rounded.        displayPoint _ view displayTransform: formPoint.        squareForm             displayOn: Display            at: displayPoint             clippingBox: view insetDisplayBox             rule: Form over            fillColor: nil.        view changeValueAt: formPoint put: color]! !!BitEditor class methodsFor: 'private' stamp: 'hmm 7/21/97 20:42'!bitEdit: aForm at: magnifiedFormLocation scale: scaleFactor remoteView: remoteView    "Create a BitEditor on aForm. That is, aForm is a small image that will     change as a result of the BitEditor changing a second and magnified     view of me. magnifiedFormLocation is where the magnified form is to be     located on the screen. scaleFactor is the amount of magnification. This     method implements a scheduled view containing both a small and     magnified view of aForm. Upon accept, aForm is updated."    | aFormView scaledFormView bitEditor topView extent menuView lowerRightExtent |    scaledFormView _ FormHolderView new model: aForm.    scaledFormView scaleBy: scaleFactor.    bitEditor _ self new.    scaledFormView controller: bitEditor.    bitEditor setColor: Color black.    topView _ ColorSystemView new.    remoteView == nil ifTrue: [topView label: 'Bit Editor'].    topView borderWidth: 2.    topView addSubView: scaledFormView.    remoteView == nil        ifTrue:  "If no remote view, then provide a local view of the form"            [aFormView _ FormView new model: scaledFormView workingForm.            aFormView controller: NoController new.            aForm height < 50                ifTrue: [aFormView borderWidthLeft: 0 right: 2 top: 2 bottom: 2]                ifFalse: [aFormView borderWidthLeft: 0 right: 2 top: 2 bottom: 0].            topView addSubView: aFormView below: scaledFormView]         ifFalse:  "Otherwise, the remote one should view the same form"            [remoteView model: scaledFormView workingForm].    lowerRightExtent _ remoteView == nil            ifTrue:                [(scaledFormView viewport width - aFormView viewport width) @                    (aFormView viewport height max: 50)]            ifFalse:                [scaledFormView viewport width @ 50].    menuView _ self buildColorMenu: lowerRightExtent colorCount: 1.    menuView model: bitEditor.    menuView borderWidthLeft: 0 right: 0 top: 2 bottom: 0.    topView        addSubView: menuView        align: menuView viewport topRight        with: scaledFormView viewport bottomRight.    extent _ scaledFormView viewport extent + (0 @ lowerRightExtent y)            + (4 @ 4).  "+4 for borders"    topView minimumSize: extent.    topView maximumSize: extent.    topView translateBy: magnifiedFormLocation.    topView insideColor: Color white.    ^topView! !!BitEditor class methodsFor: 'private'!buildColorMenu: extent colorCount: nColors    "See BitEditor magnifyWithSmall."    | menuView form aSwitchView    button formExtent highlightForm color leftOffset |    menuView _ FormMenuView new.    menuView window: (0@0 corner: extent).    formExtent _ 30@30 min: extent//(nColors*2+1@2).  "compute this better"    leftOffset _ extent x-(nColors*2-1*formExtent x)//2.    highlightForm _ Form extent: formExtent.    highlightForm borderWidth: 4.    1 to: nColors do:        [:index |         color _ (nColors=1            ifTrue: [#(black)]            ifFalse: [#(black gray)]) at: index.        form _ Form extent: formExtent.        form fill: form boundingBox fillColor: (Color perform: color).        form borderWidth: 5.        form border: form boundingBox width: 4 fillColor: Color white.        button _ Button new.        index = 1 ifTrue:            [button onAction: [menuView model setColor: Color fromUser]]            ifFalse:            [button onAction: [menuView model setTransparentColor]].        aSwitchView _ SwitchView new model: button.        aSwitchView key: ((nColors=3 ifTrue: ['xvn'] ifFalse: ['xn']) at: index).        aSwitchView label: form.        aSwitchView window: (0@0 extent: form extent).        aSwitchView translateBy: (index-1*2*form width+leftOffset) @ (form height//2).        aSwitchView highlightForm: highlightForm.            aSwitchView borderWidth: 1.        aSwitchView controller selector: #turnOn.        menuView addSubView: aSwitchView].    ^menuView! !!BitEditor class methodsFor: 'private'!locateMagnifiedView: aForm scale: scaleFactor    "Answer a rectangle at the location where the scaled view of the form,    aForm, should be displayed."    ^ Rectangle originFromUser: (aForm extent * scaleFactor + (0@50)).    ! !!Bitmap methodsFor: 'filing'!compressToByteArray    "Return a simple run-coded compression of the receiver into a byteArray:        First 4 bytes are the size of the original Bitmap.        This is followed by a number of runs...        [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]"    ^ ByteArray streamContents:        [:s | 1 to: 4 do: [:i | s nextPut: (self size digitAt: 5-i)].    "positive size"        self compressToStream: s]"Space check: | n rawBytes myBytes b |n _ rawBytes _ myBytes _ 0.Form allInstancesDo:    [:f | b _ f bits.    b size > 10 ifTrue:        [n _ n + 1.        rawBytes _ rawBytes + (b size*4).        myBytes _ myBytes + (b compressToByteArray size)]].Array with: n with: rawBytes with: myBytes (69 304604 87588 )Speed test: | b |Smalltalk garbageCollect.MessageTally spyOn: [Form allInstances do:    [:f | b _ f bits.    b size > 10 ifTrue:        [Bitmap decompressFromByteArray: b compressToByteArray]]]"! !!Bitmap methodsFor: 'filing'!compressToStream: aBinaryStream    "Return a simple run-coded compression of the receiver into a byteArray:        (Caller has put negated size of original Bitmap in first 4 bytes.)        Then put out a number of runs...        [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]"    | here end runLen startAndLen junkLen s |    s _ aBinaryStream.    here _ 1.  end _ self size*4.    [here <= end] whileTrue:        ["Scan for a run of 4..130 = bytes..."        runLen _ self scanForRunOf: 4 from: here to: (here+129 min: end).        runLen > 0            ifTrue:            [s nextPut: runLen - 3.  "Codes 1..127 mean n+3 copies of next byte"            s nextPut: (self byteAt: here).            here _ here + runLen]            ifFalse:            ["Scan for a junk run (never 4 or more = bytes) of length 1..64                [dont want to find runs of 3 as we would miss aaabaaab]"            runLen _ self scanForNoRunOf: 4 from: here to: (here+63 min: end).            "See if there is a 4-byte repeating pattern in the junk"            startAndLen _ self scanForWordRunFrom: here to: (here+runLen-1 min: end).            startAndLen first = 0                ifTrue: [junkLen _  runLen]                ifFalse: [junkLen _ startAndLen first - here].            "Now output the junk up to repeating words if any..."            junkLen > 0                ifTrue: [s nextPut: junkLen+127.  "Codes 128..191 mean n-127 bytes of junk"                        0 to: junkLen-1 do: [:i | s nextPut: (self byteAt: here + i)].                        here _ here + junkLen].            startAndLen first > 0                ifTrue: ["Note: later may want to look for more copies of this                        4-byte pattern up to 65"                        s nextPut: startAndLen last+190.                            "Codes 192-255 mean n-190  copies of next 4 bytes"                        0 to: 3 do: [:i | s nextPut: (self byteAt: here + i)].                        here _ here + (startAndLen last * 4)]]].    s nextPut: 0 "zero end-flag to simplify decompressor""Space check: | n rawBytes myBytes b |n _ rawBytes _ myBytes _ 0.Form allInstancesDo:    [:f | b _ f bits.    b size > 10 ifTrue:        [n _ n + 1.        rawBytes _ rawBytes + (b size*4).        myBytes _ myBytes + (b compressToByteArray size)]].Array with: n with: rawBytes with: myBytes (69 304604 87588 )Speed test: | b |Smalltalk garbageCollect.MessageTally spyOn: [Form allInstances do:    [:f | b _ f bits.    b size > 10 ifTrue:        [Bitmap decompressFromByteArray: b compressToByteArray]]]"! !!Bitmap methodsFor: 'filing' stamp: 'jm 9/21/97 18:06'!isBigEndian    "Return true if the currently running virtual machine stores words in big-ending byte ordering (that is, of the four bytes used to store a 32-bit word, the byte with the lowest memory address is the most significant)."    "Note: One should generally avoid writing in a style that depends on the underlying byte ordering, hence there should be very few references to this method."    | words bytes |    words _ Bitmap new: 1.    bytes _ ByteArray new: 4.    bytes at: 4 put: 1.    (Form new hackBits: bytes) displayOn: (Form new hackBits: words).    ^ (words at: 1) = 1! !!Bitmap methodsFor: 'filing' stamp: 'jm 9/21/97 18:06'!readCompressedFrom: strm    "Decompress a 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 _ WriteStream on: (outBuff _ ByteArray new: self size*4).    [(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 isBigEndian ifFalse: [self swapBytes: outBuff].    (Form new hackBits: outBuff) displayOn: (Form new hackBits: self)."Integerity check: | f r |r _ Rectangle fromUser.f _ Form fromDisplay: r.f bits: (Bitmap decompressFromByteArray: f bits compressToByteArray).f bits size = f bitsSize ifFalse: [self halt].f displayAt: r topLeftTotal Integerity check:Form allInstances do: [:f |f bits = (Bitmap decompressFromByteArray: f bits compressToByteArray)    ifFalse: [self halt]]"! !!Bitmap methodsFor: 'filing'!scanForNoRunOf: minLen from: here to: end    | val runLen runStart |    (here + minLen - 1) > end ifTrue: [^ end - here + 1].    runStart _ here.  val _ self byteAt: runStart.    here + 1 to: end do:        [:i | (self byteAt: i) = val            ifTrue: [runLen _ i - runStart + 1.                    runLen >= minLen ifTrue: [^ runStart - here]]            ifFalse: [runStart _ i.  val _ self byteAt: runStart]].    ^ end - here + 1! !!Bitmap methodsFor: 'filing'!scanForRunOf: minLen from: here to: end    | val runLen |    (here + minLen - 1) > end ifTrue: [^ 0].    val _ self byteAt: here.    here + 1 to: end do:        [:i | (self byteAt: i) = val ifFalse:            [runLen _ i - here.            runLen < minLen ifTrue: [^ 0] ifFalse: [^ runLen]]].    ^ end - here + 1! !!Bitmap methodsFor: 'filing'!scanForWordRunFrom: here to: end    "Returns an array with (starting byte index) , (length of run in 4-byte words)"    | runStart runLen |    here + 7 > end ifTrue: [^ Array with: 0 with: 0].  "Need at least 8 bytes"    "Scan for i such that a(i+j+4) = a(i+j), for j=0...n, n>=7"    runStart _ here.  runLen _ 0.    here to: end-4 do:        [:i | (self byteAt: i) = (self byteAt: i+4)            ifTrue: [runLen _ runLen + 1]            ifFalse: [runLen >= 8 ifTrue: [^ Array with: runStart with: runLen//4].                    runStart _ i + 1.  runLen _ 0]].    runLen >= 8 ifTrue: [^ Array with: runStart with: runLen//4].    ^ Array with: 0 with: 0! !!Bitmap methodsFor: 'filing' stamp: 'di 9/23/97 14:41'!swapBytes    self swapBytesFrom: 1 to: self size! !!Bitmap methodsFor: 'filing' stamp: 'jm 9/21/97 18:07'!swapBytes: aByteArray    | i b0 b1 |    (aByteArray size \\ 4) = 0        ifFalse: [self error: 'array size must be multiple of 4'].    i _ 1.    [i < aByteArray size] whileTrue: [        b0 _ aByteArray at: i.        b1 _ aByteArray at: i+1.        aByteArray at: i   put: (aByteArray at: i+3).        aByteArray at: i+1 put: (aByteArray at: i+2).        aByteArray at: i+2 put: b1.        aByteArray at: i+3 put: b0.        i _ i + 4].! !!Bitmap methodsFor: 'filing' stamp: 'di 10/2/97 00:02'!swapBytesFrom: start to: stop    "Perform a bigEndian/littleEndian byte reversal of my words"    | 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: 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.! !!Bitmap methodsFor: 'filing'!writeOn: aStream     "Store the array of bits onto the argument, aStream.  Use a simple run-coded compression of the receiver into a byteArray:        First 4 bytes are the size of the original Bitmap *negated*.        This is followed by a number of runs...        [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].    Difference from compressToByteArray is that first word is size negated here."    aStream nextInt32Put: self size negated.    self compressToStream: aStream! !!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."    <primitive: 145>    self errorImproperStore.! !!Bitmap class methodsFor: 'instance creation'!decompressFromByteArray: b    | s size |    s _ ReadStream on: b.    size _ 0.    1 to: 4 do: [:i | size _ (size * 256) + s next].    ^ (self new: size) readCompressedFrom: s! !!BlockContext methodsFor: 'evaluating'!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."    <primitive: 82>    self numArgs = anArray size        ifTrue: [self error: 'Attempt to evaluate a block that is already being evaluated.']        ifFalse: [self error: 'This block requires ' , self numArgs printString , ' arguments.']! !!BlockContext methodsFor: 'private' stamp: 'jm 9/18/97 21:40'!cannotReturn: result    "The receiver tried to return result to a method context that no longer exists."    DebuggerView        openContext: thisContext        label: 'Block cannot return'        contents: thisContext shortStack.! !!BlockContext methodsFor: 'menus'!dispatchAsMenuActionTo: anObject with: argument    ^self numArgs = 0        ifTrue: [self value]        ifFalse: [self numArgs = 1                    ifTrue: [self value: anObject]                    ifFalse: [self value: anObject value: argument]]! !!BlockNode methodsFor: 'initialize-release'!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 _ Array new: 0.    returnLast ifTrue: [self returnLast]! !!BlockNode methodsFor: 'code generation'!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].    stack pop: 1! !!BlockNode methodsFor: 'printing'!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: [(len = 1 and: [((statements at: 1) == NodeNil) & (arguments size = 0)])                    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 size > 0            ifTrue:                 [i = shown ifTrue: [aStream crtab: level].                thisStatement printCommentOn: aStream indent: level.                i < shown ifTrue: [aStream crtab: level]]]! !!BlockNode methodsFor: 'C translation'!asTranslatorNode    | statementList newS |    statementList _ OrderedCollection new.    statements do: [ :s |        newS _ s asTranslatorNode.        newS isStmtList ifTrue: [            "inline the statement list returned when a CascadeNode is translated"            statementList addAll: newS statements.        ] ifFalse: [            statementList add: newS.        ].    ].    ^TStmtListNode new        setArguments: (arguments asArray collect: [ :arg | arg key ])        statements: statementList! !!BookMorph methodsFor: 'initialization'!initialize    super initialize.    orientation _ #vertical.    centering _ #center.    hResizing _ #shrinkWrap.    vResizing _ #shrinkWrap.    inset _ 5.    color _ Color white.    self borderWidth: 2.    pageSize _ 160@300.    openToDragNDrop _ true.    copyContents _ false.    pages _ OrderedCollection new.    self addMorph: (Morph new color: color; extent: 10@10).  "spacer"    self addMorph: self makePageControls.    self insertPage.! !!BookMorph methodsFor: 'accessing'!pages    ^ pages! !!BookMorph methodsFor: 'accessing'!pages: aMorphList    pages _ aMorphList asOrderedCollection.    pages size > 0        ifTrue: [currentPage _ pages first]        ifFalse: [self insertPage].! !!BookMorph methodsFor: 'accessing'!pageSize    ^ pageSize! !!BookMorph methodsFor: 'accessing'!pageSize: aPoint    pageSize _ aPoint.! !!BookMorph methodsFor: 'accessing' stamp: 'jm 6/21/97 16:45'!saveBlock: aBlock    "Record a block to be evaluated with a copy of this book when the user wishes to save it."    saveBlock _ aBlock.! !!BookMorph methodsFor: 'dropping/grabbing'!acceptDroppingMorph: aMorph event: evt    "Allow the user to add submorphs just by dropping them on this morph."    (currentPage allMorphs includes: aMorph)        ifFalse: [currentPage addMorph: aMorph].! !!BookMorph methodsFor: 'dropping/grabbing'!allowSubmorphExtraction    ^ false! !!BookMorph methodsFor: 'dropping/grabbing' stamp: 'jm 6/21/97 15:43'!rootForGrabOf: aMorph    | root |    (openToDragNDrop or: [copyContents])        ifFalse: [^ super rootForGrabOf: aMorph].    (aMorph = currentPage or: [aMorph owner = self])        ifTrue: [^ self rootForGrabOf: self].    root _ aMorph.    [root = self] whileFalse: [        root owner = currentPage ifTrue: [            (copyContents and: [openToDragNDrop not])                ifTrue: [^ root fullCopy]                ifFalse: [^ root]].        root _ root owner].    ^ super rootForGrabOf: aMorph! !!BookMorph methodsFor: 'zooming page turns'!goToPage: pageNumber zoomingFrom: srcButtonMorph    | bigBalloonMorph i newPage cachedMorph zoomer |    pages isEmpty ifTrue: [^ self].    (self isInWorld and:     [self world modelOrNil respondsTo: #bigBalloonMorph])        ifTrue: [bigBalloonMorph _ self world model bigBalloonMorph fullCopy]        ifFalse: [^ self goToPage: pageNumber].    bigBalloonMorph position: self world model scaffoldingBook root fullBounds origin.    bigBalloonMorph removeAllMorphs.    i _ pageNumber asInteger.    i > pages size ifTrue: [i _ 1].  "wrap"    i < 1  ifTrue: [i _ pages size].  "wrap"    newPage _ pages at: i.    cachedMorph _ CachingMorph new.    cachedMorph addMorph: bigBalloonMorph.    bigBalloonMorph addMorph: newPage fullCopy.    zoomer _ ZoomMorph new.    self world addMorphFront: zoomer.    zoomer zoomFromMorph: srcButtonMorph                            toMorph: cachedMorph                            andThen: [self goToPage: i].    self world ifNotNil: [self world startSteppingSubmorphsOf: zoomer].! !!BookMorph methodsFor: 'zooming page turns'!nextPageZoomingFrom: aMorph    | i |    i _ (pages indexOf: currentPage ifAbsent: [0]) + 1.    self goToPage: i zoomingFrom: aMorph.! !!BookMorph methodsFor: 'zooming page turns'!previousPageZoomingFrom: aMorph    | i |    i _ (pages indexOf: currentPage ifAbsent: [2]) - 1.    self goToPage: i zoomingFrom: aMorph.! !!BookMorph methodsFor: 'menu' stamp: 'jm 9/28/97 14:36'!addCustomMenuItems: aCustomMenu hand: aHandMorph    super addCustomMenuItems: aCustomMenu hand: aHandMorph.    aCustomMenu add: 'previous page' action: #previousPage.    aCustomMenu add: 'next page' action: #nextPage.    aCustomMenu add: 'insert a page' action: #insertPage.    aCustomMenu add: 'delete this page' action: #deletePage.    aCustomMenu add: 'page controls' action: #pageControls:.    saveBlock ifNotNil: [aCustomMenu add: 'save' action: #save].! !!BookMorph methodsFor: 'menu'!deletePage    | oldPage |    oldPage _ currentPage.    self nextPage.    pages remove: oldPage.    oldPage delete.    currentPage = oldPage ifTrue: [self nextPage].    pages isEmpty ifTrue: [self insertPage].! !!BookMorph methodsFor: 'menu'!insertPage    | newPage |    newPage _ ClippingMorph new extent: pageSize; color: Color white.    pages isEmpty        ifTrue: [pages add: (currentPage _ newPage)]        ifFalse: [pages add: newPage after: currentPage].    self nextPage.! !!BookMorph methodsFor: 'menu' stamp: 'jm 6/11/97 17:37'!newTextMorph    "Create a new, empty TextMorph that can be placed in this book."    self isInWorld ifTrue: [        self world hands first attachMorph:            (TextMorph new extent: currentPage width@30)].! !!BookMorph methodsFor: 'menu'!nextPage    | i |    i _ (pages indexOf: currentPage ifAbsent: [0]) + 1.    self goToPage: i.! !!BookMorph methodsFor: 'menu'!pageControls: evt    | buttonPanel |    buttonPanel _ self makePageControls.    buttonPanel borderWidth: 1; inset: 4.    evt hand attachMorph: buttonPanel.! !!BookMorph methodsFor: 'menu'!previousPage    | i |    i _ (pages indexOf: currentPage ifAbsent: [2]) - 1.    self goToPage: i.! !!BookMorph methodsFor: 'private'!goToPage: pageNumber    | i |    pages isEmpty ifTrue: [^ self].    "wrap around"    i _ pageNumber asInteger.    pageNumber < 1 ifTrue: [i _ pages size].    pageNumber > pages size ifTrue: [i _ 1].    self world ifNotNil: [        self world hands first newKeyboardFocus: nil].    currentPage ifNotNil: [currentPage delete].    currentPage _ pages at: i.    self addMorphBack: currentPage.    self world ifNotNil: [        self world startSteppingSubmorphsOf: currentPage].! !!BookMorph methodsFor: 'private' stamp: 'jm 6/11/97 17:37'!insertPageLabel: labelString morphs: morphList    | m c |    self insertPage.    m _ (TextMorph new extent: pageSize x@20; contents: labelString).    m position: currentPage position + (((currentPage width - m width) // 2) @ 5).    currentPage addMorph: m.    "use a column to align the given morphs, then add them to the page"    c _ LayoutMorph newColumn centering: #center.    c addAllMorphs: morphList.    c position: currentPage position + (0@40).    currentPage addAllMorphs: morphList.! !!BookMorph methodsFor: 'private'!makePageControls    | b r |    b _ SimpleButtonMorph new target: self; borderColor: Color black.    r _ LayoutMorph newRow.    r color: b color; borderWidth: 0; inset: 0.    r hResizing: #shrinkWrap; vResizing: #shrinkWrap; extent: 5@5.    r addMorphBack: (b fullCopy label: '<-';            actionSelector: #previousPage).    r addMorphBack: (b fullCopy label: 'Insert';        actionSelector: #insertPage).    r addMorphBack: (b fullCopy label: 'Delete';        actionSelector: #deletePage).    r addMorphBack: (b fullCopy label: 'Text';        actionSelector: #newTextMorph).    r addMorphBack: (b fullCopy label: '->';            actionSelector: #nextPage).    ^ r! !!BookMorph methodsFor: 'copying' stamp: 'jm 6/13/97 18:08'!copyRecordingIn: dict    "Overridden to copy the pages of this book as well."    | new |    new _ super copyRecordingIn: dict.    new pages: (pages collect: [:pg |        "the current page was copied with the submorphs"        (dict includesKey: pg)            ifTrue: [dict at: pg]  "current page; already copied"            ifFalse: [pg copyRecordingIn: dict]]).    dict at: self put: new.    ^ new! !!BookMorph methodsFor: 'save/revert' stamp: 'jm 6/21/97 16:45'!save    "Evaluate the saveBlock for this book, if any. The saveBlock typically stores a copy of this book for later retrieval."    saveBlock ifNotNil: [saveBlock value: self fullCopy].! !!BorderedMorph methodsFor: 'initialization' stamp: 'di 6/20/97 11:07'!initialize    super initialize.    borderColor _ Color black.    borderWidth _ 2.! !!BorderedMorph methodsFor: 'accessing' stamp: 'di 6/20/97 11:08'!borderColor    ^ borderColor! !!BorderedMorph methodsFor: 'accessing' stamp: 'di 6/20/97 11:08'!borderColor: colorOrNil    borderColor _ colorOrNil.    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: 'di 6/20/97 11:09'!borderWidth    ^ borderWidth! !!BorderedMorph methodsFor: 'accessing' stamp: 'di 6/20/97 11:10'!borderWidth: anInteger    borderColor ifNil: [borderColor _ Color black].    borderWidth _ anInteger.    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: 'drawing' stamp: 'di 6/20/97 11:13'!drawOn: aCanvas     "Draw a rectangle with a solid, inset, or raised border.    Note: the raised border color is generated from the receiver's own color,    while the inset border color is generated from the color of its owner.    This behavior is visually more consistent. Thanks to Hans-Martin Mosner."    | insetColor |    borderWidth = 0 ifTrue: [  "no border"        aCanvas fillRectangle: bounds color: color.        ^ self].    borderColor == #raised ifTrue: [        ^ aCanvas frameAndFillRectangle: bounds            fillColor: color            borderWidth: borderWidth            topLeftColor: color lighter            bottomRightColor: color darker].    borderColor == #inset ifTrue: [        insetColor _ owner colorForInsets.        ^ aCanvas frameAndFillRectangle: bounds            fillColor: color            borderWidth: borderWidth            topLeftColor: insetColor darker            bottomRightColor: insetColor lighter].    "solid color border"    aCanvas frameAndFillRectangle: bounds        fillColor: color        borderWidth: borderWidth        borderColor: borderColor.! !!BorderedMorph methodsFor: 'geometry' stamp: 'di 6/20/97 11:15'!innerBounds    ^ bounds insetBy: borderWidth! !!BorderedMorph methodsFor: 'menu' stamp: 'jm 9/28/97 14:36'!addCustomMenuItems: aCustomMenu hand: aHandMorph    super addCustomMenuItems: aCustomMenu hand: aHandMorph.    aCustomMenu add: 'border color...' action: #changeBorderColor:.    self doesBevels ifTrue:        [borderColor == #raised ifFalse: [aCustomMenu add: 'raised bevel' action: #borderRaised].        borderColor == #inset ifFalse: [aCustomMenu add: 'inset bevel' action: #borderInset]].    aCustomMenu add: 'border width...' action: #changeBorderWidth:.! !!BorderedMorph methodsFor: 'menu' stamp: 'jm 9/25/97 16:55'!changeBorderColor: evt    evt hand changeColorTarget: self selector: #borderColor:.! !!BorderedMorph methodsFor: 'menu' stamp: 'jm 9/29/97 10:33'!changeBorderWidth: evt    | menu |    menu _ MenuMorph new.    menu addStayUpItem.    0 to: 5 do: [:w |        menu add: w printString            target: self            selector: #borderWidth:            argument: w].    menu popUpAt: evt hand position event: evt.! !!BorderedMorph methodsFor: 'printing' stamp: 'di 6/20/97 11:20'!fullPrintOn: aStream    aStream nextPutAll: '('.    super fullPrintOn: aStream.    aStream nextPutAll: ') setBorderWidth: '; print: borderWidth;        nextPutAll: ' borderColor: ' , (self colorString: borderColor)! !!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.! !BouncingAtomsMorph comment:'This morph shows how an ideal gas simulation might work. When it gets step messages, it makes all its atom submorphs move along their velocity vectors, bouncing when they hit a wall. It also exercises the Morphic damage reporting and display architecture. Here are some things to try:  1. Resize this morph as the atoms bounce around.  2. In an inspector on this morph, evaluate "self addAtoms: 10."  3. Try setting quickRedraw to false in invalidRect:. This gives the     default damage reporting and incremental redraw. Try it for     100 atoms.  4. In the drawOn: method of AtomMorph, change drawAsRect to true.  5. Create a HeaterCoolerMorph and embed it in the simulation. Extract    it and use an inspector on it to evaluate "self velocityDelta: -5", then     re-embed it. Note the effect on atoms passing over it.'!!BouncingAtomsMorph methodsFor: 'all'!addAtoms: n    "Add a bunch of new atoms."    | a |    n timesRepeat: [        a _ AtomMorph new.        a randomPositionIn: bounds maxVelocity: 10.        self addMorph: a].    self stopStepping.! !!BouncingAtomsMorph methodsFor: 'all'!addMorphFront: aMorph    "Called by the 'embed' meta action. We want non-atoms to go to the back."    "Note: A user would not be expected to write this method. However, a sufficiently advanced user (e.g, an e-toy author) might do something equivalent by overridding the drag-n-drop messages when they are implemented."    (aMorph isMemberOf: AtomMorph)        ifTrue: [super addMorphFront: aMorph]        ifFalse: [super addMorphBack: aMorph].! !!BouncingAtomsMorph methodsFor: 'all'!collisionPairs    "Return a list of pairs of colliding atoms, which are assumed to be circles of known radius. This version uses the morph's positions--i.e. the top-left of their bounds rectangles--rather than their centers."    | count sortedAtoms radius twoRadii radiiSquared collisions p1 continue j p2 distSquared |    count _ submorphs size.    sortedAtoms _ submorphs asSortedCollection:        [ :m1 :m2 | m1 position x < m2 position x].    radius _ 8.    twoRadii _ 2 * radius.    radiiSquared _ radius squared * 2.    collisions _ OrderedCollection new.    1 to: count - 1 do: [ :i |        m1 _ sortedAtoms at: i.        p1 _ m1 position.        continue _ (j _ i + 1) <= count.        [continue] whileTrue: [            m2 _ sortedAtoms at: j.            p2 _ m2 position.            (p2 x - p1 x) <= twoRadii  ifTrue: [                distSquared _ (p1 x - p2 x) squared + (p1 y - p2 y) squared.                distSquared < radiiSquared ifTrue: [                    collisions add: (Array with: m1 with: m2)].                continue _ (j _ j + 1) <= count.            ] ifFalse: [                continue _ false.            ].        ].    ].    ^ collisions! !!BouncingAtomsMorph methodsFor: 'all'!drawOn: aCanvas    "Clear the damageReported flag when redrawn."    super drawOn: aCanvas.    damageReported _ false.! !!BouncingAtomsMorph methodsFor: 'all'!initialize    super initialize.    damageReported _ false.    self extent: 400@250.    self color: (Color r: 0.8 g: 1.0 b: 0.8).    infectionHistory _ OrderedCollection new.    transmitInfection _ false.! !!BouncingAtomsMorph methodsFor: 'all'!invalidRect: damageRect    "Try setting 'quickRedraw' to true. This invalidates the entire morph, whose bounds typically subsume all it's submorphs. (However, this code checks that assumption and passes through any damage reports for out-of-bounds submorphs. Note that atoms with super-high velocities do occaisionally shoot through the walls!!) An additional optimization is to only submit only damage report per display cycle by using the damageReported flag, which is reset to false when the morph is drawn."    | quickRedraw |    quickRedraw _ true.  "false gives the original invalidRect: behavior"    (quickRedraw and:     [(bounds origin <= damageRect topLeft) and:     [damageRect bottomRight <= bounds corner]]) ifTrue: [        "can use quick redraw if damage is within my bounds"        damageReported ifFalse: [super invalidRect: bounds].  "just report once"        damageReported _ true.    ] ifFalse: [super invalidRect: damageRect].  "ordinary damage report"! !!BouncingAtomsMorph methodsFor: 'all'!setGermCount    | countString count |    countString _ FillInTheBlank        request: 'Number of cells?'        initialAnswer: self submorphCount printString.    countString isEmpty ifTrue: [^ self].    count _ Integer readFrom: (ReadStream on: countString).    self removeAllMorphs.    self addAtoms: count.! !!BouncingAtomsMorph methodsFor: 'all'!startInfection    self submorphsDo: [:m | m infected: false].    self firstSubmorph infected: true.    infectionHistory _ OrderedCollection new: 500.    transmitInfection _ true.    self startStepping.! !!BouncingAtomsMorph methodsFor: 'all'!step    "Bounce those atoms!!"    | r |    r _ bounds origin corner: (bounds corner - (8@8)).    self submorphsDo: [ :m |        (m isMemberOf: AtomMorph) ifTrue: [m bounceIn: r]].    transmitInfection ifTrue: [self transmitInfection].! !!BouncingAtomsMorph methodsFor: 'all'!stepTime    "As fast as possible."    ^ 0! !!BouncingAtomsMorph methodsFor: 'all'!transmitInfection    | infected count graph |    self collisionPairs do: [:pair |        infected _ false.        pair do: [:atom | atom infected ifTrue: [infected _ true]].        infected            ifTrue: [pair do: [:atom | atom infected: true]]].    count _ 0.    self submorphsDo: [:m | m infected ifTrue: [count _ count + 1]].    infectionHistory addLast: count.    count = submorphs size ifTrue: [        "done!! place a graph of the infection history in the world"        graph _ GraphMorph new data: infectionHistory.        graph position: bounds topRight + (10@0).        graph extent: (((infectionHistory size * 3) + (2 * graph borderWidth))@count).        self world addMorph: graph.        graph changed.        transmitInfection _ false.        self stopStepping].! !!BouncingAtomsMorph class methodsFor: 'all'!new    ^ super new addAtoms: 30! !!BraceNode methodsFor: 'code generation'!emitForValue: stack on: aStream    "elem1, ..., elemN, collectionClass, N, fromBraceStack:"    elements do: [:element | element emitForValue: stack on: aStream].    collClassNode emitForValue: stack on: aStream.    nElementsNode emitForValue: stack on: aStream.    fromBraceStackNode emit: stack args: 1 on: aStream.    stack pop: elements size! !!Browser methodsFor: 'accessing'!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 |    editSelection == #none ifTrue: [^ ''].    editSelection == #editSystemCategories         ifTrue: [^ systemOrganizer printString].    editSelection == #newClass         ifTrue: [^ Class template: self selectedSystemCategoryName].    editSelection == #editClass         ifTrue: [^ self selectedClassOrMetaClass definition].    editSelection == #editComment         ifTrue: [comment _ self selectedClass comment.            comment size = 0            ifTrue: [ ^ 'This class has not yet been commented.']            ifFalse: [ ^ comment]].    editSelection == #hierarchy         ifTrue: [^ self selectedClassOrMetaClass printHierarchy].    editSelection == #editMessageCategories         ifTrue: [^ self classOrMetaClassOrganizer printString].    editSelection == #newMessage        ifTrue: [^ self selectedClassOrMetaClass sourceCodeTemplate].    editSelection == #editMessage        ifTrue: [^ self selectedMessage].    self error: 'Browser internal error: unknown edit selection.'! !!Browser methodsFor: 'accessing'!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 |    aString _ input asString.    aText _ input asText.    editSelection == #editSystemCategories         ifTrue: [^ self changeSystemCategories: aString].    editSelection == #editClass | (editSelection == #newClass)         ifTrue: [^ self defineClass: aString notifying: aController].    editSelection == #editComment         ifTrue: [self selectedClass comment: aString. ^ true].    editSelection == #hierarchy ifTrue: [^ true].    editSelection == #editMessageCategories         ifTrue: [^ self changeMessageCategories: aString].    editSelection == #editMessage | (editSelection == #newMessage)         ifTrue: [^ self defineMessage: aText notifying: aController].    editSelection == #none ifTrue: [^ true].    self error: 'unacceptable accept'! !!Browser methodsFor: 'system category functions'!browseAllClasses    "Create and schedule a new browser on all classes alphabetically."    | newBrowser view |    newBrowser _ HierarchyBrowser new initAlphabeticListing.    BrowserView openBrowserView: (BrowserView systemCategoryBrowser: newBrowser editString: nil)        label: 'All Classes Alphabetically'! !!Browser methodsFor: 'system category functions' stamp: 'di 6/28/97 19:02'!printOutSystemCategories    "Print a description of each class in the selected category as Html."    systemCategoryListIndex ~= 0        ifTrue: [systemOrganizer fileOutCategory: self selectedSystemCategoryName                                asHtml: true ]! !!Browser methodsFor: 'class list'!classListIndex: anInteger         "Set anInteger to be the index of the current class selection."        | className |classListIndex _ anInteger.        self setClassOrganizer.        messageCategoryListIndex _ 0.        messageListIndex _ 0.        editSelection _ anInteger = 0                        ifTrue: [metaClassIndicated                                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! !!Browser methodsFor: 'class list'!hierarchy        "Display the inheritance hierarchy of the receiver's selected class."        classListIndex = 0 ifTrue: [^ self].        self okToChange ifFalse: [^ self].        self messageCategoryListIndex: 0.        editSelection := #hierarchy.        self changed: #editComment.        ^ self! !!Browser methodsFor: 'class list' stamp: 'sw 12/19/96'!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: [^ self beep].    className := (SelectionMenu selections: recentList) startUp.    className == nil ifTrue: [^ self].    class := Smalltalk at: className.    self systemCategoryListIndex: (self systemCategoryList indexOf: class category).    self classListIndex: (self classList indexOf: class name)! !!Browser methodsFor: 'class list'!selectClass: classNotMeta    self classListIndex: (self classList findFirst: [:each | each == classNotMeta name])! !!Browser methodsFor: 'class list'!spawnHierarchy        "Create and schedule a new class hierarchy browser on the currently selected class or meta."        | newBrowser view |        classListIndex = 0 ifTrue: [^ self].        newBrowser _ HierarchyBrowser new initHierarchyForClass: self selectedClass                         meta: self metaClassIndicated.        view _ BrowserView systemCategoryBrowser: newBrowser editString: nil.        Browser postOpenSuggestion: (Array with: self selectedClassOrMetaClass                         with: self selectedMessageName).        BrowserView openBrowserView: view                label: self selectedClassName , ' hierarchy'! !!Browser methodsFor: 'class functions' stamp: 'di 6/28/97 09:58'!printOutClass    "Print a description of the selected class onto a file whose name is the     category name followed by .html."    classListIndex ~= 0 ifTrue: [self selectedClass fileOutAsHtml: true]! !!Browser methodsFor: 'class functions' stamp: 'di 7/13/97 16:43'!spawnProtocol        "Create and schedule a new protocol browser on the currently selected class or meta."        classListIndex = 0 ifTrue: [^ self].        ProtocolBrowser openSubProtocolForClass: self selectedClassOrMetaClass  ! !!Browser methodsFor: 'message category functions' stamp: 'di 6/28/97 15:38'!printOutMessageCategories    "Print a description of the selected message category of the selected class     onto an external file in Html format."    messageCategoryListIndex ~= 0        ifTrue:             [self selectedClassOrMetaClass fileOutCategory: self selectedMessageCategoryName                                        asHtml: true]! !!Browser methodsFor: 'message list' stamp: 'di 9/21/97 01:02'!selectedMessage    "Answer a copy of the source code for the selected message selector."    | class selector method tempNames |    contents == nil ifFalse: [^ contents copy].    class _ self selectedClassOrMetaClass.    selector _ self selectedMessageName.    method _ class compiledMethodAt: selector.    (Sensor controlKeyPressed        or: [method fileIndex > 0 and: [(SourceFiles at: method fileIndex) == nil]])        ifTrue:        ["Emergency or no source file -- decompile without temp names"        contents _ (class decompilerClass new decompile: selector in: class method: method)            decompileString.        ^ contents copy].    Sensor leftShiftDown ifTrue:        ["Special request to decompile -- get temps from source file"        tempNames _ (class compilerClass new                        parse: method getSourceFromFile in: class notifying: nil)                        tempNames.        contents _ ((class decompilerClass new withTempNames: tempNames)                decompile: selector                in: class                method: method) decompileString.        ^ contents copy].    contents _ class sourceCodeAt: selector.    ^ contents copy! !!Browser methodsFor: 'message functions' stamp: 'di 7/13/97 11:14'!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 messageCategoryListIndex: 1].            self setClassOrganizer.  "In case organization not cached"            (oldMessageList includes: selector)                ifFalse: [self changed: #messageListChanged].            self messageListIndex: (self messageList indexOf: selector)].    ^ true! !!Browser methodsFor: 'message functions' stamp: 'di 6/27/97 21:25'!fileOutMessage    "Print a description of the selected message"    messageListIndex = 0 ifTrue: [^ self].    self selectedClassOrMetaClass fileOutMethod: self selectedMessageName! !!Browser methodsFor: 'message functions'!maybeSetSelection    "After a browser's message list is changed, this message is dispatched to the model, to give it a chance to refigure a selection"! !!Browser methodsFor: 'message functions'!methodHierarchy     "Create and schedule a message set browser on all implementors of the     currently selected message selector. Do nothing if no message is selected."    | sel list tab stab |    messageListIndex = 0 ifTrue: [^ self].    sel _ self selectedMessageName.    list _ OrderedCollection new.    tab _ ''.    self selectedClassOrMetaClass allSuperclasses reverseDo:        [:cl |        (cl includesSelector: sel) ifTrue:            [list addLast: tab , cl name, ' ', sel].        tab _ tab , '  '].    self selectedClassOrMetaClass allSubclassesWithLevelDo:        [:cl :level |        (cl includesSelector: sel) ifTrue:            [stab _ ''.  1 to: level do: [:i | stab _ stab , '  '].            list addLast: tab , stab , cl name, ' ', sel]]         startingLevel: 0.    Smalltalk browseMessageList: list        name: 'Inheritance of ' , self selectedMessageName! !!Browser methodsFor: 'message functions' stamp: 'di 6/28/97 15:53'!printOutMessage    "Print a description of the selected message"    messageListIndex = 0 ifTrue: [^ self].    self selectedClassOrMetaClass fileOutMethod: self selectedMessageName                            asHtml: true! !!Browser methodsFor: 'metaclass'!classMessagesIndicated    "Answer whether the messages to be presented should come from the     metaclass."    ^ self metaClassIndicated! !!Browser methodsFor: 'metaclass'!classOrMetaClassOrganizer    "Answer the class organizer for the metaclass or class, depending on     which (instance or class) is indicated."    self metaClassIndicated        ifTrue: [^metaClassOrganizer]        ifFalse: [^classOrganizer]! !!Browser methodsFor: 'metaclass'!selectedClassOrMetaClass    "Answer the selected class or metaclass."    self metaClassIndicated        ifTrue: [^ self selectedClass class]        ifFalse: [^ self selectedClass]! !!Browser methodsFor: 'metaclass'!setClassOrganizer    "Install whatever organization is appropriate"    classOrganizer _ nil.    metaClassOrganizer _ nil.    classListIndex = 0 ifTrue: [^ self].    self metaClassIndicated        ifTrue: [metaClassOrganizer _ self selectedClass class organization]        ifFalse: [classOrganizer _ self selectedClass organization]! !!Browser class methodsFor: 'instance creation'!newOnClass: aClass     "Open a new class browser on this class."    | index newBrowser |    newBrowser _ Browser new.    newBrowser systemCategoryListIndex:        (index _ SystemOrganization numberOfCategoryOfElement: aClass name).    newBrowser classListIndex: ((SystemOrganization listAtCategoryNumber: index)            findFirst: [:each | each == aClass name]).    newBrowser metaClassIndicated: false.    BrowserView openClassBrowser: newBrowser editString: nil label: 'Class Browser:', aClass name! !!Browser class methodsFor: 'class initialization'!initialize        "Browser initialize"        RecentClasses := OrderedCollection new! !!BrowserCodeController methodsFor: 'menu messages'!explain    "Try to shed some light on what kind of entity the current selection is.     The selection must be a single token or construct. Insert the answer after     the selection. Send private messages whose names begin with 'explain'     that return a string if they recognize the selection, else nil."    | string tiVars cgVars selectors delimitors numbers sorry reply |    Cursor execute        showWhile:             [sorry _ '"Sorry, I can''t explain that.  Please select a single token, construct, or special character.'.            sorry _ sorry , (model isUnlocked                            ifTrue: ['"']                            ifFalse: ['  Also, please cancel or accept."']).            (string _ self selection asString) isEmpty                ifTrue: [reply _ '']                ifFalse:                     [string _ self explainScan: string.                    "Remove space, tab, cr"                    "Temps and Instance vars need only test strings that are                     all                      letters"                    (string detect: [:char | (char isLetter or: [char isDigit]) not]                        ifNone: [])                        ~~ nil                        ifFalse:                             [tiVars _ self explainTemp: string.                            tiVars == nil ifTrue: [tiVars _ self explainInst: string]].                    (tiVars == nil and: [model class == Browser])                        ifTrue: [tiVars _ model explainSpecial: string].                    tiVars == nil                        ifTrue: [tiVars _ '']                        ifFalse: [tiVars _ tiVars , NewLine].                    "Context, Class, Pool, and Global vars, and Selectors need                     only test symbols"                    (Symbol hasInterned: string ifTrue: [:symbol | symbol])                        ifTrue:                             [cgVars _ self explainCtxt: symbol.                            cgVars == nil                                ifTrue:                                     [cgVars _ self explainClass: symbol.                                    cgVars == nil ifTrue: [cgVars _ self explainGlobal: symbol]].                            "See if it is a Selector (sent here or not)"                            selectors _ self explainMySel: symbol.                            selectors == nil                                ifTrue:                                     [selectors _ self explainPartSel: string.                                    selectors == nil ifTrue: [selectors _ self explainAnySel: symbol]]]                        ifFalse: [selectors _ self explainPartSel: string].                    cgVars == nil                        ifTrue: [cgVars _ '']                        ifFalse: [cgVars _ cgVars , NewLine].                    selectors == nil                        ifTrue: [selectors _ '']                        ifFalse: [selectors _ selectors , NewLine].                    string size = 1                        ifTrue: ["single special characters"                            delimitors _ self explainChar: string]                        ifFalse: ["matched delimitors"                            delimitors _ self explainDelimitor: string].                    numbers _ self explainNumber: string.                    numbers == nil ifTrue: [numbers _ ''].                    delimitors == nil ifTrue: [delimitors _ ''].                    reply _ tiVars , cgVars , selectors , delimitors , numbers].            reply size = 0 ifTrue: [reply _ sorry].            self afterSelectionInsertAndSelect: reply]! !!BrowserCodeController methodsFor: 'menu messages'!format    "Reformat the contents of the receiver's view, formatted, if the view is unlocked. "    | selectedClass aCompiler newText locked |    locked _ model isLocked.    model messageListIndex = 0 | locked ifTrue: [^view flash].    selectedClass _ model selectedClassOrMetaClass.    Cursor execute showWhile:         [aCompiler _ selectedClass compilerClass new.        self deselect; selectInvisiblyFrom: 1 to: paragraph text size.        newText _ aCompiler            format: model contents            in: selectedClass            notifying: self.        newText == nil ifFalse:             [self replaceSelectionWith:                (newText asText makeSelectorBoldIn: selectedClass).            self selectAt: 1]].    locked ifFalse: [self unlockModel] ! !!BrowserCodeController methodsFor: 'menu messages'!showBytecodes    "Show the bytecodes of the selected method."    | selectedClass newText |    (model messageListIndex = 0) | (model isLocked) ifTrue: [        ^view flash.    ].    selectedClass _ model selectedClassOrMetaClass.    Cursor execute showWhile: [        self deselect; selectInvisiblyFrom: 1 to: paragraph text size.        newText _ (selectedClass compiledMethodAt: model selectedMessageName) symbolic asText.        self replaceSelectionWith: newText.        self selectAt: 1.    ].    self unlockModel.! !!BrowserCodeController methodsFor: 'private'!explainClass: symbol     "Is symbol a class variable or a pool variable?"    | class reply classes |    class _ model selectedClass.    class == nil ifTrue: [^nil].      "no class is selected"    (class isKindOf: Metaclass) ifTrue: [class _ class soleInstance].    classes _ (Array with: class) , class allSuperclasses.    "class variables"    reply _ classes detect: [:each | (each classVarNames            detect: [:name | symbol = name] ifNone: [])            ~~ nil] ifNone: [].    reply == nil ifFalse: [^'"is a class variable; defined in class ' , reply printString, '"', NewLine,        'Smalltalk browseAllCallsOn: (', reply printString, ' classPool associationAt: #', symbol, ').'].    "pool variables"    classes do: [:each | (each sharedPools            detect: [:pool | (pool includesKey: symbol) and: [reply _ pool. true]]            ifNone: []) ~~ nil].    reply == nil ifTrue: [(Undeclared includesKey: symbol) ifTrue: [reply _ Undeclared]].    reply == nil        ifFalse:             [classes _ WriteStream on: Array new.            Smalltalk allBehaviorsDo: [:each |                    (each sharedPools detect: [:pool | pool == reply] ifNone: [])                    ~~ nil ifTrue: [classes nextPut: each]].            "Perhaps not print whole list of classes if too long. (unlikely)"            ^'"is a pool variable from the pool ' , (Smalltalk keyAtValue: reply),            ', which is used by the following classes ' , classes contents printString , '"', NewLine,            'Smalltalk browseAllCallsOn: (', (Smalltalk keyAtValue: reply) printString,            ' associationAt: #', symbol, ').'].    ^nil! !!BrowserCodeController methodsFor: 'private'!explainDelimitor: string    "Is string enclosed in delimitors?"    | str |    (string at: 1) isLetter ifTrue: [^nil].  "only special chars"    (string first = string last) ifTrue:            [^ self explainChar: (String with: string first)]        ifFalse:            [(string first = $( and: [string last = $)]) ifTrue:                [^ self explainChar: (String with: string first)].            (string first = $[ and: [string last = $]]) ifTrue:                [^ self explainChar: (String with: string first)].            (string first = $< and: [string last = $>]) ifTrue:                [^ self explainChar: (String with: string first)].            (string first = $# and: [string last = $)]) ifTrue:                [^'"An instance of class Array.  The Numbers, Characters, or Symbols between the parenthesis are the elements of the Array."'].            string first = $# ifTrue:                [^'"An instance of class Symbol."'].            (string first = $$ and: [string size = 2]) ifTrue:                [^'"An instance of class Character.  This one is the character ', (String with: string last), '."'].            (string first = $:) ifTrue:                [str _ string allButFirst.                (self explainTemp: str) ~~ nil ifTrue:                    [^'"An argument to this block will be bound to the temporary variable ',                        str, '."']]].    ^ nil! !!BrowserCodeController methodsFor: 'private'!explainGlobal: symbol     "Is symbol a global variable?"    | reply classes |    reply _ Smalltalk at: symbol ifAbsent: [^nil].    (reply isKindOf: Behavior)        ifTrue: [^'"is a global variable.  ' , symbol , ' is a class in category ', reply category,            '."', NewLine, 'Browser newOnClass: ' , symbol , '.'].    symbol == #Smalltalk ifTrue: [^'"is a global.  Smalltalk is the only instance of SystemDictionary and holds all global variables."'].    reply class == Dictionary        ifTrue:             [classes _ Set new.            Smalltalk allBehaviorsDo: [:each | (each sharedPools detect: [:pool | pool == reply]                    ifNone: [])                    ~~ nil ifTrue: [classes add: each]].            classes _ classes printString.            ^'"is a global variable.  ' , symbol , ' is a Dictionary.  It is a pool which is used by the following classes' , (classes copyFrom: 4 to: classes size) , '"'].    ^'"is a global variable.  ' , symbol , ' is ' , reply printString , '"'! !!BrowserCodeController methodsFor: 'private'!explainInst: string     "Is string an instance variable of this class?"    | classes |    model selectedClassOrMetaClass == nil ifTrue: [^nil].      "no class is selected"    classes _ (Array with: model selectedClassOrMetaClass)                , model selectedClassOrMetaClass allSuperclasses.    classes _ classes detect: [:each | (each instVarNames            detect: [:name | name = string] ifNone: [])            ~~ nil] ifNone: [^nil].    classes _ classes printString.    ^ '"is an instance variable of the receiver; defined in class ' , classes , '"',        NewLine , classes , ' browseAllAccessesTo: ''' , string , '''.'! !!BrowserCodeController methodsFor: 'private'!explainPartSel: string     "Is this a fragment of a multiple-argument selector sent in this method?"    | lits whole reply classes s |    model messageListIndex = 0 ifTrue: [^nil].  "not in a message"    string last == $: ifFalse: [^nil].    "Name of this method"    lits _ Array with: model selectedMessageName.    (whole _ lits detect: [:each | (each keywords detect: [:frag | frag = string]                    ifNone: []) ~~ nil]                ifNone: []) ~~ nil        ifTrue: [reply _ ', which is the selector of this very method!!'.            s _ '.  To see the other definitions, go to the message list pane and use yellowbug to select ''implementors''."']        ifFalse:             ["Selectors called from this method"            lits _ (model selectedClassOrMetaClass compiledMethodAt:                model selectedMessageName) messages.            (whole _ lits detect: [:each | (each keywords detect: [:frag | frag = string]                            ifNone: []) ~~ nil]                        ifNone: []) ~~ nil                ifFalse: [string = 'primitive:'                    ifTrue: [^self explainChar: '<']                    ifFalse: [^nil]].            reply _ '.'.            s _ '.  To see the definitions, go to the message list pane and use yellowbug to select ''messages''."'].    classes _ Smalltalk allClassesImplementing: whole.    classes size > 12        ifTrue: [classes _ 'many classes']        ifFalse: [classes _ 'these classes ' , classes printString].    ^ '"' , string , ' is one part of the message selector ' , whole, reply , '  It is defined in ' , classes , s! !!BrowserListView methodsFor: 'updating'!getListAndDisplayView    "Display the list of items."    | newList |    newList _ self getList.    isEmpty & newList isEmpty        ifTrue: [^self]        ifFalse:             [self list: newList.            model maybeSetSelection.            self displayView; emphasizeView]! !!BrowserView class methodsFor: 'instance creation' stamp: 'sw 3/11/96'!instanceBrowserViewOn: aBrowser    "Answer an instance of me on the model, aBrowser, which looks at a user-defined instance-class. The view has three subviews.  "    | browserView  messageCategoryListView messageListView browserCodeView |    browserView _ self new model: aBrowser.    messageCategoryListView _ self buildMessageCategoryListView: aBrowser.    messageListView _ self buildMessageListView: aBrowser.    browserCodeView _ self buildBrowserCodeView: aBrowser editString: nil.    browserView addSubView: messageCategoryListView.    browserView addSubView: messageListView.    browserView addSubView: browserCodeView.    messageListView         align: messageListView viewport topLeft         with: messageCategoryListView viewport topRight.    browserCodeView         window: browserCodeView window         viewport: (messageCategoryListView viewport bottomLeft                     corner: messageListView viewport bottomRight + (0 @ 110)).    ^ browserView! !!ByteArray methodsFor: 'accessing'!asString    "Convert to a String with Characters for each byte.    Fast code uses primitive that avoids character conversion"    ^ (String new: self size) replaceFrom: 1 to: self size with: self! !CachingMorph comment:'This morph can be used to cache the picture of a morph that takes a long time to draw. It should be used with judgement, however, since heavy use of caching can consume large amounts of memory.'!!CachingMorph methodsFor: 'all'!drawOn: aCanvas    submorphs isEmpty ifTrue: [^ super drawOn: aCanvas].! !!CachingMorph methodsFor: 'all'!fullDrawOn: aCanvas    self updateCacheCanvasDepth: aCanvas depth.    aCanvas image: cacheCanvas form at: self fullBounds origin.! !!CachingMorph methodsFor: 'all'!imageForm    self updateCacheCanvasDepth: Display depth.    ^ cacheCanvas form offset: self fullBounds topLeft! !!CachingMorph methodsFor: 'all'!initialize    super initialize.    color _ Color veryLightGray.    damageRecorder _ DamageRecorder new.! !!CachingMorph methodsFor: 'all'!invalidRect: damageRect    "Record the given rectangle in the damage list."    damageRecorder recordInvalidRect: (damageRect translateBy: self fullBounds origin negated).    super invalidRect: damageRect.! !!CachingMorph methodsFor: 'all'!prepareToBeSaved    super prepareToBeSaved.    cacheCanvas _ nil.! !!CachingMorph methodsFor: 'all'!updateCacheCanvasDepth: depth    "Update the cached image of the morphs being held by this hand."    | myBnds rectList c |    myBnds _ self fullBounds.    (cacheCanvas == nil or: [cacheCanvas extent ~= myBnds extent]) ifTrue: [        cacheCanvas _ FormCanvas extent: myBnds extent depth: depth.        c _ cacheCanvas copyOffset: myBnds origin negated.        ^ super fullDrawOn: c].    "incrementally update the cache canvas"    rectList _ damageRecorder invalidRectsFullBounds: (0@0 extent: myBnds extent).    rectList do: [:r |        c _ cacheCanvas copyOrigin: myBnds origin negated clipRect: r.        c fillColor: Color transparent.  "clear to transparent"        super fullDrawOn: c].    damageRecorder reset.! !Canvas comment:'A canvas is a two-dimensional medium on which morphs are drawn in a device-independent manner. Canvases keep track of the origin and clipping rectangle, as well as the underlying drawing medium (such as a window, pixmap, or postscript script).This kind of canvas does no drawing, and may be used as a "null canvas" to factor out drawing time during performance measurements.'!!Canvas methodsFor: 'initialization'!reset    origin _ 0@0.                            "origin of the top-left corner of this cavas"    clipRect _ (0@0 corner: 10000@10000).        "default clipping rectangle"    shadowDrawing _ false.                    "draw translucent shadows when true"! !!Canvas methodsFor: 'copying'!copyClipRect: aRectangle    ^ self copyOrigin: origin clipRect: (aRectangle translateBy: origin)! !!Canvas methodsFor: 'copying'!copyForShadowDrawingOffset: aPoint    ^ (self copyOrigin: origin + aPoint clipRect: clipRect) setShadowDrawing! !!Canvas methodsFor: 'copying'!copyOffset: aPoint    ^ self copyOrigin: origin + aPoint clipRect: clipRect! !!Canvas methodsFor: 'copying'!copyOffset: aPoint clipRect: sourceClip    "Make a copy of me offset by aPoint, and further clipped    by sourceClip, a rectangle in the un-offset coordinates"    ^ self copyOrigin: aPoint + origin        clipRect: ((sourceClip translateBy: origin) intersect: clipRect)! !!Canvas methodsFor: 'copying'!copyOrigin: aPoint clipRect: aRectangle    "Return a copy of this canvas with the given origin. The clipping rectangle of this canvas is the intersection of the given rectangle and the receiver's current clipping rectangle. This allows the clipping rectangles of nested clipping morphs to be composed."    ^ self copy        setOrigin: aPoint        clipRect: (clipRect intersect: aRectangle)! !!Canvas methodsFor: 'accessing'!clipRect    ^ clipRect translateBy: origin negated! !!Canvas methodsFor: 'accessing'!depth    ^ Display depth! !!Canvas methodsFor: 'accessing'!origin    ^ origin! !!Canvas methodsFor: 'testing'!isVisible: aRectangle    "Optimization of: ^ clipRect intersects: (aRectangle translateBy: origin)"    ^ ((aRectangle right + origin x) < clipRect left or:      [(aRectangle left + origin x) > clipRect right or:      [(aRectangle bottom + origin y) < clipRect top or:      [(aRectangle top + origin y) > clipRect bottom]]]) not! !!Canvas methodsFor: 'drawing'!fillColor: c    "Noop here; overridden by non-trivial canvases."! !!Canvas methodsFor: 'drawing'!fillOval: r color: c    "Noop here; overridden by non-trivial canvases."! !!Canvas methodsFor: 'drawing'!fillPolygon: pointList color: c    "Noop here; overridden by non-trivial canvases."! !!Canvas methodsFor: 'drawing'!fillRectangle: r color: c    "Noop here; overridden by non-trivial canvases."! !!Canvas methodsFor: 'drawing'!fillWedge: r startDegrees: startDegrees spanning: spanDegrees color: c    "Noop here; overridden by non-trivial canvases."! !!Canvas methodsFor: 'drawing'!frameOval: r color: c    self frameOval: r width: 1 color: c.! !!Canvas methodsFor: 'drawing'!frameOval: r width: w color: c    "Noop here; overridden by non-trivial canvases."! !!Canvas methodsFor: 'drawing'!framePolygon: pointList color: c    self framePolygon: pointList width: 1 color: c.! !!Canvas methodsFor: 'drawing'!framePolygon: pointList width: w color: c    "Noop here; overridden by non-trivial canvases."! !!Canvas methodsFor: 'drawing'!frameRectangle: r color: c    self frameRectangle: r width: 1 color: c.! !!Canvas methodsFor: 'drawing'!frameRectangle: r width: w color: c    "Noop here; overridden by non-trivial canvases."! !!Canvas methodsFor: 'drawing'!frameWedge: r startDegrees: startDegrees spanning: spanDegrees color: c    self frameWedge: r startDegrees: startDegrees spanning: spanDegrees width: 1 color: c.! !!Canvas methodsFor: 'drawing'!frameWedge: r startDegrees: startDegrees spanning: spanDegrees width: w color: c    "Noop here; overridden by non-trivial canvases."! !!Canvas methodsFor: 'drawing'!image: i at: aPoint    "Noop here; overridden by non-trivial canvases."! !!Canvas methodsFor: 'drawing'!line: pt1 to: pt2 color: c    self line: pt1 to: pt2 width: 1 color: c.! !!Canvas methodsFor: 'drawing'!line: pt1 to: pt2 width: w color: c    "Noop here; overridden by non-trivial canvases."! !!Canvas methodsFor: 'drawing'!paragraph: paragraph bounds: bounds color: c    "Noop here; overridden by non-trivial canvases."! !!Canvas methodsFor: 'drawing'!point: p color: c    "Noop here; overridden by non-trivial canvases."! !!Canvas methodsFor: 'drawing'!text: s at: pt font: fontOrNil color: c    "Support only for vestigial test methods"    ^ self text: s bounds: (pt extent: 999@99) font: fontOrNil color: c! !!Canvas methodsFor: 'form copy/paste'!copyFormAt: aPoint extent: aRectangle    "Answer a Form containing a rectangular portion of this canvas. This operation may not be supported on all kinds of canvases. (For example, it does not work on a null canvas and may not work on a write-only Postscript canvas.)"    self error: 'This canvas does not support image capture'.! !!Canvas methodsFor: 'form copy/paste'!pasteForm: aForm at: p    "Copy the given pixmap onto this canvas at the given point."    self unimplemented.! !!Canvas methodsFor: 'form copy/paste'!pasteForm: aForm at: aPoint src: srcPt width: w height: h    "Extract and copy a rectanglar portion of the given Form onto this canvas."    self unimplemented.! !!Canvas methodsFor: 'private'!setOrigin: aPoint clipRect: aRectangle    origin _ aPoint.    clipRect _ aRectangle.! !!Canvas methodsFor: 'private'!setShadowDrawing    "Put this canvas into 'shadow drawing' mode, which is used to draw translucent shadows. While in this mode, all drawing operations are done in black through a gray mask. The mask allows some of the underlying pixels to show through, providing a crude sense of transparency."    shadowDrawing _ true.! !!CascadeNode methodsFor: 'C translation'!asTranslatorNode    ^TStmtListNode new        setArguments: #()        statements: (messages collect:            [ :msg | msg asTranslatorNode receiver: receiver asTranslatorNode ])! !CCodeGenerator comment:'This class oversees the translation of a subset of Smalltalk to C, allowing the comforts of Smalltalk during development and the efficiency and portability of C for the resulting interpreter.  Executing    Interpreter translate: ''InterpTest.c'' doInlining: true.(with single quotes) will cause all the methods of Interpreter, ObjectMemory and BitBltSimulation to be translated to C, and stored in the named file.  This file together with the files emitted by InterpreterSupportCode (qv) should be adequate to produce a complete interpreter for the Macintosh environment.'!!CCodeGenerator methodsFor: 'public'!addClass: aClass    "Add the variables and methods of the given class to the code base."    | source |    self checkClassForNameConflicts: aClass.    aClass classPool associationsDo: [ :assoc |        constants at: assoc key put: (TConstantNode new setValue: assoc value).    ].    variables addAll: aClass instVarNames.'Adding Class ' , aClass name , '...'displayProgressAt: Sensor cursorPointfrom: 0 to: aClass selectors sizeduring: [:bar |    aClass selectors doWithIndex: [ :sel :i | bar value: i.        source _ aClass sourceCodeAt: sel.        self addMethod: ((Compiler new parse: source in: aClass notifying: nil) asTMethodFromClass: aClass).    ]].! !!CCodeGenerator methodsFor: 'public'!codeString    "Return a string containing all the C code for the code base. Used for testing."    | stream |    stream _ ReadWriteStream on: (String new: 1000).    self emitCCodeOn: stream doInlining: true.    ^stream contents! !!CCodeGenerator methodsFor: 'public'!codeStringForPrimitives: classAndSelectorList    "CCodeGenerator new codeStringForPrimitives: #(        (FMSound mixSampleCount:into:startingAt:)    )"    | sel aClass source s verbose meth |    self initialize.    classAndSelectorList do: [ :classAndSelector |        aClass _ Smalltalk at: (classAndSelector at: 1).        sel _ classAndSelector at: 2.        source _ aClass sourceCodeAt: sel.        meth _ ((Compiler new parse: source in: aClass notifying: nil)                asTMethodFromClass: aClass).        meth preparePrimitiveInClass: aClass.        self addMethod: meth.    ].    s _ ReadWriteStream on: (String new: 1000).    "method preparation"    verbose _ false.    self prepareMethods.    verbose ifTrue: [        self printUnboundCallWarnings.        self printUnboundVariableReferenceWarnings.        Transcript cr.    ].    "code generation"    methods _ methods asSortedCollection: [ :m1 :m2 | m1 selector < m2 selector ].    self emitCHeaderForPrimitivesOn: s.    self emitCVariablesOn: s.    self emitCFunctionPrototypesOn: s.    methods do: [ :m | m emitCCodeOn: s generator: self ].    ^ s contents! !!CCodeGenerator methodsFor: 'public'!globalsAsSet    "Used by the inliner to avoid name clashes with global variables."    ((variablesSetCache == nil) or:     [variablesSetCache size ~= variables size]) ifTrue: [        variablesSetCache _ variables asSet.    ].    ^ variablesSetCache! !!CCodeGenerator methodsFor: 'public'!initialize    translationDict _ Dictionary new.    inlineList _ Array new.    constants _ Dictionary new.    variables _ OrderedCollection new.    variableDeclarations _ Dictionary new.    methods _ Dictionary new.    self initializeCTranslationDictionary.! !!CCodeGenerator methodsFor: 'public' stamp: 'jm 9/21/97 18:07'!storeCodeOnFile: fileName doInlining: inlineFlag    "Store C code for this code base on the given file."    | stream |    stream _ FileStream newFileNamed: fileName.    self emitCCodeOn: stream doInlining: inlineFlag.    stream close.! !!CCodeGenerator methodsFor: 'public'!var: varName declareC: declarationString    "Record the given C declaration for a global variable."    variableDeclarations at: varName put: declarationString.! !!CCodeGenerator methodsFor: 'error notification'!checkClassForNameConflicts: aClass    "Verify that the given class does not have constant, variable, or method names that conflict with those of previously added classes. Raise an error if a conflict is found, otherwise just return."    "check for constant name collisions"    aClass classPool associationsDo: [ :assoc |        (constants includesKey: assoc key) ifTrue: [            self error: 'Constant was defined in a previously added class: ', assoc key.        ].    ].    "check for instance variable name collisions"    aClass instVarNames do: [ :varName |        (variables includes: varName) ifTrue: [            self error: 'Instance variable was defined in a previously added class: ', varName.        ].    ].    "check for method name collisions"    aClass selectors do: [ :sel |        (methods includesKey: sel) ifTrue: [            self error: 'Method was defined in a previously added class: ', sel.        ].    ].! !!CCodeGenerator methodsFor: 'error notification'!printUnboundCallWarnings    "Print a warning message for every unbound method call in the code base."    | knownSelectors undefinedCalls |    undefinedCalls _ Dictionary new.    knownSelectors _ translationDict keys asSet.    knownSelectors add: #error:.    methods do: [ :m | knownSelectors add: m selector ].    methods do: [ :m |        m allCalls do: [ :sel |            (knownSelectors includes: sel) ifFalse: [                (undefinedCalls includesKey: sel)                    ifTrue: [ (undefinedCalls at: sel) add: m selector ]                    ifFalse: [ undefinedCalls at: sel put: (OrderedCollection with: m selector) ].            ].        ].    ].    Transcript cr.    undefinedCalls keys asSortedCollection do: [ :undefined |        Transcript show: undefined, ' -- undefined method sent by:'; cr.        (undefinedCalls at: undefined) do: [ :caller |            Transcript tab; show: caller; cr.        ].    ].! !!CCodeGenerator methodsFor: 'error notification'!printUnboundVariableReferenceWarnings    "Print a warning message for every unbound variable reference in the code base."    | undefinedRefs globalVars knownVars |    undefinedRefs _ Dictionary new.    globalVars _ Set new: 100.    globalVars addAll: variables.    methods do: [ :m |        knownVars _ globalVars copy.        m args do: [ :var | knownVars add: var ].        m locals do: [ :var | knownVars add: var ].        m freeVariableReferences do: [ :varName |            (knownVars includes: varName) ifFalse: [                (undefinedRefs includesKey: varName)                    ifTrue: [ (undefinedRefs at: varName) add: m selector ]                    ifFalse: [ undefinedRefs at: varName put: (OrderedCollection with: m selector) ].            ].        ].    ].    Transcript cr.    undefinedRefs keys asSortedCollection do: [ :var |        Transcript show: var, ' -- undefined variable used in:'; cr.        (undefinedRefs at: var) do: [ :sel |            Transcript tab; show: sel; cr.        ].    ].! !!CCodeGenerator methodsFor: 'inlining'!collectInlineList    "Make a list of methods that should be inlined."    "Details: The method must not include any inline C, since the translator cannot currently map variable names in inlined C code. Methods to be inlined must be small or called from only one place."    | methodsNotToInline callsOf inlineIt hasCCode nodeCount senderCount |    methodsNotToInline _ Set new: methods size.    "build dictionary to record the number of calls to each method"    callsOf _ Dictionary new: methods size * 2.    methods keys do: [ :sel | callsOf at: sel put: 0 ].    "For each method, scan its parse tree once to:        1. determine if the method contains C code or declarations        2. determine how many nodes it has        3. increment the sender counts of the methods it calls        4. determine if it includes any C declarations or code"    inlineList _ Set new: methods size * 2.    methods do: [ :m |        inlineIt _ #dontCare.        (translationDict includesKey: m selector) ifTrue: [            hasCCode _ true.        ] ifFalse: [            hasCCode _ m declarations size > 0.            nodeCount _ 0.            m parseTree nodesDo: [ :node |                node isSend ifTrue: [                    sel _ node selector.                    sel = #cCode: ifTrue: [ hasCCode _ true ].                    senderCount _ callsOf at: sel ifAbsent: [ nil ].                    nil = senderCount ifFalse: [                        callsOf at: sel put: senderCount + 1.                    ].                ].                nodeCount _ nodeCount + 1.            ].            inlineIt _ m extractInlineDirective.  "may be true, false, or #dontCare"        ].        (hasCCode or: [inlineIt = false]) ifTrue: [            "don't inline if method has C code and is contains negative inline directive"            methodsNotToInline add: m selector.        ] ifFalse: [            ((nodeCount < 40) or: [inlineIt = true]) ifTrue: [                "inline if method has no C code and is either small or contains inline directive"                inlineList add: m selector.            ].        ].    ].    callsOf associationsDo: [ :assoc |        ((assoc value = 1) and: [(methodsNotToInline includes: assoc key) not]) ifTrue: [            inlineList add: assoc key.        ].    ].! !!CCodeGenerator methodsFor: 'inlining'!doInlining    "Inline the bodies of all methods that are suitable for inlining."    "Interpreter translate: 'InterpTest.c' doInlining: true"    | pass progress |    self collectInlineList.    "xxx do we need the following?"    Interpreter primitiveTable do: [ :sel |        inlineList remove: sel ifAbsent: [].    ].    pass _ 0.    progress _ true.    [progress] whileTrue: [        "repeatedly attempt to inline methods until no further progress is made"        progress _ false.        ('Inlining pass ', (pass _ pass + 1) printString, '...')            displayProgressAt: Sensor cursorPoint            from: 0 to: methods size            during: [ :bar |                methods doWithIndex: [ :m :i |                    bar value: i.                    (m tryToInlineMethodsIn: self)                        ifTrue: [progress _ true]]].    ].    'Inlining bytecodes'        displayProgressAt: Sensor cursorPoint        from: 1 to: 2        during: [ :bar |            self inlineDispatchesInMethodNamed: #interpret                localizingVars: #(currentBytecode localIP localSP).            bar value: 1.            self removeMethodsReferingToGlobals: #(currentBytecode localIP localSP)                except: #interpret.            bar value: 2.    ].! !!CCodeGenerator methodsFor: 'inlining'!inlineDispatchesInMethodNamed: selector localizingVars: varsList    "Inline dispatches (case statements) in the method with the given name."    | m |    m _ self methodNamed: selector.    m = nil ifFalse: [        m inlineCaseStatementBranchesIn: self localizingVars: varsList.        m parseTree nodesDo: [ :n |            n isCaseStmt ifTrue: [                n customizeShortCasesForDispatchVar: #currentBytecode.            ].        ].    ].    variables _ variables asOrderedCollection.    varsList do: [ :v |        variables remove: v asString ifAbsent: [].        (variableDeclarations includesKey: v asString) ifTrue: [            m declarations at: v asString put: (variableDeclarations at: v asString).            variableDeclarations removeKey: v asString.        ].    ].! !!CCodeGenerator methodsFor: 'inlining'!mayInline: sel    "Answer true if the method with the given selector may be inlined."    ^ inlineList includes: sel! !!CCodeGenerator methodsFor: 'inlining'!methodStatsString    "Return a string describing the size, # of locals, and # of senders of each method. Note methods that have inline C code or C declarations."    | methodsWithCCode sizesOf callsOf hasCCode nodeCount senderCount s calls registers selr |    methodsWithCCode _ Set new: methods size.    sizesOf _ Dictionary new: methods size * 2.  "selector -> nodeCount"    callsOf _ Dictionary new: methods size * 2.  "selector -> senderCount"    "For each method, scan its parse tree once to:        1. determine if the method contains C code or declarations        2. determine how many nodes it has        3. increment the sender counts of the methods it calls        4. determine if it includes any C declarations or code"    methods do: [ :m |        (translationDict includesKey: m selector) ifTrue: [            hasCCode _ true.        ] ifFalse: [            hasCCode _ m declarations size > 0.            nodeCount _ 0.            m parseTree nodesDo: [ :node |                node isSend ifTrue: [                    selr _ node selector.                    selr = #cCode: ifTrue: [ hasCCode _ true ].                    senderCount _ callsOf at: selr ifAbsent: [ 0 ].                    callsOf at: selr put: senderCount + 1.                ].                nodeCount _ nodeCount + 1.            ].        ].        hasCCode ifTrue: [ methodsWithCCode add: m selector ].        sizesOf at: m selector put: nodeCount.    ].    s _ WriteStream on: (String new: 5000).    methods keys asSortedCollection do: [ :sel |        m _ methods at: sel.        registers _ m locals size + m args size.        calls _ callsOf at: sel ifAbsent: [0].        registers > 11 ifTrue: [            s nextPutAll: sel; tab.            s nextPutAll: (sizesOf at: sel) printString; tab.            s nextPutAll: calls printString; tab.            s nextPutAll: registers printString; tab.            (methodsWithCCode includes: sel) ifTrue: [ s nextPutAll: 'CCode' ].        s cr.        ].    ].    ^ s contents! !!CCodeGenerator methodsFor: 'inlining'!removeMethodsReferingToGlobals: varList except: methodName    "Remove any methods (presumably inlined) that still contain references to the given obsolete global variables."    | varListAsStrings removeIt mVars |    varListAsStrings _ varList collect: [ :sym | sym asString ].    methods keys copy do: [ :sel |        removeIt _ false.        mVars _ (self methodNamed: sel) freeVariableReferences asSet.        varListAsStrings do: [ :v |            (mVars includes: v) ifTrue: [ removeIt _ true ].        ].        (removeIt and: [sel ~= methodName]) ifTrue: [            methods removeKey: sel ifAbsent: [].        ].    ].! !!CCodeGenerator methodsFor: 'utilities'!addMethod: aTMethod    "Add the given method to the code base."    (methods includesKey:  aTMethod selector) ifTrue: [        self error: 'Method name conflict: ', aTMethod selector.    ].    methods at: aTMethod selector put: aTMethod.! !!CCodeGenerator methodsFor: 'utilities'!builtin: sel    "Answer true if the given selector is one of the builtin selectors."    ((sel = #longAt:) or: [(sel = #longAt:put:) or: [sel = #error:]]) ifTrue: [ ^true ].    ((sel = #byteAt:) or: [sel = #byteAt:put:]) ifTrue: [ ^true ].    ^translationDict includesKey: sel! !!CCodeGenerator methodsFor: 'utilities'!cCodeForMethod: selector    "Answer a string containing the C code for the given method."    "Example:        ((CCodeGenerator new initialize addClass: TestCClass1; prepareMethods)            cCodeForMethod: #ifTests)"    | m s |    m _ self methodNamed: selector.    m = nil ifTrue: [ self error: 'method not found in code base: ', selector ].    s _ (ReadWriteStream on: '').    m emitCCodeOn: s generator: self.    ^ s contents! !!CCodeGenerator methodsFor: 'utilities'!emitBuiltinConstructFor: msgNode on: aStream level: level    "If the given selector is in the translation dictionary, translate it into a target code construct and return true. Otherwise, do nothing and return false."    | action |    action _ translationDict at: msgNode selector ifAbsent: [ ^false ].    self perform: action with: msgNode with: aStream with: level.    ^true! !!CCodeGenerator methodsFor: 'utilities'!methodNamed: selector    "Answer the method in the code base with the given selector."    ^ methods at: selector ifAbsent: [ nil ]! !!CCodeGenerator methodsFor: 'utilities'!methodsReferringToGlobal: v    "Return a collection of methods that refer to the given global variable."    | out |    out _ OrderedCollection new.    methods associationsDo: [ :assoc |        (assoc value freeVariableReferences includes: v) ifTrue: [            out add: assoc key.        ].    ].    ^ out! !!CCodeGenerator methodsFor: 'utilities'!methodsThatCanInvoke: aSelectorList    "Return a set of methods that can invoke one of the given selectors, either directly or via a sequence of intermediate methods."    | out todo sel mSelector |    out _ Set new.    todo _ aSelectorList copy asOrderedCollection.    [todo isEmpty] whileFalse: [        sel _ todo removeFirst.        out add: sel.        methods do: [ :m |            (m allCalls includes: sel) ifTrue: [                mSelector _ m selector.                ((out includes: mSelector) or:                 [todo includes: mSelector]) ifFalse: [                    todo add: mSelector.                ].            ].        ].    ].    ^ out    ! !!CCodeGenerator methodsFor: 'utilities'!prepareMethods    "Prepare methods for browsing."    | globals |    globals _ Set new: 200.    globals addAll: variables.    methods do: [ :m |        (m locals, m args) do: [ :var |            (globals includes: var) ifTrue: [                self error: 'Local variable name may mask global when inlining: ', var.            ].            (methods includesKey: var) ifTrue: [                self error: 'Local variable name may mask method when inlining: ', var.            ].            ].        m bindClassVariablesIn: constants.        m prepareMethodIn: self.    ].! !!CCodeGenerator methodsFor: 'utilities'!reportRecursiveMethods    "Report in transcript all methods that can call themselves directly or indirectly or via a chain of N intermediate methods."    | visited calls newCalls sel called |    methods do: [: m |        visited _ translationDict keys asSet.        calls _ m allCalls asOrderedCollection.        5 timesRepeat: [            newCalls _ Set new: 50.            [calls isEmpty] whileFalse: [                sel _ calls removeFirst.                sel = m selector ifTrue: [                    Transcript show: m selector, ' is recursive'; cr.                ] ifFalse: [                    (visited includes: sel) ifFalse: [                        called _ self methodNamed: sel.                        called = nil ifFalse: [ newCalls addAll: called allCalls ].                    ].                    visited add: sel.                ].            ].            calls _ newCalls asOrderedCollection.        ].    ].! !!CCodeGenerator methodsFor: 'utilities'!unreachableMethods    "Return a collection of methods that are never invoked."    | sent out |    sent _ Set new.    methods do: [ :m |        sent addAll: m allCalls.    ].    out _ OrderedCollection new.    methods keys do: [ :sel |        (sent includes: sel) ifFalse: [ out add: sel ].    ].    ^ out! !!CCodeGenerator methodsFor: 'C code generator'!cFunctionNameFor: aSelector    "Create a C function name from the given selector by omitting colons."    ^aSelector copyWithout: $:! !!CCodeGenerator methodsFor: 'C code generator'!cLiteralFor: anObject    "Return a string representing the C literal value for the given object."    | s |    (anObject isKindOf: Integer) ifTrue: [^ anObject printString ].    (anObject isKindOf: String) ifTrue: [^ '"', anObject, '"' ].    (anObject isKindOf: Float) ifTrue: [^ anObject printString ].    anObject == nil ifTrue: [^ 'null' ].    Transcript show:        'Warning: A Smalltalk literal could not be translated into a C constant'; cr.    ^'"XXX UNTRANSLATABLE CONSTANT XXX"'! !!CCodeGenerator methodsFor: 'C code generator'!emitCCodeOn: aStream doInlining: inlineFlag    "Emit C code for all methods in the code base onto the given stream. All inlined method calls should already have been expanded."    | verbose |    "method preparation"    verbose _ false.    self prepareMethods.    verbose ifTrue: [        self printUnboundCallWarnings.        self printUnboundVariableReferenceWarnings.        Transcript cr.    ].    inlineFlag ifTrue: [ self doInlining ].    "code generation"    methods _ methods asSortedCollection: [ :m1 :m2 | m1 selector < m2 selector ].    self emitCHeaderOn: aStream.    self emitCVariablesOn: aStream.    self emitCFunctionPrototypesOn: aStream.'Writing Translated Code...'displayProgressAt: Sensor cursorPointfrom: 0 to: methods sizeduring: [:bar |    methods doWithIndex: [ :m :i | bar value: i.        m emitCCodeOn: aStream generator: self.]].! !!CCodeGenerator methodsFor: 'C code generator'!emitCExpression: aParseNode on: aStream    "Emit C code for the expression described by the given parse node."    aParseNode isLeaf ifTrue: [        "omit parens"        aParseNode emitCCodeOn: aStream level: 0 generator: self.    ] ifFalse: [        aStream nextPut: $(.        aParseNode emitCCodeOn: aStream level: 0 generator: self.        aStream nextPut: $).    ].! !!CCodeGenerator methodsFor: 'C code generator'!emitCFunctionPrototypesOn: aStream    "Store prototype declarations for all non-inlined methods on the given stream."    aStream nextPutAll: '/*** Function Prototypes ***/'; cr.    methods do: [ :m |        m emitCFunctionPrototype: aStream generator: self.        aStream nextPutAll: ';'; cr.    ].! !!CCodeGenerator methodsFor: 'C code generator'!emitCHeaderForPrimitivesOn: aStream    "Write a C file header for compiled primitives onto the given stream."    aStream nextPutAll: '/* Automatically generated from Squeak on '.    aStream nextPutAll: Time dateAndTimeNow printString.    aStream nextPutAll: ' */'; cr; cr.    aStream nextPutAll: '#include "sq.h"'; cr; cr.    aStream nextPutAll: '/* Memory Access Macros */#define byteAt(i) (*((unsigned char *) (i)))#define byteAtput(i, val) (*((unsigned char *) (i)) = val)#define longAt(i) (*((int *) (i)))#define longAtput(i, val) (*((int *) (i)) = val)/*** Imported Variables ***/extern int stackPointer;extern int successFlag;'.    aStream cr.! !!CCodeGenerator methodsFor: 'C code generator'!emitCHeaderOn: aStream    "Write a C file header onto the given stream."    aStream nextPutAll: '/* Automatically generated from Squeak on '.    aStream nextPutAll: Time dateAndTimeNow printString.    aStream nextPutAll: ' */'; cr; cr.    aStream nextPutAll: '#include "sq.h"'; cr; cr.    aStream nextPutAll: '/* memory access macros */#define byteAt(i) (*((unsigned char *) (i)))#define byteAtput(i, val) (*((unsigned char *) (i)) = val)#define longAt(i) (*((int *) (i)))#define longAtput(i, val) (*((int *) (i)) = val)int printCallStack(void);void error(char *s);void error(char *s) {    /* Print an error message and exit. */    static int printingStack = false;    printf("\n%s\n\n", s);    if (!!printingStack) {        /* flag prevents recursive error when trying to print a broken stack */        printingStack = true;        printCallStack();    }    exit(-1);}'.    aStream cr.! !!CCodeGenerator methodsFor: 'C code generator'!emitCTestBlock: aBlockNode on: aStream    "Emit C code for the given block node to be used as a loop test."    aBlockNode statements size > 1 ifTrue: [        aBlockNode emitCCodeOn: aStream level: 0 generator: self.    ] ifFalse: [        aBlockNode statements first emitCCodeOn: aStream level: 0 generator: self.    ].! !!CCodeGenerator methodsFor: 'C code generator'!emitCVariablesOn: aStream    "Store the global variable declarations on the given stream."    aStream nextPutAll: '/*** Variables ***/'; cr.    variables asSortedCollection do: [ :var |        (variableDeclarations includesKey: var) ifTrue: [            aStream nextPutAll: (variableDeclarations at: var), ';'; cr.        ] ifFalse: [            "default variable declaration"            aStream nextPutAll: 'int ', var, ';'; cr.        ].    ].    aStream cr.! !!CCodeGenerator methodsFor: 'C translation'!generateAnd: msgNode on: aStream indent: level    "Generate the C code for this message onto the given stream."    self emitCExpression: msgNode receiver on: aStream.    aStream nextPutAll: ' && '.    self emitCExpression: msgNode args first on: aStream.! !!CCodeGenerator methodsFor: 'C translation'!generateAt: msgNode on: aStream indent: level    "Generate the C code for this message onto the given stream."    self emitCExpression: msgNode receiver on: aStream.    aStream nextPutAll: '['.    msgNode args first emitCCodeOn: aStream level: level generator: self.    aStream nextPutAll: ']'.! !!CCodeGenerator methodsFor: 'C translation'!generateAtPut: msgNode on: aStream indent: level    "Generate the C code for this message onto the given stream."    self emitCExpression: msgNode receiver on: aStream.    aStream nextPutAll: '['.    msgNode args first emitCCodeOn: aStream level: level generator: self.    aStream nextPutAll: '] = '.    self emitCExpression: msgNode args last on: aStream.! !!CCodeGenerator methodsFor: 'C translation'!generateBitAnd: msgNode on: aStream indent: level    "Generate the C code for this message onto the given stream."    self emitCExpression: msgNode receiver on: aStream.    aStream nextPutAll: ' & '.    self emitCExpression: msgNode args first on: aStream.! !!CCodeGenerator methodsFor: 'C translation'!generateBitInvert32: msgNode on: aStream indent: level    "Generate the C code for this message onto the given stream."    aStream nextPutAll: '~'.    self emitCExpression: msgNode receiver on: aStream.! !!CCodeGenerator methodsFor: 'C translation'!generateBitOr: msgNode on: aStream indent: level    "Generate the C code for this message onto the given stream."    self emitCExpression: msgNode receiver on: aStream.    aStream nextPutAll: ' | '.    self emitCExpression: msgNode args first on: aStream.! !!CCodeGenerator methodsFor: 'C translation'!generateBitShift: msgNode on: aStream indent: level    "Generate the C code for this message onto the given stream."    | arg rcvr |    arg _ msgNode args first.    rcvr _ msgNode receiver.    arg isConstant ifTrue: [        "bit shift amount is a constant"        aStream nextPutAll: '((unsigned) '.        self emitCExpression: rcvr on: aStream.        arg value < 0 ifTrue: [            aStream nextPutAll: ' >> ', arg value negated printString.        ] ifFalse: [            aStream nextPutAll: ' << ', arg value printString.        ].        aStream nextPutAll: ')'.    ] ifFalse: [        "bit shift amount is an expression"        aStream nextPutAll: '(('.        self emitCExpression: arg on: aStream.        aStream nextPutAll: ' < 0) ? ((unsigned) '.        self emitCExpression: rcvr on: aStream.        aStream nextPutAll: ' >> -'.        self emitCExpression: arg on: aStream.        aStream nextPutAll: ') : ((unsigned) '.        self emitCExpression: rcvr on: aStream.        aStream nextPutAll: ' << '.        self emitCExpression: arg on: aStream.        aStream nextPutAll: '))'.    ].! !!CCodeGenerator methodsFor: 'C translation'!generateBitXor: msgNode on: aStream indent: level    "Generate the C code for this message onto the given stream."    self emitCExpression: msgNode receiver on: aStream.    aStream nextPutAll: ' ^ '.    self emitCExpression: msgNode args first on: aStream.! !!CCodeGenerator methodsFor: 'C translation'!generateCCoercion: msgNode on: aStream indent: level    "Generate the C code for this message onto the given stream."    aStream nextPutAll: '(('.    aStream nextPutAll: msgNode args last value.    aStream nextPutAll: ') '.    self emitCExpression: msgNode args first on: aStream.    aStream nextPutAll: ')'.! !!CCodeGenerator methodsFor: 'C translation'!generateDivide: msgNode on: aStream indent: level    "Generate the C code for this message onto the given stream."    self emitCExpression: msgNode receiver on: aStream.    aStream nextPutAll: ' / '.    self emitCExpression: msgNode args first on: aStream.! !!CCodeGenerator methodsFor: 'C translation'!generateEqual: msgNode on: aStream indent: level    "Generate the C code for this message onto the given stream."    self emitCExpression: msgNode receiver on: aStream.    aStream nextPutAll: ' == '.    self emitCExpression: msgNode args first on: aStream.! !!CCodeGenerator methodsFor: 'C translation'!generateGreaterThan: msgNode on: aStream indent: level    "Generate the C code for this message onto the given stream."    self emitCExpression: msgNode receiver on: aStream.    aStream nextPutAll: ' > '.    self emitCExpression: msgNode args first on: aStream.! !!CCodeGenerator methodsFor: 'C translation'!generateGreaterThanOrEqual: msgNode on: aStream indent: level    "Generate the C code for this message onto the given stream."    self emitCExpression: msgNode receiver on: aStream.    aStream nextPutAll: ' >= '.    self emitCExpression: msgNode args first on: aStream.! !!CCodeGenerator methodsFor: 'C translation'!generateIfFalse: msgNode on: aStream indent: level    "Generate the C code for this message onto the given stream."    "Note: PP 2.3 compiler produces two arguments for ifFalse:, presumably     to help with inlining later. Taking the last agument should do the correct     thing even if your compiler is different."    aStream nextPutAll: 'if (!!('.    msgNode receiver emitCCodeOn: aStream level: level generator: self.    aStream nextPutAll: ')) {'; cr.    msgNode args last emitCCodeOn: aStream level: level + 1 generator: self.    level timesRepeat: [ aStream tab ].    aStream nextPutAll: '}'.! !!CCodeGenerator methodsFor: 'C translation'!generateIfFalseIfTrue: msgNode on: aStream indent: level    "Generate the C code for this message onto the given stream."    "Note: PP 2.3 compiler reverses the argument blocks for ifFalse:ifTrue:,       presumably to help with inlining later. That is, the first argument       is the block to be evaluated if the condition is true."    aStream nextPutAll: 'if ('.    msgNode receiver emitCCodeOn: aStream level: level generator: self.    aStream nextPutAll: ') {'; cr.    msgNode args first emitCCodeOn: aStream level: level + 1 generator: self.    level timesRepeat: [ aStream tab ].    aStream nextPutAll: '} else {'; cr.    msgNode args last emitCCodeOn: aStream level: level + 1 generator: self.    level timesRepeat: [ aStream tab ].    aStream nextPutAll: '}'.! !!CCodeGenerator methodsFor: 'C translation'!generateIfTrue: msgNode on: aStream indent: level    "Generate the C code for this message onto the given stream."    aStream nextPutAll: 'if ('.    msgNode receiver emitCCodeOn: aStream level: level generator: self.    aStream nextPutAll: ') {'; cr.    msgNode args first emitCCodeOn: aStream level: level + 1 generator: self.    level timesRepeat: [ aStream tab ].    aStream nextPutAll: '}'.! !!CCodeGenerator methodsFor: 'C translation'!generateIfTrueIfFalse: msgNode on: aStream indent: level    "Generate the C code for this message onto the given stream."    aStream nextPutAll: 'if ('.    msgNode receiver emitCCodeOn: aStream level: level generator: self.    aStream nextPutAll: ') {'; cr.    msgNode args first emitCCodeOn: aStream level: level + 1 generator: self.    level timesRepeat: [ aStream tab ].    aStream nextPutAll: '} else {'; cr.    msgNode args last emitCCodeOn: aStream level: level + 1 generator: self.    level timesRepeat: [ aStream tab ].    aStream nextPutAll: '}'.! !!CCodeGenerator methodsFor: 'C translation'!generateInlineCCode: msgNode on: aStream indent: level    "Generate the C code for this message onto the given stream."    aStream nextPutAll: msgNode args first value.! !!CCodeGenerator methodsFor: 'C translation'!generateInlineDirective: msgNode on: aStream indent: level    "Generate the C code for this message onto the given stream."    aStream nextPutAll: '/* inline: '.    aStream nextPutAll: msgNode args first name.    aStream nextPutAll: ' */'.! !!CCodeGenerator methodsFor: 'C translation'!generateIntegerObjectOf: msgNode on: aStream indent: level    "Generate the C code for this message onto the given stream."    aStream nextPutAll: '(('.    self emitCExpression: msgNode args first on: aStream.    aStream nextPutAll: ' << 1) | 1)'.! !!CCodeGenerator methodsFor: 'C translation'!generateIntegerValueOf: msgNode on: aStream indent: level    "Generate the C code for this message onto the given stream."    aStream nextPutAll: '('.    self emitCExpression: msgNode args first on: aStream.    aStream nextPutAll: ' >> 1)'.! !!CCodeGenerator methodsFor: 'C translation'!generateIsIntegerObject: msgNode on: aStream indent: level    "Generate the C code for this message onto the given stream."    aStream nextPutAll: '('.    self emitCExpression: msgNode args first on: aStream.    aStream nextPutAll: ' & 1)'.! !!CCodeGenerator methodsFor: 'C translation'!generateIsNil: msgNode on: aStream indent: level    "Generate the C code for this message onto the given stream."    self emitCExpression: msgNode receiver on: aStream.    aStream nextPutAll: ' == '.    aStream nextPutAll: (self cLiteralFor: nil).! !!CCodeGenerator methodsFor: 'C translation'!generateLessThan: msgNode on: aStream indent: level    "Generate the C code for this message onto the given stream."    self emitCExpression: msgNode receiver on: aStream.    aStream nextPutAll: ' < '.    self emitCExpression: msgNode args first on: aStream.! !!CCodeGenerator methodsFor: 'C translation'!generateLessThanOrEqual: msgNode on: aStream indent: level    "Generate the C code for this message onto the given stream."    self emitCExpression: msgNode receiver on: aStream.    aStream nextPutAll: ' <= '.    self emitCExpression: msgNode args first on: aStream.! !!CCodeGenerator methodsFor: 'C translation'!generateMax: msgNode on: aStream indent: level    "Generate the C code for this message onto the given stream."    aStream nextPutAll: '(('.    self emitCExpression: msgNode receiver on: aStream.    aStream nextPutAll: ' < '.    self emitCExpression: msgNode args first on: aStream.    aStream nextPutAll: ') ? '.    self emitCExpression: msgNode args first on: aStream.    aStream nextPutAll: ' : '.    self emitCExpression: msgNode receiver on: aStream.    aStream nextPutAll: ')'.! !!CCodeGenerator methodsFor: 'C translation'!generateMin: msgNode on: aStream indent: level    "Generate the C code for this message onto the given stream."    aStream nextPutAll: '(('.    self emitCExpression: msgNode receiver on: aStream.    aStream nextPutAll: ' < '.    self emitCExpression: msgNode args first on: aStream.    aStream nextPutAll: ') ? '.    self emitCExpression: msgNode receiver on: aStream.    aStream nextPutAll: ' : '.    self emitCExpression: msgNode args first on: aStream.    aStream nextPutAll: ')'.! !!CCodeGenerator methodsFor: 'C translation'!generateMinus: msgNode on: aStream indent: level    "Generate the C code for this message onto the given stream."    self emitCExpression: msgNode receiver on: aStream.    aStream nextPutAll: ' - '.    self emitCExpression: msgNode args first on: aStream.! !!CCodeGenerator methodsFor: 'C translation'!generateModulo: msgNode on: aStream indent: level    "Generate the C code for this message onto the given stream."    self emitCExpression: msgNode receiver on: aStream.    aStream nextPutAll: ' % '.    self emitCExpression: msgNode args first on: aStream.! !!CCodeGenerator methodsFor: 'C translation'!generateNot: msgNode on: aStream indent: level    "Generate the C code for this message onto the given stream."    aStream nextPutAll: '!!'.    self emitCExpression: msgNode receiver on: aStream.! !!CCodeGenerator methodsFor: 'C translation'!generateNotEqual: msgNode on: aStream indent: level    "Generate the C code for this message onto the given stream."    self emitCExpression: msgNode receiver on: aStream.    aStream nextPutAll: ' !!= '.    self emitCExpression: msgNode args first on: aStream.! !!CCodeGenerator methodsFor: 'C translation'!generateNotNil: msgNode on: aStream indent: level    "Generate the C code for this message onto the given stream."    self emitCExpression: msgNode receiver on: aStream.    aStream nextPutAll: ' !!= '.    aStream nextPutAll: (self cLiteralFor: nil).! !!CCodeGenerator methodsFor: 'C translation'!generateOr: msgNode on: aStream indent: level    "Generate the C code for this message onto the given stream."    self emitCExpression: msgNode receiver on: aStream.    aStream nextPutAll: ' || '.    self emitCExpression: msgNode args first on: aStream.! !!CCodeGenerator methodsFor: 'C translation'!generatePlus: msgNode on: aStream indent: level    "Generate the C code for this message onto the given stream."    self emitCExpression: msgNode receiver on: aStream.    aStream nextPutAll: ' + '.    self emitCExpression: msgNode args first on: aStream.! !!CCodeGenerator methodsFor: 'C translation'!generatePreDecrement: msgNode on: aStream indent: level    "Generate the C code for this message onto the given stream."    | varNode |    varNode _ msgNode receiver.    varNode isVariable        ifFalse: [ self error: 'preDecrement can only be applied to variables' ].    aStream nextPutAll: '--'.    aStream nextPutAll: varNode name.! !!CCodeGenerator methodsFor: 'C translation'!generatePreIncrement: msgNode on: aStream indent: level    "Generate the C code for this message onto the given stream."    | varNode |    varNode _ msgNode receiver.    varNode isVariable        ifFalse: [ self error: 'preIncrement can only be applied to variables' ].    aStream nextPutAll: '++'.    aStream nextPutAll: varNode name.! !!CCodeGenerator methodsFor: 'C translation'!generateSequentialAnd: msgNode on: aStream indent: level    "Generate the C code for this message onto the given stream."    self emitCExpression: msgNode receiver on: aStream.    aStream nextPutAll: ' && ('.    self emitCTestBlock: msgNode args first on: aStream.    aStream nextPutAll: ')'.! !!CCodeGenerator methodsFor: 'C translation'!generateSequentialOr: msgNode on: aStream indent: level    "Generate the C code for this message onto the given stream."    "Note: PP 2.3 compiler produces two arguments for or:, presumably     to help with inlining later. Taking the last agument should do the correct     thing even if your compiler is different."    self emitCExpression: msgNode receiver on: aStream.    aStream nextPutAll: ' || ('.    self emitCTestBlock: msgNode args last on: aStream.    aStream nextPutAll: ')'.! !!CCodeGenerator methodsFor: 'C translation'!generateSharedCodeDirective: msgNode on: aStream indent: level    "Generate the C code for this message onto the given stream."    aStream nextPutAll: '/* common code: '.    aStream nextPutAll: msgNode args first value.    aStream nextPutAll: ' */'.! !!CCodeGenerator methodsFor: 'C translation'!generateShiftLeft: msgNode on: aStream indent: level    "Generate the C code for this message onto the given stream."    self emitCExpression: msgNode receiver on: aStream.    aStream nextPutAll: ' << '.    self emitCExpression: msgNode args first on: aStream.! !!CCodeGenerator methodsFor: 'C translation'!generateShiftRight: msgNode on: aStream indent: level    "Generate the C code for this message onto the given stream."    aStream nextPutAll: '((unsigned) '.    self emitCExpression: msgNode receiver on: aStream.    aStream nextPutAll: ')'.    aStream nextPutAll: ' >> '.    self emitCExpression: msgNode args first on: aStream.! !!CCodeGenerator methodsFor: 'C translation'!generateTimes: msgNode on: aStream indent: level    "Generate the C code for this message onto the given stream."    self emitCExpression: msgNode receiver on: aStream.    aStream nextPutAll: ' * '.    self emitCExpression: msgNode args first on: aStream.! !!CCodeGenerator methodsFor: 'C translation'!generateToByDo: msgNode on: aStream indent: level    "Generate the C code for this message onto the given stream."    | iterationVar |    (msgNode args last args size = 1) ifFalse: [        self error: 'wrong number of block arguments'.    ].    iterationVar _ msgNode args last args first.    aStream nextPutAll: 'for (', iterationVar, ' = '.    self emitCExpression: msgNode receiver on: aStream.    aStream nextPutAll: '; ', iterationVar, ' <= '.    self emitCExpression: msgNode args first on: aStream.    aStream nextPutAll: '; ', iterationVar, ' += '.    self emitCExpression: (msgNode args at: 2) on: aStream.    aStream nextPutAll: ') {'; cr.    msgNode args last emitCCodeOn: aStream level: level + 1 generator: self.    level timesRepeat: [ aStream tab ].    aStream nextPutAll: '}'.! !!CCodeGenerator methodsFor: 'C translation'!generateToDo: msgNode on: aStream indent: level    "Generate the C code for this message onto the given stream."    | iterationVar |    (msgNode args last args size = 1) ifFalse: [        self error: 'wrong number of block arguments'.    ].    iterationVar _ msgNode args last args first.    aStream nextPutAll: 'for (', iterationVar, ' = '.    self emitCExpression: msgNode receiver on: aStream.    aStream nextPutAll: '; ', iterationVar, ' <= '.    self emitCExpression: msgNode args first on: aStream.    aStream nextPutAll: '; ', iterationVar, '++) {'; cr.    msgNode args last emitCCodeOn: aStream level: level + 1 generator: self.    level timesRepeat: [ aStream tab ].    aStream nextPutAll: '}'.! !!CCodeGenerator methodsFor: 'C translation'!generateWhileFalse: msgNode on: aStream indent: level    "Generate the C code for this message onto the given stream."    aStream nextPutAll: 'while (!!('.    self emitCTestBlock: msgNode receiver on: aStream.    aStream nextPutAll: ')) {'; cr.    msgNode args first emitCCodeOn: aStream level: level + 1 generator: self.    level timesRepeat: [ aStream tab ].    aStream nextPutAll: '}'.! !!CCodeGenerator methodsFor: 'C translation'!generateWhileTrue: msgNode on: aStream indent: level    "Generate the C code for this message onto the given stream."    aStream nextPutAll: 'while ('.    self emitCTestBlock: msgNode receiver on: aStream.    aStream nextPutAll: ') {'; cr.    msgNode args first emitCCodeOn: aStream level: level + 1 generator: self.    level timesRepeat: [ aStream tab ].    aStream nextPutAll: '}'.! !!CCodeGenerator methodsFor: 'C translation'!initializeCTranslationDictionary     "Initialize the dictionary mapping message names to actions for C code generation."    | pairs |    translationDict _ Dictionary new: 200.    pairs _ #(    #&                #generateAnd:on:indent:    #|                #generateOr:on:indent:    #and:            #generateSequentialAnd:on:indent:    #or:            #generateSequentialOr:on:indent:    #not            #generateNot:on:indent:    #+                #generatePlus:on:indent:    #-                #generateMinus:on:indent:    #*                #generateTimes:on:indent:    #//                #generateDivide:on:indent:    #\\                #generateModulo:on:indent:    #<<                #generateShiftLeft:on:indent:    #>>                #generateShiftRight:on:indent:    #min:            #generateMin:on:indent:    #max:            #generateMax:on:indent:    #bitAnd:        #generateBitAnd:on:indent:    #bitOr:            #generateBitOr:on:indent:    #bitXor:            #generateBitXor:on:indent:    #bitShift:        #generateBitShift:on:indent:    #bitInvert32    #generateBitInvert32:on:indent:    #<                #generateLessThan:on:indent:    #<=                #generateLessThanOrEqual:on:indent:    #=                #generateEqual:on:indent:    #>                #generateGreaterThan:on:indent:    #>=                #generateGreaterThanOrEqual:on:indent:    #~=                #generateNotEqual:on:indent:    #==                #generateEqual:on:indent:    #isNil            #generateIsNil:on:indent:    #notNil            #generateNotNil:on:indent:    #whileTrue:     #generateWhileTrue:on:indent:    #whileFalse:    #generateWhileFalse:on:indent:    #to:do:            #generateToDo:on:indent:    #to:by:do:        #generateToByDo:on:indent:    #ifTrue:        #generateIfTrue:on:indent:    #ifFalse:        #generateIfFalse:on:indent:    #ifTrue:ifFalse:    #generateIfTrueIfFalse:on:indent:    #ifFalse:ifTrue:    #generateIfFalseIfTrue:on:indent:    #at:                #generateAt:on:indent:    #at:put:            #generateAtPut:on:indent:    #integerValueOf:    #generateIntegerValueOf:on:indent:    #integerObjectOf:    #generateIntegerObjectOf:on:indent:    #isIntegerObject:     #generateIsIntegerObject:on:indent:    #cCode:                #generateInlineCCode:on:indent:    #cCoerce:to:            #generateCCoercion:on:indent:    #preIncrement        #generatePreIncrement:on:indent:    #preDecrement        #generatePreDecrement:on:indent:    #inline:                #generateInlineDirective:on:indent:    #sharedCodeNamed:inCase:    #generateSharedCodeDirective:on:indent:    ).    1 to: pairs size by: 2 do: [ :i |        translationDict at: (pairs at: i) put: (pairs at: i + 1).    ].! !!CCodeGenerator class methodsFor: 'removing from system'!removeCompilerMethods    "Before removing the C code generator classes from the system, use this method to remove the compiler node methods that support it. This avoids leaving dangling references to C code generator classes in the compiler node classes."    ParseNode withAllSubclasses do: [ :nodeClass |        nodeClass removeCategory: 'C translation'.    ].    AbstractSound class removeCategory: 'primitive generation'.! !!ChangedMessageSet methodsFor: 'everything'!changeSet: aChangeSet    changeSet _ aChangeSet! !!ChangedMessageSet methodsFor: 'everything'!contents: aString notifying: aController    | selectedMessageName selector oldMessageList |    selectedMessageName _ self selectedMessageName.    oldMessageList _ self messageList.    contents _ nil.    selector _         self selectedClassOrMetaClass                compile: aString                classified:  self selectedMessageCategoryName                notifying: aController.    selector == nil ifTrue: [^ false].    contents _ aString copy.    selector ~~ selectedMessageName        ifTrue:             [(oldMessageList includes: selector)                ifFalse: [self initializeMessageList: changeSet changedMessageListAugmented.                        self changed: #messageListChanged].            self messageListIndex: (self messageList indexOf: selector)].    ^ true! !!ChangedMessageSet class methodsFor: 'as yet unclassified' stamp: 'sw 3/9/97'!openFor: aChangeSet    "Open up a ChangedMessageSet browser on the given change set; this is a conventional message-list browser whose message list is the list of methods in aChangeSet.  After any method submission, the message list is refigured, making it plausibly dynamic.  "    | messageSet |    messageSet _ self messageList: aChangeSet changedMessageListAugmented.    messageSet changeSet: aChangeSet.    messageSet autoSelectString: nil.    ScheduledControllers scheduleActive:                     (self open: messageSet name:  'Methods in Change Set ', aChangeSet name)! !!ChangeList methodsFor: 'scanning' stamp: 'di 6/13/97 22:52'!scanCategory  "or other preamble"    | itemPosition item tokens stamp |    itemPosition _ file position.    item _ file nextChunk.    (item findString: 'methodsFor:' startingAt: 1) = 0 ifTrue:        ["Maybe a preamble, but not one we recognize"        ^ self addItem: (ChangeRecord new file: file position: itemPosition type: #preamble)                 text: ('preamble: ' , item contractTo: 50)].    tokens _ Scanner new scanTokens: item.    tokens size >= 3 ifTrue:        [stamp _ ''.        tokens size >= 5 ifTrue:  "capture change stamp, if any"            [(tokens at: 4) = #stamp: ifTrue: [stamp _ tokens at: 5].            (tokens at: 5) = #stamp: ifTrue: [stamp _ tokens at: 6]].        (tokens at: 2) = #methodsFor:            ifTrue: [^ self scanCategory: (tokens at: 3) class: (tokens at: 1)                            meta: false stamp: stamp].        (tokens at: 3) = #methodsFor:            ifTrue: [^ self scanCategory: (tokens at: 4) class: (tokens at: 1)                            meta: true stamp: stamp]]! !!ChangeList methodsFor: 'scanning' stamp: 'di 6/13/97 23:02'!scanCategory: category class: class meta: meta stamp: stamp    | itemPosition method |    [itemPosition _ file position.    method _ file nextChunk.    method size > 0]                        "done when double terminators"        whileTrue:        [self addItem: (ChangeRecord new file: file position: itemPosition type: #method                            class: class category: category meta: meta stamp: stamp)            text: 'method: ' , class , (meta ifTrue: [' class '] ifFalse: [' '])                , (Parser new parseSelector: method)                , (stamp isEmpty ifTrue: [''] ifFalse: ['; ' , stamp])]! !!ChangeList methodsFor: 'scanning' stamp: 'di 6/28/97 09:24'!scanVersionsOf: method class: class meta: meta category: category selector: selector    | position prevPos prevFileIndex preamble tokens sourceFilesCopy stamp |    changeList _ OrderedCollection new.    list _ OrderedCollection new.    listIndex _ 0.    position _ method filePosition.    sourceFilesCopy _ SourceFiles collect:        [:x | x isNil ifTrue: [ nil ]                ifFalse: [x readOnlyCopy]].    file _ sourceFilesCopy at: method fileIndex.    [position notNil & file notNil]        whileTrue:        [file position: (0 max: position-150).  "Skip back to before the preamble"        [file position < (position-1)]  "then pick it up from the front"            whileTrue: [preamble _ file nextChunk].        "Preamble is likely a linked method preamble, if we're in            a changes file (not the sources file).  Try to parse it            for prior source position and file index"        prevPos _ nil.        stamp _ ''.        ((file == sourceFilesCopy first) not and:            [(preamble findString: 'methodsFor:' startingAt: 1) > 0])            ifTrue: [tokens _ Scanner new scanTokens: preamble]            ifFalse: [tokens _ Array new  "ie cant be back ref"].        ((tokens size between: 7 and: 8)            and: [(tokens at: tokens size-5) = #methodsFor:])            ifTrue:                [(tokens at: tokens size-3) = #stamp:                ifTrue: ["New format gives change stamp and unified prior pointer"                        stamp _ tokens at: tokens size-2.                        prevPos _ tokens last.                        prevFileIndex _ prevPos // 16r1000000.                        prevPos _ prevPos \\ 16r1000000]                ifFalse: ["Old format gives no stamp; prior pointer in two parts"                        prevPos _ tokens at: tokens size-2.                        prevFileIndex _ tokens last].                (prevPos = 0 or: [prevFileIndex = 0]) ifTrue: [prevPos _ nil]].        ((tokens size between: 5 and: 6)            and: [(tokens at: tokens size-3) = #methodsFor:])            ifTrue:                [(tokens at: tokens size-1) = #stamp:                ifTrue: ["New format gives change stamp and unified prior pointer"                        stamp _ tokens at: tokens size]].         self addItem:                (ChangeRecord new file: file position: position type: #method                        class: class name category: category meta: meta stamp: stamp)            text: stamp , ' ' , class name , (meta ifTrue: [' class '] ifFalse: [' ']) , selector.        position _ prevPos.        prevPos notNil ifTrue:            [file _ sourceFilesCopy at: prevFileIndex]].    sourceFilesCopy do: [:x | x notNil ifTrue: [x close]].    listSelections _ Array new: list size withAll: false! !!ChangeList methodsFor: 'menu actions' stamp: 'jm 6/12/97 10:54'!fileOutSelections     | f |    f _ FileStream newFileNamed: (FillInTheBlank request: 'Enter file name' initialAnswer: 'Filename.st').    f header; timeStamp.    listSelections with: changeList do:         [:selected :item | selected ifTrue: [item fileOutOn: f]].    f close.! !!ChangeList methodsFor: 'menu actions' stamp: 'di 6/13/97 23:10'!removeOlderMethodVersions    "Remove older versions of entries from the receiver."    | newChangeList newList found str |    newChangeList _ OrderedCollection new.    newList _ OrderedCollection new.    found _ OrderedCollection new.    changeList reverseWith: list do:        [:chRec :strNstamp | str _ strNstamp copyUpTo: $;.            (found includes: str)                ifFalse:                    [found add: str.                    newChangeList add: chRec.                    newList add: strNstamp]].    newChangeList size < changeList size        ifTrue:            [changeList _ newChangeList reversed.            list _ newList reversed.            listIndex _ 0.            listSelections _ Array new: list size withAll: false].    self changed: #list! !!ChangeList methodsFor: 'viewing access' stamp: 'di 6/15/97 16:47'!contents: aString    listIndex = 0 ifTrue: [self changed: #flash. ^ false].    lostMethodPointer ifNotNil: [^ self restoreDeletedMethod].    (changeList at: listIndex) fileIn.    ^ true! !!ChangeList methodsFor: 'viewing access' stamp: 'di 6/15/97 16:46'!restoreDeletedMethod    "If lostMethodPointer is not nil, then this is a version browser for a method that has been removed.  In this case we want to establish a sourceCode link to prior versions.  We do this by installing a dummy method with the correct source code pointer prior to installing this version."    | dummyMethod class selector |    dummyMethod _ CompiledMethod toReturnSelf setSourcePointer: lostMethodPointer.    class _ (changeList at: listIndex) methodClass.    selector _ (changeList at: listIndex) methodSelector.    class addSelector: selector withMethod: dummyMethod.    (changeList at: listIndex) fileIn.    "IF for some reason, the dummy remains, remove it, but (N.B.!!) we might not get control back if the compile (fileIn above) fails."    (class compiledMethodAt: selector) == dummyMethod        ifTrue: [class removeSelectorSimply: selector].    ^ true! !!ChangeList methodsFor: 'accessing' stamp: 'di 6/15/97 15:13'!setLostMethodPointer: sourcePointer    lostMethodPointer _ sourcePointer! !!ChangeList class methodsFor: 'public access'!browseRecentLog    "ChangeList browseRecentLog"    "Prompt with a menu of how far back to go"    | end changesFile banners positions pos chunk i |    changesFile _ (SourceFiles at: 2) readOnlyCopy.    banners _ OrderedCollection new.    positions _ OrderedCollection new.    end _ changesFile size.    pos _ Smalltalk lastQuitLogPosition.    [pos = 0 or: [banners size > 20]] whileFalse:        [changesFile position: pos.        chunk _ changesFile nextChunk.        i _ chunk indexOfSubCollection: 'priorSource: ' startingAt: 1.        i > 0 ifTrue: [positions addLast: pos.                    banners addLast: (chunk copyFrom: 5 to: i-2).                    pos _ Number readFrom: (chunk copyFrom: i+13 to: chunk size)]            ifFalse: [pos _ 0]].    changesFile close.    pos _ (SelectionMenu labelList: banners reversed selections: positions reversed)                startUpWithCaption: 'Browse as far back as...'.    pos == nil ifTrue: [^ self].    self browseRecent: end-pos! !!ChangeList class methodsFor: 'public access' stamp: 'di 6/15/97 15:12'!browseVersionsOf: method class: class meta: meta        category: category selector: selector lostMethodPointer: sourcePointer    | changeList |    Cursor read showWhile:        [changeList _ self new            scanVersionsOf: method class: class meta: meta            category: category selector: selector].    changeList setLostMethodPointer: sourcePointer.    self openVersions: changeList name: 'Recent versions of ' , selector! !!ChangeRecord methodsFor: 'access' stamp: '6/6/97 08:56 dhhi'!stamp    ^ stamp! !!ChangeRecord methodsFor: 'initialization' stamp: '6/6/97 08:48 dhhi'!file: f position: p type: t class: c category: cat meta: m stamp: s    self file: f position: p type: t.    class _ c.    category _ cat.    meta _ m.    stamp _ s! !ChangeSet comment:'My instances keep track of the changes made to a system, so the user can make an incremental fileOut. The order in which changes are made is not remembered.classChanges:  Dictionary {class name -> Set {eg, #change, #rename, etc}}.methodChanges:  Dictionary {class name -> IdentityDictionary {selector -> {eg, #change, #remove, etc}}.classRemoves:  Set {class name (original)}.methodRemoves:  Dictionary {(Array with: class name with: selector) -> (Array with: source pointer with: category)}.name: a String used to name the changeSet, and thus any associated project or fileOut.preamble and postscript:  two strings that serve as prefix (useful for documentation) and suffix (useful for doits) to the fileout of the changeSet.'!!ChangeSet methodsFor: 'initialize-release' stamp: 'sw 11/26/96'!clear     "Reset the receiver to be empty.  "    classChanges _ Dictionary new.    methodChanges _ Dictionary new.    classRemoves _ Set new.    preamble _ nil.    postscript _ nil! !!ChangeSet methodsFor: 'initialize-release' stamp: 'sw 11/27/96'!editPostscript    "edit the receiver's postscript, in a separate window.  "    self assurePostscriptExists.    StringHolderView open: postscript label: 'Postscript for ChangeSet named ', name! !!ChangeSet methodsFor: 'initialize-release' stamp: 'di 6/15/97 08:40'!initialize     "Reset the receiver to be empty."    self wither.  "Avoid duplicate entries in AllChangeSets if initialize gets called twice"    classChanges _ Dictionary new.    methodChanges _ Dictionary new.    classRemoves _ Set new.    methodRemoves _ Dictionary new.    name _ ChangeSet defaultName! !!ChangeSet methodsFor: 'change management' stamp: 'di 9/22/97 13:19'!assimilateAllChangesFoundIn: aChangeSet    "Make all changes in aChangeSet take effect on self as it they happened later.  *** classes renamed in aChangeSet may have have problems"    | cls info selector pair |    aChangeSet changedClassNames do: [:className |        (cls _ Smalltalk classNamed: className) notNil ifTrue:        [info _ aChangeSet classChangeAt: className.        info do: [:each | self atClass: cls add: each].        info _ aChangeSet methodChanges at: className             ifAbsent: [Dictionary new].        info associationsDo: [:assoc |            assoc value == #remove                ifTrue:                    [selector _ assoc key.                    self removeSelector: selector class: cls.                    pair _ aChangeSet methodRemoves                            at: (Array with: cls name with: selector)                            ifAbsent: [nil].                    pair ifNotNil:                        ["Retain source code ref if stored"                        methodRemoves at: (Array with: cls name with: selector)                                        put: pair]]                ifFalse:                     [self atSelector: assoc key class: cls put: assoc value]]]].    self flag: #developmentNote.  "the following cannot work, since the class will not exist; SW comments this out 8/91 because it thwarts integration!!""aChangeSet classRemoves do:        [:removed | self removeClass: (Smalltalk classNamed: removed)] "! !!ChangeSet methodsFor: 'method changes' stamp: 'di 9/22/97 13:18'!removeSelector: selector class: class     "Include indication that a method has been forgotten."    (self atSelector: selector class: class) = #add        ifTrue: [self atSelector: selector                    class: class                    put: #addedThenRemoved]        ifFalse: [self atSelector: selector                    class: class                    put: #remove].    (class includesSelector: selector) ifTrue:        ["Save the source code pointer and category so can still browse old versions"        methodRemoves at: (Array with: class name with: selector)            put: (Array with: (class compiledMethodAt: selector) sourcePointer                        with: (class whichCategoryIncludesSelector: selector))]! !!ChangeSet methodsFor: 'fileIn/Out' stamp: 'sw 11/27/96'!assurePostscriptExists    "Make sure there is a StringHolder holding the postscript.  "    postscript == nil ifTrue: [postscript _ StringHolder new contents: '']! !!ChangeSet methodsFor: 'fileIn/Out' stamp: 'sw 11/27/96'!assurePreambleExists    "Make sure there is a StringHolder holding the preamble.       : if it's found to have reverted to empty contents, put up the template"    (preamble == nil or: [preamble contents size == 0])        ifTrue: [preamble _ StringHolder new contents: self preambleTemplate]! !!ChangeSet methodsFor: 'fileIn/Out' stamp: 'sw 5/30/96'!fileOut    "File out the receiver, to a file whose name is a function of the change-set name and of the date and the time.  1/18/96 sw : show write cursor    : put a dot before the date/time stamp"    | file |    Cursor write showWhile:        [file _ FileStream newFileNamed: ((self name, '.', Utilities dateTimeSuffix, '.cs') truncateTo: 27).        file header; timeStamp.        self fileOutPreambleOn: file.        self fileOutOn: file.        self fileOutPostscriptOn: file.        file trailer; close]! !!ChangeSet methodsFor: 'fileIn/Out' stamp: 'sw 11/25/96'!fileOutPostscriptOn: stream     "If the receiver has a postscript, put it out onto the stream.  "    | aString |    ((aString _ self postscriptString) size > 0)        ifTrue:            [stream nextChunkPut: aString "surroundedBySingleQuotes".            stream cr; cr]! !!ChangeSet methodsFor: 'fileIn/Out' stamp: 'sw 11/25/96'!fileOutPreambleOn: stream     "If the receiver has a preamble, put it out onto the stream.  "    | aString |    ((aString _ self preambleString) size > 0)        ifTrue:            [stream nextChunkPut: aString "surroundedBySingleQuotes".            stream cr; cr]! !!ChangeSet methodsFor: 'fileIn/Out' stamp: 'sw 11/27/96'!postscriptString    "Answer the string representing the postscript.  "    self assurePostscriptExists.    ^ postscript contents! !!ChangeSet methodsFor: 'fileIn/Out' stamp: 'sw 11/27/96'!postscriptString: aString    "Establish aString as the new contents of the postscript.  "    postscript _ StringHolder new contents: aString! !!ChangeSet methodsFor: 'fileIn/Out' stamp: 'sw 11/27/96'!preambleString    "Answer the string representing the preamble.  "    ^ preamble == nil        ifTrue:            [preamble]        ifFalse:            [preamble contents]! !!ChangeSet methodsFor: 'fileIn/Out' stamp: 'sw 11/27/96'!preambleString: aString    "Establish aString as the new contents of the preamble.  "    preamble _ StringHolder new contents: aString! !!ChangeSet methodsFor: 'fileIn/Out'!preambleTemplate    "Answer a string that will form the default contents for a change set's preamble.  Just a first stab at what the content should be.12/3/96 sw"    | aStream |    aStream _ ReadWriteStream on: ''.    aStream nextPutAll: '"Change Set:'.    aStream tab;tab; nextPutAll: self name.    aStream cr; nextPutAll: 'Date:'; tab; tab; tab; nextPutAll: Date today printString.    aStream cr; nextPutAll: 'Author:'; tab; tab; tab; nextPutAll: 'Your Name'.    aStream cr; cr; nextPutAll: '<your descriptive text goes here>"'.    ^ aStream contents"Smalltalk changes preambleTemplate"! !!ChangeSet methodsFor: 'private' stamp: 'di 6/28/97 20:34'!fileOutClassChanges: class on: stream     "Write out class changes, i.e. new class, definition, comment, renaming.     : put out a rename indicator that won't halt if class of old name not there."    (self atClass: class includes: #add) ifTrue:        [stream cr.        class fileOutOn: stream.        stream cr].    (self atClass: class includes: #rename) ifTrue:        [stream nextChunkPut: 'Smalltalk renameClassNamed: #', (self oldNameFor: class), ' as: #', class name; cr].    (self atClass: class includes: #change) ifTrue:        [stream command: 'H3'; nextChunkPut: class definition; cr; command: '/H3'].    (self atClass: class includes: #comment) ifTrue:        [class organization putCommentOnFile: stream            numbered: nil moveSource: false.        stream cr].    (self atClass: class includes: #reorganize) ifTrue:        [class fileOutOrganizationOn: stream.        stream cr]! !!ChangeSet methodsFor: 'private' stamp: 'di 6/28/97 20:34'!fileOutClassDefinition: class on: stream     "Write out class definition for the given class on the given stream, if the class definition was added or changed.  5/15/96 sw"    ((self atClass: class includes: #add) or: [self atClass: class includes: #change])        ifTrue:            [stream command: 'H3'; nextChunkPut: class definition; cr; command: '/H3']! !!ChangeSet methodsFor: 'private' stamp: 'sw 5/15/96'!fileOutClassModifications: class on: stream     "Write out class mod-- rename, comment, reorg, remove, on the given stream.  Differs from the superseded fileOutClassChanges:on: in that it does not deal with class definitions, and does not file out entire added classes.       : put out a rename indicator that won't halt if class of old name not there."    (self atClass: class includes: #rename) ifTrue:        [stream nextChunkPut: 'Smalltalk renameClassNamed: #', (self oldNameFor: class), ' as: #', class name; cr].    (self atClass: class includes: #comment) ifTrue:        [class theNonMetaClass organization putCommentOnFile: stream            numbered: nil moveSource: false.        stream cr].    (self atClass: class includes: #reorganize) ifTrue:        [class fileOutOrganizationOn: stream.        stream cr]! !!ChangeSet methodsFor: 'accessing' stamp: 'sw 11/27/96'!editPreamble    "edit the receiver's preamble, in a separate window.  "    self assurePreambleExists.    StringHolderView open: preamble label: 'Preamble for ChangeSet named ', name! !!ChangeSet methodsFor: 'accessing' stamp: 'di 6/15/97 09:45'!methodRemoves    ^methodRemoves! !!ChangeSorter methodsFor: 'creation' stamp: 'sw 11/26/96'!initialize    "Initialize the receiver to look at the current change set.  "    self initializeFor: Smalltalk changes! !!ChangeSorter methodsFor: 'creation' stamp: 'sw 11/26/96'!initializeFor: aChangeSet    "Initialize the receiver and have it start out life looking at aChangeSet.  "    myChangeSet _ aChangeSet.        classList _ CngsClassList new.    classList parent: self.    messageList _ CngsMsgList new.    messageList parent: self.    MsgListMenu == nil ifTrue: [self class initialize].    classList list: #().    messageList list: #().! !!ChangeSorter methodsFor: 'creation'!open  "ChangeSorter new open"    | topView |    self initialize.    topView _ StandardSystemView new.    topView model: self.    topView label: self label.    topView minimumSize: 360@360.    self openView: topView offsetBy: 0@0.    topView controller open        "Let the show begin"! !!ChangeSorter methodsFor: 'creation'!openView: topView    "Create change sorter on one changeSet only.  Two of these in a DualChangeSorter."    | classView messageView codeView |    buttonView _ SwitchView new.    buttonView model: self controller: TriggerController new.    buttonView borderWidthLeft: 2 right: 2 top: 2 bottom: 0.    buttonView selector: #whatPolarity.    buttonView controller selector: #cngSetActivity.    buttonView window: (0 @ 0 extent: 360 @ 20).    buttonView label: myChangeSet name asParagraph.    classView _ GeneralListView new.    classView controllerClass: GeneralListController.    classView model: classList.    classView window: (0 @ 0 extent: 180 @ 160).    classView borderWidthLeft: 2 right: 0 top: 2 bottom: 2.    classView controller yellowButtonMenu: ClassMenu         yellowButtonMessages: ClassSelectors.    classList controller: classView controller.    messageView _ GeneralListView new.    messageView controllerClass: GeneralListController.    messageView model: messageList.    messageView window: (0 @ 0 extent: 180 @ 160).    messageView borderWidthLeft: 2 right: 2 top: 2 bottom: 2.    messageView controller yellowButtonMenu: MsgListMenu         yellowButtonMessages: MsgListSelectors.    messageList controller: messageView controller.    codeView _ BrowserCodeView new.    codeView model: self.    codeView window: (0 @ 0 extent: 360 @ 180).    codeView borderWidthLeft: 2 right: 2 top: 0 bottom: 2.    topView addSubView: buttonView.    topView addSubView: classView below: buttonView.    topView addSubView: messageView toRightOf: classView.    topView addSubView: codeView below: classView."    classView         align: classView viewport topLeft             with: buttonView viewport bottomLeft.    messageView         align: messageView viewport topLeft             with: classView viewport topRight.    codeView         align: codeView viewport topLeft             with: classView viewport bottomLeft."! !!ChangeSorter methodsFor: 'creation'!openView: topView offsetBy: offset    "Create change sorter on one changeSet with 0@0.    Two of these in a DualChangeSorter, right one is offset by 360@0."    | classView messageView codeView |    buttonView _ SwitchView new.    buttonView model: self controller: TriggerController new.    buttonView borderWidthLeft: 2 right: 2 top: 2 bottom: 0.    buttonView selector: #whatPolarity.    buttonView controller selector: #cngSetActivity.    buttonView window: ((0 @ 0 extent: 360 @ 20) translateBy: offset).    buttonView label: myChangeSet name asParagraph.    classView _ GeneralListView new.    classView controllerClass: GeneralListController.    classView model: classList.    classView window: (0 @ 0 extent: 180 @ 160).    classView borderWidthLeft: 2 right: 0 top: 2 bottom: 2.    classView controller yellowButtonMenu: ClassMenu         yellowButtonMessages: ClassSelectors.    classList controller: classView controller.    messageView _ GeneralListView new.    messageView controllerClass: GeneralListController.    messageView model: messageList.    messageView window: (0 @ 0 extent: 180 @ 160).    messageView borderWidthLeft: 2 right: 2 top: 2 bottom: 2.    messageView controller yellowButtonMenu: MsgListMenu         yellowButtonMessages: MsgListSelectors.    messageList controller: messageView controller.    codeView _ BrowserCodeView new.    codeView model: self.    codeView window: (0 @ 0 extent: 360 @ 180).    codeView borderWidthLeft: 2 right: 2 top: 0 bottom: 2.    topView addSubView: buttonView.    topView addSubView: classView below: buttonView.    topView addSubView: messageView toRightOf: classView.    topView addSubView: codeView below: classView.! !!ChangeSorter methodsFor: 'change set menu' stamp: 'sw 2/2/96'!browseChangeSet    "Open a message list browser on the new and changed methods in the current change set.       : launch a ChangedMessageSet"    ChangedMessageSet openFor: myChangeSet! !!ChangeSorter methodsFor: 'change set menu' stamp: 'sw 11/26/96'!clearChangeSet    "Clear out the current change set, after getting a confirmation.  "    | message |    myChangeSet isEmpty ifFalse:        [message _ 'Are you certain that you want to forget all the changes in this set?'.        (self confirm: message) ifFalse: [^ self]].    myChangeSet clear.    self launch! !!ChangeSorter methodsFor: 'change set menu' stamp: 'sw 11/27/96'!editPostscript    "Allow the user to edit the receiver's change-set's postscript -- in a separate window at present.  "    myChangeSet editPostscript! !!ChangeSorter methodsFor: 'change set menu' stamp: 'sw 11/27/96'!editPreamble    "Allow the user to edit the receiver's change-set's preamble -- in a separate window at present.  "    myChangeSet editPreamble! !!ChangeSorter methodsFor: 'code pane' stamp: 'di 7/13/97 11:15'!contents: aString notifying: aController     "Compile the code in aString. Notify aController of any syntax errors.     Create an error if the category of the selected message is unknown.     Answer false if the compilation fails. Otherwise, if the compilation     created a new method, deselect the current selection. Then answer true."    | category selector class oldSelector |    messageList listIndex = 0 ifTrue: [^ false].    class _ self selectedClassOrMetaClass.    oldSelector _ self selectedMessageName.    category _ class organization categoryOfElement: oldSelector.    selector _ class compile: aString                classified: category                notifying: aController.    selector == nil ifTrue: [^false].    selector == oldSelector ifFalse: [self changed: #message].    ^ true! !!ChangeSorter methodsFor: 'code pane' stamp: 'di 6/15/97 09:34'!setContents    "return the source code that shows in the bottom pane"    | sel class strm changeType |    self unlock.    (classList selection) == nil ifTrue: [^ contents _ ''].    class _ classList selectedClassOrMetaClass.    (sel _ messageList selection) == nil        ifFalse: [changeType _ (myChangeSet atSelector: (sel _ sel asSymbol) class: class).            changeType == #remove                ifTrue: [^ contents _ 'Method has been removed (see versions)'].            changeType == #addedThenRemoved                ifTrue: [^ contents _ 'Added then removed (see versions)'].            (class includesSelector: sel)                ifFalse: [^ contents _ 'Method was added, but cannot be found!!'].            ^ contents _ (class sourceMethodAt: sel) copy]        ifTrue: [strm _ WriteStream on: (String new: 100).            (myChangeSet classChangeAt: class name) do: [:each |                each = #remove ifTrue: [strm nextPutAll: 'Entire class was removed.'; cr].                each = #add ifTrue: [strm nextPutAll: 'Entire class was added.'; cr].                each = #change ifTrue: [strm nextPutAll: 'Class definition was changed.'; cr].                each = #comment ifTrue: [strm nextPutAll: 'New class comment.'; cr]].            ^ contents _ strm contents].! !!ChangeSorter class methodsFor: 'as yet unclassified' stamp: 'sw 11/26/96'!initialize    "Initialize the class.  1991-tck    Modified 1/12/96 sw: added a bunch of new items, not all of them implemented yet.  2/2/96 sw: added browse change set.  Also made it such that if AllChangeSets already exists, this won't clobber the existing order.  : changed wording of some items    5/8/96 sw: added subtractOtherSide    5/29/96 sw: added SingleCngSetMenu, for single change sorter    5/30/96 sw: added fileIntoNewChangeSet    7/23/96 di: removed SingleCngSetMenu, since not used    11/25/96 sw: added cmds to manipulate preamble and postscript    : added clear"    AllChangeSets == nil ifTrue:        [AllChangeSets _ OrderedCollection new].    self gatherChangeSets.    CngSetMenu _ PopUpMenu labels: 'make changes go to menew...file into new...show...fileOutbrowserenamecopy all to other sidesubtract other sideedit preamble...edit postscript...clearremove'    lines: #(1 3 7 9 11).    CngSetSelectors  _         #(newCurrent newSet fileIntoNewChangeSet chooseCngSet fileOut browseChangeSet rename copyToOther subtractOtherSide editPreamble editPostscript clearChangeSet remove).    ClassMenu _ PopUpMenu labels: 'browse classbrowse fullinst var refsclass varscopy to other sideforget'             lines: #().    ClassSelectors _         #(browse browseFull instVarRefs classVariables copyToOther forget).    MsgListMenu _ PopUpMenu labels: 'fileOutsendersimplementorssenders of...implementors of...implementors of sent msgsversionscopy to other sideforget'             lines: #(1 6 7).    MsgListSelectors _         #(fileOut senders implementors browseSendersOfMessages messages        allImplementorsOf versions copyToOther forget).    false ifTrue: [        "Just so senders will find it here!!!!!!  Never executed."        (CngsMsgList new) fileOut; senders; implementors; messages;              versions; copyToOther; forget.        (MessageListController new) browseSendersOfMessages;             allImplementorsOf].    "    ChangeSorter initialize.    GeneralListController allInstancesDo:        [:each  | each model parent class == ChangeSorter ifTrue: [            each yellowButtonMenu: ClassMenu                 yellowButtonMessages: ClassSelectors.            each yellowButtonMenu: MsgListMenu                 yellowButtonMessages: MsgListSelectors]].    "! !!ChangeSorter class methodsFor: 'as yet unclassified' stamp: 'di 9/20/97 22:34'!newChangesFromFile: aFileName    "File in the code from the file of the given name, into a new change set whose name is derived from that of the filename.  Leave the 'current change set' unchanged.   Returns the new change set; Returns nil on failure.  5/30/96 sw"    ^ self newChangesFromStream: (FileStream oldFileNamed: aFileName)         named: aFileName.! !!ChangeSorter class methodsFor: 'as yet unclassified' stamp: 'di 9/20/97 22:34'!newChangesFromFileStream: aFileStream    "File in the code from the file, into a new change set whose name is derived from the filename.  Leave the 'current change set' unchanged.   Returns the new change set;  Returns nil on failure.  7/12/96 sw"    ^ self newChangesFromStream: aFileStream         named: aFileStream localName! !!ChangeSorter class methodsFor: 'as yet unclassified' stamp: 'di 9/20/97 22:34'!newChangesFromStream: aFileStream named: aFileName    "File in the code from the file, into a new change set whose name is derived from the filename.  Leave the 'current change set' unchanged.   Returns the new change set;  Returns nil on failure.  7/12/96 sw  Allow any kind of stream.  tk 9/11/97"    |  newName aNewChangeSet existingChanges |    existingChanges _ Smalltalk changes.    newName _ aFileName sansPeriodSuffix.    (self changeSetNamed: newName) ~~ nil        ifTrue:            [self inform: 'Sorry -- "', newName, '" is already used as a change-set name'.            aFileStream close.            ^ nil].    aNewChangeSet _ ChangeSet new initialize.    aNewChangeSet name: newName.    AllChangeSets add: aNewChangeSet.    self makeCurrent: aNewChangeSet.    aFileStream fileIn.    Transcript cr; show: 'File ', aFileName, ' successfully filed in to change set ', newName.    self makeCurrent: existingChanges.    ^ aNewChangeSet! !!ChangeSorter class methodsFor: 'as yet unclassified' stamp: 'sw 11/26/96'!secondaryChangeSet    "Answer a likely change set to use as the second initial one in a Dual Change Sorter.  "    | last |    self gatherChangeSets.    AllChangeSets size == 1 ifTrue: [^ AllChangeSets first].    ^ (last _ AllChangeSets last) == Smalltalk changes        ifTrue:     [AllChangeSets at: (AllChangeSets size - 1)]        ifFalse:    [last]! !!Character methodsFor: 'accessing'!digitValue    "Answer 0-9 if the receiver is $0-$9, 10-35 if it is $A-$Z, and < 0     otherwise. This is used to parse literal numbers of radix 2-36."    value <= $9 asciiValue         ifTrue: [^value - $0 asciiValue].    value >= $A asciiValue         ifTrue: [value <= $Z asciiValue ifTrue: [^value - $A asciiValue + 10]].    ^ -1! !!Character methodsFor: 'converting'!asLowercase    "If the receiver is uppercase, answer its matching lowercase Character."        (8r101 <= value and: [value <= 8r132])  "self isUppercase"        ifTrue: [^ Character value: value + 8r40]        ifFalse: [^ self]! !!Character class methodsFor: 'accessing untypeable characters'!linefeed    "Answer the Character representing a linefeed."    ^self value: 10! !!CharacterBlock methodsFor: 'private'!moveBy: aPoint     "Change the corner positions of the receiver so that its area translates by     the amount defined by the argument, aPoint."    origin _ origin + aPoint.    corner _ corner + aPoint! !!CharacterBlock methodsFor: 'private'!newStringIndex: anInteger Character: aCharacter BoundingRectangle: aRectangle    stringIndex _ anInteger.    character _ aCharacter.    super setOrigin: aRectangle topLeft corner: aRectangle corner! !!CharacterBlock class methodsFor: 'instance creation'!stringIndex: anInteger character: aCharacter topLeft: originPoint extent: extentPoint     "Answer an instance of me with values set to the arguments."    ^self new        newStringIndex: anInteger        Character: aCharacter        BoundingRectangle: (originPoint extent: extentPoint)! !!CharacterBlockScanner methodsFor: 'scanning'!characterNotInFont     "This does not handle character selection nicely, i.e., illegal characters are a     little tricky to select.  Since the end of a run or line is subverted here by actually    having the scanner scan a different string in order to manage the illegal     character, things are not in an absolutely correct state for the character     location code.  If this becomes too odious in use, logic will be added to accurately     manage the situation."    lastCharacterExtent _         (font widthOf: (font maxAscii + 1) asCharacter) @ line lineHeight.    ^super characterNotInFont! !!CharacterBlockScanner methodsFor: 'stop conditions'!cr     "Answer a CharacterBlock that specifies the current location of the mouse     relative to a carriage return stop condition that has just been     encountered. The ParagraphEditor convention is to denote selections by     CharacterBlocks, sometimes including the carriage return (cursor is at     the end) and sometimes not (cursor is in the middle of the text)."    ((characterIndex ~= nil        and: [characterIndex > text size])            or: [(line last = text size)                and: [(destY + line lineHeight) < characterPoint y]])        ifTrue:    ["When off end of string, give data for next character"                destY _ destY +  line lineHeight.                lastCharacter _ nil.                characterPoint _ ((text at: lastIndex) = CR                                ifTrue: [leftMargin]                                ifFalse: [nextLeftMargin]) @ destY.                lastIndex _ lastIndex + 1.                self lastCharacterExtentSetX: 0.                ^ true].        lastCharacter _ CR.        characterPoint _ destX @ destY.        self lastCharacterExtentSetX: rightMargin - destX.        ^true! !!CharacterBlockScanner methodsFor: 'stop conditions'!crossedX    "Text display has wrapping. The scanner just found a character past the x     location of the cursor. We know that the cursor is pointing at a character     or before one."    | leadingTab currentX |    ((characterPoint x <= (destX + ((lastCharacterExtent x) // 2)))        or: [line last = lastIndex])        ifTrue:    [lastCharacter _ (text at: lastIndex).                characterPoint _ destX @ destY.                ^true].    "Pointing past middle of a character, return the next character."    lastIndex _ lastIndex + 1.    lastCharacter _ text at: lastIndex.    currentX _ destX + lastCharacterExtent x.    self lastCharacterExtentSetX: (font widthOf: lastCharacter).    characterPoint _ currentX @ destY.    "Yukky if next character is space or tab."    (lastCharacter = Space and: [textStyle alignment = Justified])        ifTrue:    [self lastCharacterExtentSetX:                    (lastCharacterExtent x +     (line justifiedPadFor: (spaceCount + 1))).                ^ true].    lastCharacter = Space        ifTrue:            ["See tabForDisplay for illumination on the following awfulness."            leadingTab _ true.            (line first to: lastIndex - 1) do:            [:index |            (text at: index) ~= Tab                ifTrue: [leadingTab _ false]].            (textStyle alignment ~= Justified or: [leadingTab])                ifTrue:    [self lastCharacterExtentSetX: (textStyle nextTabXFrom: currentX                            leftMargin: leftMargin rightMargin: rightMargin) -                                currentX]                ifFalse:    [self lastCharacterExtentSetX:  (((currentX + (textStyle tabWidth -                                (line justifiedTabDeltaFor: spaceCount))) -                                    currentX) max: 0)]].    ^ true! !!CharacterBlockScanner methodsFor: 'stop conditions'!endOfRun    "Before arriving at the cursor location, the selection has encountered an     end of run. Answer false if the selection continues, true otherwise. Set     up indexes for building the appropriate CharacterBlock."    | runLength lineStop |    ((characterIndex ~~ nil and:        [runStopIndex < characterIndex and: [runStopIndex < text size]])            or:    [characterIndex == nil and: [lastIndex < line last]])        ifTrue:    ["We're really at the end of a real run."                runLength _ (text runLengthFor: (lastIndex _ lastIndex + 1)).                characterIndex ~~ nil                    ifTrue:    [lineStop _ characterIndex    "scanning for index"]                    ifFalse:    [lineStop _ line last            "scanning for point"].                (runStopIndex _ lastIndex + (runLength - 1)) > lineStop                    ifTrue:     [runStopIndex _ lineStop].                self setStopConditions.                ^false].    lastCharacter _ text at: lastIndex.    characterPoint _ destX @ destY.    ((lastCharacter = Space and: [textStyle alignment = Justified])        or: [lastCharacter = Tab and: [lastSpaceOrTabExtent notNil]])        ifTrue: [lastCharacterExtent _ lastSpaceOrTabExtent].    characterIndex ~~ nil        ifTrue:    ["If scanning for an index and we've stopped on that index,                then we back destX off by the width of the character stopped on                (it will be pointing at the right side of the character) and return"                runStopIndex = characterIndex                    ifTrue:    [self characterPointSetX: destX - lastCharacterExtent x.                            ^true].                "Otherwise the requested index was greater than the length of the                string.  Return string size + 1 as index, indicate further that off the                string by setting character to nil and the extent to 0."                lastIndex _  lastIndex + 1.                lastCharacter _ nil.                self lastCharacterExtentSetX: 0.                ^true].    "Scanning for a point and either off the end of the line or off the end of the string."    runStopIndex = text size        ifTrue:    ["off end of string"                lastIndex _  lastIndex + 1.                lastCharacter _ nil.                self lastCharacterExtentSetX: 0.                ^true].    "just off end of line without crossing x"    lastIndex _ lastIndex + 1.    ^true! !!CharacterBlockScanner methodsFor: 'stop conditions'!paddedSpace    "When the line is justified, the spaces will not be the same as the font's     space character. A padding of extra space must be considered in trying     to find which character the cursor is pointing at. Answer whether the     scanning has crossed the cursor."    | pad |    pad _ 0.    spaceCount _ spaceCount + 1.    pad _ line justifiedPadFor: spaceCount.    lastSpaceOrTabExtent _ lastCharacterExtent copy.    self lastSpaceOrTabExtentSetX:  spaceWidth + pad.    (destX + lastSpaceOrTabExtent x)  >= characterPoint x        ifTrue: [lastCharacterExtent _ lastSpaceOrTabExtent copy.                ^self crossedX].    lastIndex _ lastIndex + 1.    destX _ destX + lastSpaceOrTabExtent x.    ^ false! !!CharacterBlockScanner methodsFor: 'stop conditions'!tab    | currentX |    currentX _ (textStyle alignment == Justified and: [self leadingTab not])        ifTrue:        "imbedded tabs in justified text are weird"            [destX + (textStyle tabWidth - (line justifiedTabDeltaFor: spaceCount)) max: destX]        ifFalse:            [textStyle                nextTabXFrom: destX                leftMargin: leftMargin                rightMargin: rightMargin].    lastSpaceOrTabExtent _ lastCharacterExtent copy.    self lastSpaceOrTabExtentSetX: (currentX - destX max: 0).    currentX >= characterPoint x        ifTrue:             [lastCharacterExtent _ lastSpaceOrTabExtent copy.            ^ self crossedX].    destX _ currentX.    lastIndex _ lastIndex + 1.    ^false! !!CharacterBlockScanner methodsFor: 'private'!buildCharacterBlockIn: aText    | lineIndex runLength lineStop done stopCondition |    "handle nullText"    (aText numberOfLines = 0 or: [text size = 0])        ifTrue:    [^CharacterBlock                    stringIndex: 1    "like being off end of string"                    character: nil                    topLeft: ((aText leftMarginForDisplayForLine: 1) @                                (aText compositionRectangle) top)                    extent: (0 @ textStyle lineGrid)].    "find the line"    lineIndex _ aText lineIndexOfTop: characterPoint y.    destY _ (aText topAtLineIndex: lineIndex).    line _ aText lines at: lineIndex.    rightMargin _ aText rightMarginForDisplay.    (lineIndex = aText numberOfLines and:        [(destY + line lineHeight) < characterPoint y])            ifTrue:    ["if beyond lastLine, force search to last character"                    self characterPointSetX: rightMargin]            ifFalse:    [characterPoint y < (aText compositionRectangle) top                        ifTrue: ["force search to first line"                                characterPoint _                                (aText compositionRectangle) topLeft].                    characterPoint x > rightMargin                        ifTrue:    [self characterPointSetX: rightMargin]].    destX _ leftMargin _ aText leftMarginForDisplayForLine: lineIndex.    nextLeftMargin_ aText leftMarginForDisplayForLine: lineIndex+1.    lastIndex _ line first.    self setStopConditions.        "also sets font"    runLength _ (text runLengthFor: line first).    characterIndex ~~ nil        ifTrue:    [lineStop _ characterIndex    "scanning for index"]        ifFalse:    [lineStop _ line last].    (runStopIndex _ lastIndex + (runLength - 1)) > lineStop        ifTrue:    [runStopIndex _ lineStop].    lastCharacterExtent _ 0 @ line lineHeight.    spaceCount _ 0. done  _ false.    [done]    whileFalse:    [stopCondition _ self scanCharactersFrom: lastIndex to: runStopIndex            in: text string rightX: characterPoint x            stopConditions: stopConditions displaying: false.    "see setStopConditions for stopping conditions for character block     operations."    self lastCharacterExtentSetX: (font widthOf: (text at: lastIndex)).    (self perform: stopCondition)        ifTrue:    [^CharacterBlock                    stringIndex: lastIndex                    character: lastCharacter                    topLeft: characterPoint                    extent: lastCharacterExtent]]! !!CharacterBlockScanner methodsFor: 'private'!characterPointSetX: xVal    characterPoint _ xVal @ characterPoint y! !!CharacterBlockScanner methodsFor: 'private'!lastCharacterExtentSetX: xVal    lastCharacterExtent _ xVal @ lastCharacterExtent y! !!CharacterBlockScanner methodsFor: 'private'!lastSpaceOrTabExtentSetX: xVal    lastSpaceOrTabExtent _ xVal @ lastSpaceOrTabExtent y! !!CharacterScanner methodsFor: 'scanning'!scanCharactersFrom: startIndex to: stopIndex in: sourceString rightX: rightX stopConditions: stops displaying: display     "Primitive. This is the inner loop of text display--but see     scanCharactersFrom: to:rightX: which would get the string,     stopConditions and displaying from the instance. March through source     String from startIndex to stopIndex. If any character is flagged with a     non-nil entry in stops, then return the corresponding value. Determine     width of each character from xTable. If dextX would exceed rightX, then     return stops at: 258. If displaying is true, then display the character.     Advance destX by the width of the character. If stopIndex has been     reached, then return stops at: 257. Fail under the same conditions that     the Smalltalk code below would cause an error. Optional. See Object     documentation whatIsAPrimitive."    | ascii nextDestX maxAscii |    <primitive: 103>    maxAscii _ xTable size-2.    lastIndex _ startIndex.    [lastIndex <= stopIndex]        whileTrue:             [ascii _ (sourceString at: lastIndex) asciiValue.            "ascii > maxAscii ifTrue: [ascii _ maxAscii]."            (stopConditions at: ascii + 1) == nil                ifFalse: [^stops at: ascii + 1].            sourceX _ xTable at: ascii + 1.            nextDestX _ destX + (width _ (xTable at: ascii + 2) - sourceX).            nextDestX > rightX ifTrue: [^stops at: CrossedX].            display ifTrue: [self copyBits].            destX _ nextDestX.            lastIndex _ lastIndex + 1].    lastIndex _ stopIndex.    ^stops at: EndOfRun! !!CharacterScanner methodsFor: 'private'!addEmphasis: code    "Set the bold-ital-under-strike emphasis."    emphasisCode _ emphasisCode bitOr: code! !!CharacterScanner methodsFor: 'private'!setActualFont: aFont    "Set the basal font to an isolated font reference."    font _ aFont! !!CharacterScanner methodsFor: 'private'!setFont    "Set the font and other emphasis."    self setFont: 1.    emphasisCode _ 0.    (text attributesAt: lastIndex) do:         [:att | att emphasizeScanner: self].    font _ font emphasized: emphasisCode.    "Install various parameters from the font."    spaceWidth _ font widthOf: Space.     sourceForm _ font glyphs.  "Should only be needed in DisplayScanner"    height _ font height.            " ditto "    xTable _ font xTable.    stopConditions _ font stopConditions.    stopConditions at: Space asciiValue + 1 put: #space.    stopConditions at: Tab asciiValue + 1 put: #tab.    stopConditions at: CR asciiValue + 1 put: #cr.    stopConditions at: EndOfRun put: #endOfRun.    stopConditions at: CrossedX put: #crossedX! !!CharacterScanner methodsFor: 'private'!setFont: fontNumber    "Set the basal font from the textStyle."    font _ textStyle fontAt: fontNumber! !!CharacterScanner methodsFor: 'private'!textColor: ignored    "Overridden in DisplayScanner"! !!Class methodsFor: 'initialize-release'!sharing: poolString     "Set up sharedPools. Answer whether recompilation is advisable."    | oldPools found |    oldPools _ self sharedPools.    sharedPools _ OrderedCollection new.    (Scanner new scanFieldNames: poolString) do:         [:poolName |         sharedPools add: (Smalltalk at: poolName asSymbol)].    sharedPools isEmpty ifTrue: [sharedPools _ nil].    oldPools do: [:pool | found _ false.                self sharedPools do: [:p | p == pool ifTrue: [found _ true]].                found ifFalse: [^ true "A pool got deleted"]].    ^ false! !!Class methodsFor: 'copying' stamp: 'sw 6/12/96'!copyOfMethodDictionary    "Return a copy of the receiver's method dictionary.  "    ^ methodDict copy! !!Class methodsFor: 'class name'!rename: aString     "The new name of the receiver is the argument, aString."    | newName |    newName _ aString asSymbol.    (Smalltalk includesKey: newName)        ifTrue: [^self error: newName , ' already exists'].    (Undeclared includesKey: newName)        ifTrue: [^ SelectionMenu notify: 'There are references to, ' , aString printString , 'from Undeclared. Check them after this change.'].    Smalltalk renameClass: self as: newName.    name _ newName.    self comment: self comment.    self class comment: self class comment! !!Class methodsFor: 'pool variables' stamp: 'tk 9/12/96'!removeSharedPool: aDictionary     "Remove the pool dictionary, aDictionary, as one of the receiver's pool     dictionaries. Create an error notification if the dictionary is not one of     the pools.    : Note that it removes the wrong one if there are two empty Dictionaries in the list."    | satisfiedSet workingSet aSubclass |    (self sharedPools includes: aDictionary)        ifFalse: [^self error: 'the dictionary is not in my pool'].    "first see if it is declared in a superclass in which case we can remove it."    (self selectSuperclasses: [:class | class sharedPools includes: aDictionary]) isEmpty        ifFalse: [sharedPools remove: aDictionary.                sharedPools isEmpty ifTrue: [sharedPools _ nil].                ^self].     "second get all the subclasses that reference aDictionary through me rather than a     superclass that is one of my subclasses."    workingSet _ self subclasses asOrderedCollection.    satisfiedSet _ Set new.    [workingSet isEmpty] whileFalse:        [aSubclass _ workingSet removeFirst.        (aSubclass sharedPools includes: aDictionary)            ifFalse:                 [satisfiedSet add: aSubclass.                workingSet addAll: aSubclass subclasses]].    "for each of these, see if they refer to any of the variables in aDictionary because     if they do, we can not remove the dictionary."    satisfiedSet add: self.    satisfiedSet do:         [:sub |         aDictionary associationsDo:             [:aGlobal |             (sub whichSelectorsReferTo: aGlobal) isEmpty                 ifFalse: [^self error: aGlobal key                                 , ' is still used in code of class '                                , sub name]]].    sharedPools remove: aDictionary.    sharedPools isEmpty ifTrue: [sharedPools _ nil]! !!Class methodsFor: 'compiling' stamp: 'tk 9/11/96'!scopeHas: varName ifTrue: assocBlock     "Look up the first argument, varName, in the context of the receiver. If it is there,    pass the association to the second argument, assocBlock, and answer true.    Else answer false.    : Allow key in shared pools to be a string for HyperSqueak"    | assoc |    assoc _ self classPool associationAt: varName ifAbsent: [].    assoc == nil        ifFalse:             [assocBlock value: assoc.            ^true].    self sharedPools do:         [:pool |         varName = #Textual ifTrue: [self halt].        assoc _ pool associationAt: varName ifAbsent: [            pool associationAt: varName asString ifAbsent: []].        assoc == nil            ifFalse:                 [assocBlock value: assoc.                ^true]].    superclass == nil        ifTrue:             [assoc _ Smalltalk associationAt: varName ifAbsent: [].            assoc == nil                ifFalse:                     [assocBlock value: assoc.                    ^true].            ^false].    ^superclass scopeHas: varName ifTrue: assocBlock! !!Class methodsFor: 'fileIn/Out' stamp: 'di 6/28/97 09:58'!fileOut    "Create a file whose name is the name of the receiver with '.st' as the     extension, and file a description of the receiver onto it."    ^ self fileOutAsHtml: false! !!Class methodsFor: 'fileIn/Out' stamp: 'di 6/28/97 20:28'!fileOutAsHtml: useHtml    "Create a file whose name is the name of the receiver with '.st' as the     extension, and file a description of the receiver onto it."    | fileStream |    fileStream _ useHtml        ifTrue: [(FileStream newFileNamed: self name , '.html') asHtml]        ifFalse: [FileStream newFileNamed: self name , '.st'].    fileStream header; timeStamp.    self sharedPools size > 0 ifTrue:        [self shouldFileOutPools            ifTrue: [self fileOutSharedPoolsOn: fileStream]].    self fileOutOn: fileStream moveSource: false toFile: 0.    fileStream trailer; close! !!ClassCategoryReader methodsFor: 'fileIn/Out' stamp: '6/5/97 di'!scanFrom: aStream     "File in methods from the stream, aStream."    | methodString |    [(methodString _ aStream nextChunk) size > 0]        whileTrue:        [class compile: methodString classified: category            withStamp: changeStamp            notifying: (SyntaxError new category: category)]! !!ClassCategoryReader methodsFor: 'private' stamp: '6/5/97 di'!setClass: aClass category: aCategory    ^ self setClass: aClass category: aCategory changeStamp: String new! !!ClassCategoryReader methodsFor: 'private' stamp: '6/5/97 di'!setClass: aClass category: aCategory changeStamp: aString    class _ aClass.    category _ aCategory.    changeStamp _ aString! !!ClassDescription methodsFor: 'initialize-release'!subclassOf: newSuper oldClass: oldClass instanceVariableNames: newInstVarString variable: v words: w pointers: p ifBad: badBlock     "Basic initialization message for creating classes using the information     provided as arguments. Answer whether old instances will be     invalidated."    | oldNames newNames usedNames invalid oldSuperMeta newInstVarArray oldSpec |    oldNames _ self allInstVarNames.    usedNames _ #(self super thisContext true false nil ) asSet.    newInstVarArray _ Scanner new scanFieldNames: newInstVarString.    newNames _ newSuper allInstVarNames , newInstVarArray.    newNames size > 254 ifTrue:        [self error: 'A class cannot have more than 254 instance variables'.        ^ badBlock value].    newNames do:         [:fieldName |         (usedNames includes: fieldName)            ifTrue:                 [self error: fieldName , ' is reserved (maybe in a superclass)'.                ^ badBlock value].        usedNames add: fieldName].    (invalid _ superclass ~~ newSuper)        ifTrue:             ["superclass changed"            oldSuperMeta _ superclass class.            superclass removeSubclass: self.            superclass _ newSuper.            superclass addSubclass: self.            self class superclass == oldSuperMeta                 ifTrue: ["Only false when self is a metaclass"                        self class superclass: newSuper class]].    instanceVariables _ newInstVarArray size = 0 ifFalse: [newInstVarArray].    invalid _ invalid | (newNames  ~= oldNames).   "field names changed"    oldSpec _ self instSpec.    self format: newNames size        variable: v        words: w        pointers: p.    invalid _ invalid | (self instSpec ~= oldSpec).  "format changed"    ^invalid! !!ClassDescription methodsFor: 'initialize-release'!updateInstancesFrom: oldClass     "Recreate any existing instances of the argument, oldClass, as instances of     the receiver, which is a newly changed class. Permute variables as     necessary."    | oldInstVarNames map variable new instSize oldInstances |    oldClass someInstance == nil ifTrue: [^self].    "no instances to convert"    oldInstVarNames _ oldClass allInstVarNames.    map _         self allInstVarNames             collect: [:instVarName | oldInstVarNames indexOf: instVarName].    variable _ self isVariable.    instSize _ self instSize.    "Now perform a bulk mutation of old instances into new ones"    oldInstances _ oldClass allInstances asArray.    oldInstances elementsExchangeIdentityWith:        (oldInstances collect:         [:old |         variable            ifTrue: [new _ self basicNew: old basicSize]            ifFalse: [new _ self basicNew].        1 to: instSize do:             [:offset |  (map at: offset) > 0 ifTrue:                [new instVarAt: offset                        put: (old instVarAt: (map at: offset))]].        variable             ifTrue: [1 to: old basicSize do:                         [:offset |                        new basicAt: offset put: (old basicAt: offset)]].        new])! !!ClassDescription methodsFor: 'initialize-release'!validateFrom: oldClass in: environ instanceVariableNames: invalidFields methods: invalidMethods     "Recompile the receiver, a class, and redefine its subclasses if necessary.    The parameter invalidFields is no longer really used"    | newSub invalidSubMethods |    oldClass becomeUncompact.  "Its about to be abandoned"    invalidMethods & self hasMethods        ifTrue:             [Transcript show: 'recompiling ' , self name , '...'.            self compileAllFrom: oldClass.            Transcript show: ' done'; cr].    invalidSubMethods _ invalidMethods | (self instSize ~= oldClass instSize).    self == oldClass        ifTrue: [invalidSubMethods ifFalse: [^self]]        ifFalse: [self updateInstancesFrom: oldClass].    oldClass subclasses do:         [:sub |         newSub _ sub copyForValidation.        newSub            subclassOf: self            oldClass: sub            instanceVariableNames: sub instVarNames            variable: sub isVariable            words: sub isBytes not            pointers: sub isBits not            ifBad: [self error: 'terrible problem in recompiling subclasses!!'].        newSub            validateFrom: sub            in: environ            instanceVariableNames: invalidFields            methods: invalidSubMethods]! !!ClassDescription methodsFor: 'accessing'!comment    "Answer the receiver's comment."    | aString |    aString _ self theNonMetaClass organization classComment.    aString size = 0 ifTrue: [^''].    "get string only of classComment, undoubling quotes"    ^ String readFromString: aString! !!ClassDescription methodsFor: 'accessing'!comment: aString     "Set the receiver's comment to be the argument, aString."    aString size = 0        ifTrue:             [self theNonMetaClass organization classComment: aString]        ifFalse:             [self theNonMetaClass organization classComment:                (String streamContents:                [:strm | strm nextPutAll: self name , ' comment:'; cr.                aString storeOn: strm])].    Smalltalk changes commentClass: self! !!ClassDescription methodsFor: 'printing'!classVariablesString    "Answer a string of my class variable names separated by spaces."    | aStream |    aStream _ WriteStream on: (String new: 100).    self classPool keys asSortedCollection do: [:key | aStream nextPutAll: key; space].    ^aStream contents! !!ClassDescription methodsFor: 'printing'!sharedPoolsString    "Answer a string of my shared pool names separated by spaces."    | aStream |    aStream _ WriteStream on: (String new: 100).    self sharedPools do: [:x | aStream nextPutAll: (Smalltalk keyAtValue: x ifAbsent: ['private']); space].    ^ aStream contents! !!ClassDescription methodsFor: 'instance variables' stamp: 'di 7/15/97 00:04'!renameInstVar: oldName to: newName    | i oldCode newCode parser header body sels |    (i _ instanceVariables indexOf: oldName) = 0 ifTrue:        [self error: oldName , ' is not defined in ', self name].    self allSuperclasses , self withAllSubclasses asOrderedCollection do:        [:cls | (cls instVarNames includes: newName) ifTrue:            [self error: newName , ' is already used in ', cls name]].    (self confirm: 'WARNING: Renaming of instance variablesis subject to substitution ambiguities.Do you still wish to attempt it?') ifFalse: [self halt].    "...In other words, this does a dumb text search-and-replace,    which might improperly alter, eg, a literal string.  As long as    the oldName is unique, everything should work jes' fine. - di"    instanceVariables replaceFrom: i to: i with: (Array with: newName).    self withAllSubclasses do:        [:cls | sels _ cls selectors.        sels removeAllFoundIn: #(DoIt DoItIn:).        sels do:            [:sel |            oldCode _ cls sourceCodeAt: sel.            "Don't make changes in the method header"            (parser _ cls parserClass new) parseSelector: oldCode.            header _ oldCode copyFrom: 1 to: (parser endOfLastToken min: oldCode size).            body _ header size > oldCode size                    ifTrue: ['']                    ifFalse: [oldCode copyFrom: header size+1 to: oldCode size].            newCode _ header , (body copyReplaceTokens: oldName with: newName).            newCode ~= oldCode ifTrue:                [cls compile: newCode                    classified: (cls organization categoryOfElement: sel)                    notifying: nil]].            cls isMeta ifFalse:                [oldCode _ cls comment.                newCode _ oldCode copyReplaceTokens: oldName with: newName.                newCode ~= oldCode ifTrue:                    [cls comment: newCode]]]! !!ClassDescription methodsFor: 'method dictionary' stamp: 'di 6/14/97 16:03'!removeSelector: aSymbol     "Remove the message whose selector is aSymbol from the method     dictionary of the receiver, if it is there. Answer nil otherwise."    (methodDict includesKey: aSymbol) ifFalse: [^nil].    Smalltalk changes removeSelector: aSymbol class: self.    super removeSelector: aSymbol.    self organization removeElement: aSymbol.    self acceptsLoggingOfCompilation ifTrue:        [Smalltalk logChange: self name , ' removeSelector: #' , aSymbol]! !!ClassDescription methodsFor: 'organization'!zapOrganization    "Remove the organization of this class by message categories.    This is typically done to save space in small systems.  Classes and methods    created or filed in subsequently will, nonetheless, be organized"    organization _ nil.    self isMeta ifFalse: [self class zapOrganization]! !!ClassDescription methodsFor: 'compiling' stamp: '6/5/97 di'!compile: text classified: category notifying: requestor     ^ self compile: text classified: category        withStamp: Utilities changeStamp notifying: requestor ! !!ClassDescription methodsFor: 'compiling' stamp: '6/5/97 di'!compile: text classified: category withStamp: changeStamp notifying: requestor     | selector priorMethod method methodNode |    method _ self        compile: text asString        notifying: requestor        trailer: #(0 0 0 0)        ifFail: [^nil]        elseSetSelectorAndNode:             [:sel :node | selector _ sel.            priorMethod _ methodDict at: selector ifAbsent: [nil].            methodNode _ node].    self acceptsLoggingOfCompilation ifTrue:        [method putSource: text asString                fromParseNode: methodNode                class: self category: category withStamp: changeStamp                 inFile: 2 priorMethod: priorMethod].    self organization classify: selector under: category.    ^selector! !!ClassDescription methodsFor: 'fileIn/Out' stamp: 'di 6/28/97 10:06'!fileOutCategory: catName     ^ self fileOutCategory: catName asHtml: false! !!ClassDescription methodsFor: 'fileIn/Out' stamp: 'di 6/28/97 10:05'!fileOutCategory: catName asHtml: useHtml    "FileOut the named category, possibly in Html format."    | fileStream |    fileStream _ useHtml        ifTrue: [(FileStream newFileNamed: self name , '-' , catName , '.html') asHtml]        ifFalse: [FileStream newFileNamed: self name , '-' , catName , '.st'].    fileStream header; timeStamp.    self fileOutCategory: catName on: fileStream moveSource: false toFile: 0.    fileStream trailer; close! !!ClassDescription methodsFor: 'fileIn/Out' stamp: 'di 6/27/97 05:27'!fileOutCategory: aString on: aFileStream moveSource: moveSource toFile: fileIndex     "File a description of the receiver's category, aString, onto aFileStream. If     moveSource, is true, then set the method source pointer to the new file position.    Note when this method is called with moveSource=true, it is condensing the    .sources file, and should only write one preamble per method category."    aFileStream cr.    moveSource ifTrue:        ["Single header for condensing source files"        self printCategoryChunk: aString on: aFileStream].    (self organization listAtCategoryNamed: aString)        do: [:sel | self printMethodChunk: sel withPreamble: moveSource not                        on: aFileStream moveSource: moveSource toFile: fileIndex].    moveSource ifTrue: [aFileStream nextChunkPut: ' ']! !!ClassDescription methodsFor: 'fileIn/Out' stamp: 'di 6/26/97 21:41'!fileOutChangedMessages: aSet on: aFileStream moveSource: moveSource toFile: fileIndex     "File a description of the messages of this class that have been     changed (i.e., are entered into the argument, aSet) onto aFileStream.  If     moveSource, is true, then set the method source pointer to the new file position.    Note when this method is called with moveSource=true, it is condensing the    .changes file, and should only write a preamble for every method."    | org sels |    (org _ self organization) categories do:         [:cat |         sels _ (org listAtCategoryNamed: cat) select: [:sel | aSet includes: sel].        sels do:            [:sel |  self printMethodChunk: sel withPreamble: true on: aFileStream                            moveSource: moveSource toFile: fileIndex]]! !!ClassDescription methodsFor: 'fileIn/Out' stamp: 'di 6/28/97 15:52'!fileOutMethod: selector    "Write source code of a single method on a file.  Make up a name for the file."    self fileOutMethod: selector asHtml: false! !!ClassDescription methodsFor: 'fileIn/Out' stamp: 'di 6/28/97 15:51'!fileOutMethod: selector asHtml: useHtml    "Write source code of a single method on a file in .st or .html format"    | fileStream nameBody |    (self includesSelector: selector) ifFalse: [^ self halt: 'Selector not found'].    nameBody _ self name , '-' , (selector copyReplaceAll: ':' with: '').    fileStream _ useHtml        ifTrue: [(FileStream newFileNamed: nameBody , '.html') asHtml]        ifFalse: [FileStream newFileNamed: nameBody , '.st'].    fileStream header; timeStamp.    self printMethodChunk: selector withPreamble: true        on: fileStream moveSource: false toFile: 0.    fileStream close! !!ClassDescription methodsFor: 'fileIn/Out' stamp: 'di 6/28/97 20:31'!fileOutOn: aFileStream moveSource: moveSource toFile: fileIndex    "File a description of the receiver on aFileStream. If the boolean     argument, moveSource, is true, then set the trailing bytes to the position     of aFileStream and to fileIndex in order to indicate where to find the     source code."    aFileStream command: 'H3'.        aFileStream nextChunkPut: self definition.        aFileStream command: '/H3'.    self organization        putCommentOnFile: aFileStream        numbered: fileIndex        moveSource: moveSource.    self organization categories do:         [:heading |        self            fileOutCategory: heading            on: aFileStream            moveSource: moveSource            toFile: fileIndex]! !!ClassDescription methodsFor: 'fileIn/Out' stamp: 'di 6/28/97 20:35'!fileOutOrganizationOn: aFileStream    "File a description of the receiver's organization on aFileStream."    aFileStream cr; nextPut: $!!.    aFileStream nextChunkPut: self name, ' reorganize'; cr.    aFileStream nextChunkPut: self organization printString; cr! !!ClassDescription methodsFor: 'fileIn/Out' stamp: '6/5/97 di'!methods    "Answer a ClassCategoryReader for compiling messages that are not classified, as in fileouts made with Smalltalk/V"    ^ ClassCategoryReader new setClass: self                            category: 'as yet unclassified' asSymbol! !!ClassDescription methodsFor: 'fileIn/Out' stamp: '6/5/97 di'!methodsFor: categoryName     "Answer a ClassCategoryReader for compiling the messages in the category, categoryName, of the receiver."    ^ ClassCategoryReader new setClass: self category: categoryName asSymbol    "False methodsFor: 'logical operations' inspect"! !!ClassDescription methodsFor: 'fileIn/Out' stamp: 'di 6/13/97 13:51'!methodsFor: categoryName stamp: changeStamp     ^ self methodsFor: categoryName stamp: (Utilities fixStamp: changeStamp) prior: 0! !!ClassDescription methodsFor: 'fileIn/Out' stamp: '6/5/97 di'!methodsFor: categoryName stamp: changeStamp prior: indexAndOffset    "Prior source link ignored when filing in."    ^ ClassCategoryReader new setClass: self                category: categoryName asSymbol                changeStamp: changeStamp! !!ClassDescription methodsFor: 'fileIn/Out' stamp: '6/5/97 di'!printCategoryChunk: categoryName on: aFileStream    ^ self printCategoryChunk: categoryName withStamp: '' on: aFileStream! !!ClassDescription methodsFor: 'fileIn/Out' stamp: '6/5/97 di'!printCategoryChunk: category on: aFileStream priorMethod: priorMethod    ^ self printCategoryChunk: category on: aFileStream        withStamp: Utilities changeStamp priorMethod: priorMethod! !!ClassDescription methodsFor: 'fileIn/Out' stamp: 'di 6/26/97 11:51'!printCategoryChunk: category on: aFileStream withStamp: changeStamp priorMethod: priorMethod    "Print a method category preamble.  This must have a category name.    It may have an author/date stamp, and it may have a prior source link.    If it has a prior source link, it MUST have a stamp, even if it is empty.""The current design is that changeStamps and prior source links are preserved in the changes file.  All fileOuts include changeStamps.  Condensing sources, however, eliminates all stamps (and links, natch)."    aFileStream cr; command: 'H3'; nextPut: $!!.    aFileStream nextChunkPut: (String streamContents:        [:strm |        strm nextPutAll: self name; nextPutAll: ' methodsFor: '; print: category asString.        (changeStamp size > 0 or: [priorMethod ~~ nil]) ifTrue:            [strm nextPutAll: ' stamp: '; print: changeStamp].        priorMethod ~~ nil ifTrue:            [strm nextPutAll: ' prior: '; print: priorMethod sourcePointer]]).    aFileStream command: '/H3'.! !!ClassDescription methodsFor: 'fileIn/Out' stamp: '6/6/97 di'!printCategoryChunk: categoryName withStamp: changeStamp on: aFileStream    ^ self printCategoryChunk: categoryName on: aFileStream withStamp: changeStamp        priorMethod: nil! !!ClassDescription methodsFor: 'fileIn/Out' stamp: 'di 6/28/97 08:55'!printMethodChunk: selector withPreamble: doPreamble on: outStream        moveSource: moveSource toFile: fileIndex    "Copy the source code for the method associated with selector onto the fileStream.  If moveSource true, then also set the source code pointer of the method."    | preamble method oldPos newPos sourceFile |    doPreamble         ifTrue: [preamble _ self name , ' methodsFor: ' ,                    (self organization categoryOfElement: selector) asString printString]        ifFalse: [preamble _ ''].    method _ methodDict at: selector.    ((method fileIndex = 0        or: [(SourceFiles at: method fileIndex) == nil])        or: [(oldPos _ method filePosition) = 0])        ifTrue:        ["The source code is not accessible.  We must decompile..."        preamble size > 0 ifTrue: [outStream cr; nextPut: $!!; nextChunkPut: preamble; cr].        outStream nextChunkPut: (self decompilerClass new decompile: selector                                            in: self method: method) decompileString]        ifFalse:        [sourceFile _ SourceFiles at: method fileIndex.        sourceFile position: oldPos.        preamble size > 0 ifTrue:    "Copy the preamble"            [outStream copyPreamble: preamble from: sourceFile].        "Copy the method chunk"        newPos _ outStream position.        outStream copyMethodChunkFrom: sourceFile.        moveSource ifTrue:    "Set the new method source pointer"            [method setSourcePosition: newPos inFile: fileIndex]].    preamble size > 0 ifTrue: [outStream nextChunkPut: ' '].    ^ outStream cr.! !!ClassDescription methodsFor: 'fileIn/Out'!reformatMethodAt: selector     | newCodeString method |     newCodeString _ (self compilerClass new)        format: (self sourceCodeAt: selector)        in: self        notifying: nil.    method _ self compiledMethodAt: selector.    method        putSource: newCodeString        fromParseNode: nil        class: self        category: (self organization categoryOfElement: selector)        inFile: 2 priorMethod: method! !!ClassDescription methodsFor: 'private'!spaceUsed    "Answer a rough estimate of number of bytes in this class and its metaclass"    | space method |    space _ 0.    self selectorsDo:        [:sel | space _ space + 16.  "dict and org'n space"        method _ self compiledMethodAt: sel.        space _ space + (method size + 6 "hdr + avg pad").        method literals do:            [:lit | ((lit isMemberOf: Symbol) or: [lit isMemberOf: SmallInteger]) ifFalse:                [(lit isMemberOf: String) ifTrue: [space _ space + (lit size+6)].                (lit isMemberOf: Array) ifTrue: [space _ space + (lit size+1*4)]]]].    (self isMemberOf: Metaclass)        ifTrue: [^ space]        ifFalse: [^ space + self class space]! !ClassListBrowser comment:'A browser on an arbitrary list of classes.  It holds on to a classListGenerator, a block which will generate a clean class list when required.  12/6/96 sw'!!ClassListBrowser methodsFor: 'everything' stamp: 'sw 12/6/96'!classListGenerator: generatorBlock    "Initialize the receiver such that it obtains its class list from generatorBlock.  "    classListGenerator _ generatorBlock.    classList _ generatorBlock value! !!ClassListBrowser methodsFor: 'everything'!updateSystemCategories    "The class categories were changed in another browser. The receiver must     reorganize its lists based on these changes."    self okToChange ifFalse: [^ self].    self systemCategoryListIndex: 0.    classList _ classListGenerator value.    self changed: #classListChanged.    self changed: #systemCategoriesChanged! !!ClassListController methodsFor: 'menu messages' stamp: 'di 6/28/97 20:28'!fileOut    "Print a description of the selected class onto an external file in .st format."    self controlTerminate.    Cursor write showWhile:        [model fileOutClass].    self controlInitialize! !!ClassListController methodsFor: 'menu messages' stamp: 'di 6/28/97 20:27'!printOut    "Print a description of the selected class onto an external file in HTML format."    self controlTerminate.    Cursor write showWhile:        [model printOutClass].    self controlInitialize! !!ClassListController methodsFor: 'menu messages'!spawnHierarchy        "Request that the receiver's view display the class hierarchy (super- and         subclasses) of the selected class so that it can be edited."        self controlTerminate.        model spawnHierarchy.        self controlInitialize! !!ClassListController methodsFor: 'menu messages'!spawnProtocol        "Request that the receiver's model open a protocol browser."        self controlTerminate.        model spawnProtocol.        self controlInitialize! !!ClassListController class methodsFor: 'class initialization' stamp: 'stp 11/12/96'!initialize        "Initialize the yellow button menu information.         2/1/96 sw: added class vars         7/29/96 sw: added 'find method' feature        11/11/96 stp: added spawn protocol and separated show/spawn hierarchy        : added recent classes feature       : recent classes feature moved to system category-list pane"                ClassListYellowButtonMenu :=                PopUpMenu                                 labels: 'browse classprintOutfileOuthierarchydefinitioncommentspawn hierarchyspawn protocolinst var refs..inst var defs..class var refs...class varsclass refsrename...removefind method...'                                 lines: #(3 6 8 10 13 16).        ClassListYellowButtonMessages :=                 #(browse  printOut fileOut                hierarchy definition comment                spawnHierarchy spawnProtocol                browseInstVarRefs browseInstVarDefs browseClassVarRefs classVariables browseClassRefs                rename remove findMethod)        "        ClassListController initialize.        ClassListController allInstancesDo:                [:x | x initializeYellowButtonMenu].        "! !!ClassOrganizer methodsFor: 'accessing'!changeFromString: aString     "Parse the argument, aString, and make this be the receiver's structure."    | scanner oldElements newElements newCategories newStops currentStop anArray |    scanner _ Scanner new scanTokens: aString.    "If nothing was scanned and I had no elements before, then default me"    (scanner size = 0 and: [elementArray size = 0])        ifTrue: [^self setDefaultList: Array new].    oldElements _ elementArray asSet.    newCategories _ Array new: scanner size.    newStops _ Array new: scanner size.    currentStop _ 0.    newElements _ WriteStream on: (Array new: 16).    1 to: scanner size do:         [:i |         anArray _ scanner at: i.        newCategories at: i put: anArray first asSymbol.        anArray allButFirst asSortedCollection do:            [:elem |            (oldElements remove: elem ifAbsent: [nil]) notNil ifTrue:                [newElements nextPut: elem.                currentStop _ currentStop+1]].        newStops at: i put: currentStop].    "Ignore extra elements but don't lose any existing elements!!"    oldElements _ oldElements collect:        [:elem | Array with: (self categoryOfElement: elem) with: elem].    newElements _ newElements contents.    categoryArray _ newCategories.    categoryStops _ newStops.    elementArray _ newElements.    oldElements do: [:pair | self classify: pair last under: pair first].! !!ClassOrganizer methodsFor: 'compiler access'!classify: element under: heading     "Store the argument, element, in the category named heading."    | catName catIndex elemIndex realHeading |    heading = NullCategory        ifTrue: [realHeading _ Default]        ifFalse: [realHeading _ heading asSymbol].    (catName _ self categoryOfElement: element) = realHeading        ifTrue: [^self].  "done if already under that category"    catName ~~ nil ifTrue:         [realHeading = Default            ifTrue: [^self].    "return if exists and realHeading is default"        self removeElement: element].    "remove if in another category"    (categoryArray indexOf: realHeading) = 0 ifTrue: [self addCategory: realHeading].    "add realHeading if not there already"    catIndex _ categoryArray indexOf: realHeading.    elemIndex _         catIndex > 1            ifTrue: [categoryStops at: catIndex - 1]            ifFalse: [0].    [(elemIndex _ elemIndex + 1) <= (categoryStops at: catIndex)         and: [element >= (elementArray at: elemIndex)]] whileTrue.    "elemIndex is now the index for inserting the element. Do the insertion before it."    elementArray _ elementArray copyReplaceFrom: elemIndex to: elemIndex-1                        with: (Array with: element).    "add one to stops for this and later categories"    catIndex to: categoryArray size do:         [:i | categoryStops at: i put: (categoryStops at: i) + 1].    (self listAtCategoryNamed: Default) size = 0 ifTrue: [self removeCategory: Default]! !!ClassOrganizer methodsFor: 'method dictionary'!addCategory: catString before: nextCategory    "Add a new category named heading.    If default category exists and is empty, remove it.    If nextCategory is nil, then add the new one at the end,    otherwise, insert it before nextCategory."    | index newCategory |    newCategory _ catString asSymbol.    (categoryArray indexOf: newCategory) > 0        ifTrue: [^self].    "heading already exists, so done"    index _ categoryArray indexOf: nextCategory        ifAbsent: [categoryArray size + 1].    categoryArray _ categoryArray        copyReplaceFrom: index        to: index-1        with: (Array with: newCategory).    categoryStops _ categoryStops        copyReplaceFrom: index        to: index-1        with: (Array with: (index = 1                ifTrue: [0]                ifFalse: [categoryStops at: index-1])).    "remove empty default category"    (newCategory ~= Default            and: [(self listAtCategoryNamed: Default) isEmpty])        ifTrue: [self removeCategory: Default]! !!ClassOrganizer methodsFor: 'method dictionary'!removeCategory: cat     "Remove the category named, cat. Create an error notificiation if the     category has any elements in it."    | index lastStop |    index _ categoryArray indexOf: cat ifAbsent: [^self].    lastStop _         index = 1            ifTrue: [0]            ifFalse: [categoryStops at: index - 1].    (categoryStops at: index) - lastStop > 0         ifTrue: [^self error: 'cannot remove non-empty category'].    categoryArray _ categoryArray copyReplaceFrom: index to: index with: Array new.    categoryStops _ categoryStops copyReplaceFrom: index to: index with: Array new.    categoryArray size = 0        ifTrue:            [categoryArray _ Array with: Default.            categoryStops _ Array with: 0]! !!ClippingMorph methodsFor: 'all'!fullBounds    "Overridden to clip submorph hit detection to my bounds."    ^ bounds! !!ClippingMorph methodsFor: 'all'!fullDrawOn: aCanvas    "Overridden to clip submorph drawing to my bounds."    | clippingCanvas |    (aCanvas isVisible: self bounds) ifFalse: [^ self].    self drawOn: aCanvas.    clippingCanvas _ aCanvas copyClipRect: bounds.    submorphs isEmpty ifFalse: [        submorphs reverseDo: [:m | m fullDrawOn: clippingCanvas]].  "draw back-to-front"! !!ClippingTextMorph methodsFor: 'drawing'!fullBounds    "Overridden to clip submorph hit detection to my bounds."    ^ bounds! !!ClippingTextMorph methodsFor: 'drawing'!fullDrawOn: aCanvas    "Overridden to clip submorph drawing to my bounds."    | clippingCanvas |    (aCanvas isVisible: self bounds) ifFalse: [^ self].    self drawOn: aCanvas.    clippingCanvas _ aCanvas copyClipRect: bounds.    submorphs isEmpty ifFalse: [        submorphs reverseDo: [:m | m fullDrawOn: clippingCanvas]].  "draw back-to-front"! !!ClockMorph methodsFor: 'all'!step    self contents: Time now printString.! !!ClockMorph methodsFor: 'all'!stepTime    "Answer the desired time between steps in milliseconds."    ^ 1000! !!CngsMsgList methodsFor: 'as yet unclassified' stamp: 'di 6/15/97 15:24'!versions    "Create and schedule a changelist browser on the versions of the     selected message."    | class selector method category pair sourcePointer |    listIndex = 0 ifTrue: [^ self].    class _ parent selectedClassOrMetaClass.    selector _ parent selectedMessageName.    (class includesSelector: selector)        ifTrue: [method _ class compiledMethodAt: selector.                category _ class whichCategoryIncludesSelector: selector.                sourcePointer _ nil]        ifFalse: [pair _ parent changeSet methodRemoves                            at: (Array with: class name with: selector)                            ifAbsent: [^ nil].                sourcePointer _ pair first.                method _ CompiledMethod toReturnSelf setSourcePointer: sourcePointer.                category _ pair last].    controller controlTerminate.    ChangeList        browseVersionsOf: method        class: parent selectedClass meta: class isMeta        category: category selector: selector        lostMethodPointer: sourcePointer.    controller controlInitialize! !!CodeBrowser methodsFor: 'initialization' stamp: 'di 6/16/97 14:54'!extent: newExtent    | w h inner labelRect |    super extent: newExtent.    inner _ self innerBounds.    labelRect _ inner topLeft corner: inner topRight + (0@self labelHeight).    w _ inner width - 2 // 4.  h _ inner height - labelRect height // 3.    systemPane bounds: (labelRect bottomLeft + (1@1) extent: w @ h).    classPane bounds: (systemPane bounds topRight extent: w @ (h - 20)).    categoryPane bounds: (classPane bounds topRight extent: w @ h).    messagePane bounds: (categoryPane bounds topRight corner: inner right-2 @ categoryPane bounds bottom).    instButton bounds: (systemPane bounds bottomRight + (2@-2) rect: classPane bounds bottomCenter + (0@2)).    classButton bounds: (categoryPane bounds bottomLeft + (-2@-2) rect: classPane bounds bottomCenter + (0@2)).    codePane bounds: (systemPane bounds bottomLeft corner: inner bottomRight - 1)! !!CodeBrowser methodsFor: 'initialization' stamp: 'di 6/16/97 15:04'!initialize    super initialize.    systemPane list: SystemOrganization categories.    self metaClassIndicated: false! !!CodeBrowser methodsFor: 'initialization' stamp: 'di 6/16/97 15:08'!initPanes    self addMorph: (systemPane _ ListPane new model: self slotName: 'systemPane').    self addMorph: (classPane _ ListPane new model: self slotName: 'classPane').    self addMorph: (instButton _ SimpleButtonMorph new borderWidth: 2; color: paneColor;                            label: 'inst'; actionSelector: #instanceMode; target: self).    self addMorph: (classButton _ SimpleButtonMorph new borderWidth: 2; color: paneColor;                            label: 'class'; actionSelector: #classMode; target: self).    self addMorph: (categoryPane _ ListPane new model: self slotName: 'categoryPane').    self addMorph: (messagePane _ ListPane new model: self slotName: 'messagePane').    self addMorph: (codePane _ ScrollPane new model: self slotName: 'codePane').! !!CodeBrowser methodsFor: 'input events'!categoryPaneMenuButtonPressed: arg1"Automatically generated null response.""Add code below for appropriate behavior..."! !!CodeBrowser methodsFor: 'input events' stamp: '6/6/97 15:54 di'!categoryPaneNewSelection: arg1    arg1 ifNil: [^ messagePane list: Array new].    messagePane list: (self selectedClassOrMetaClass organization listAtCategoryNamed: arg1)! !!CodeBrowser methodsFor: 'input events'!classPaneMenuButtonPressed: arg1"Automatically generated null response.""Add code below for appropriate behavior..."! !!CodeBrowser methodsFor: 'input events' stamp: '6/6/97 15:44 di'!classPaneNewSelection: arg1    arg1 ifNil: [^ categoryPane list: Array new].    categoryPane list: self selectedClassOrMetaClass organization categories! !!CodeBrowser methodsFor: 'input events'!codePaneMenuButtonPressed: arg1"Automatically generated null response.""Add code below for appropriate behavior..."! !!CodeBrowser methodsFor: 'input events'!messagePaneMenuButtonPressed: arg1"Automatically generated null response.""Add code below for appropriate behavior..."! !!CodeBrowser methodsFor: 'input events' stamp: '6/6/97 15:51 di'!messagePaneNewSelection: arg1    codePane scroller removeAllMorphs.    arg1 ifNil: [^ self].    codePane scroller addMorph:        (TextMorph new contents:            (self selectedClassOrMetaClass sourceMethodAt: arg1))! !!CodeBrowser methodsFor: 'input events'!systemPaneNewSelection: arg1    classPane list: (SystemOrganization listAtCategoryNamed: arg1)! !!CodeBrowser methodsFor: 'system pane' stamp: 'jm 9/28/97 19:19'!systemPaneMenuButtonPressed: event    | menu |    menu _ MenuMorph new defaultTarget: self.    menu addTitle: 'system category'.    "**these two belong in class pane**"    menu add: 'select class...' action: #selectClass.    menu add: 'select recent...' action: #selectRecentClass.    menu add: 'browse all classes' action: #browseAllClasses.    menu add: 'spawn selection' action: #spawnSystemCategory.    menu addLine.    menu add: 'fileOut' action: #fileOutSystemCategory.    menu addLine.    menu add: 'reorganize' action: #editSystemOrganization.    menu add: 'add selection...' action: #addSystemCategory.    menu add: 'rename selection...' action: #renameSystemCategory.    menu add: 'remove selection' action: #removeSystemCategory.    event hand invokeMenu: menu event: event.! !!CodeBrowser methodsFor: 'private' stamp: '6/6/97 15:47 di'!classMode    self metaClassIndicated: true! !!CodeBrowser methodsFor: 'private' stamp: '6/6/97 15:47 di'!instanceMode    self metaClassIndicated: false! !!CodeBrowser methodsFor: 'private' stamp: '6/6/97 15:50 di'!metaClassIndicated: trueOrFalse    metaClassIndicated == trueOrFalse ifTrue: [^ self].    (metaClassIndicated _ trueOrFalse)        ifTrue: [instButton color: paneColor.                classButton color: paneColor darker]        ifFalse: [instButton color: paneColor darker.                classButton color: paneColor].    classPane selection == nil ifFalse:        [categoryPane list: self selectedClassOrMetaClass organization categories]! !!CodeBrowser methodsFor: 'private' stamp: '6/6/97 15:44 di'!selectedClass    ^ Smalltalk at: classPane selection! !!CodeBrowser methodsFor: 'private' stamp: '6/6/97 15:32 di'!selectedClassOrMetaClass    ^ metaClassIndicated        ifTrue: [self selectedClass class]        ifFalse: [self selectedClass]! !!CodeBrowser class methodsFor: 'instance creation' stamp: 'di 6/18/97 05:33'!new    ^ self labelled: 'System Browser'! !!Collection methodsFor: 'enumerating' stamp: 'di 7/5/97 14:56'!sum    "Return the sum of all my elements."    | sum |  sum _ 0.    self do: [:each | sum _ sum + each].      ^ sum! !!Collection methodsFor: 'printing' stamp: 'di 6/20/97 09:09'!printOn: aStream     "Refer to the comment in Object|printOn:."    aStream nextPutAll: self class name, ' ('.    self do: [:element | element printOn: aStream. aStream space].    aStream nextPut: $)! !!Color methodsFor: 'access'!alpha    "Return the opacity ('alpha') value of opaque so that normal colors can be compared to TransparentColors."    ^ 1.0! !!Color methodsFor: 'access'!blue    "Return the blue component of this color, a float in the range [0.0..1.0]."    ^ self privateBlue asFloat / ComponentMax! !!Color methodsFor: 'access'!brightness    "Return the brightness of this color, a float in the range [0.0..1.0]."    ^ ((self privateRed max:        self privateGreen) max:        self privateBlue) asFloat / ComponentMax! !!Color methodsFor: 'access'!green    "Return the green component of this color, a float in the range [0.0..1.0]."    ^ self privateGreen asFloat / ComponentMax! !!Color methodsFor: 'access'!luminance    "Return the luminance of this color, a brightness value weighted by the human eye's color sensitivity."    ^ ((299 * self privateRed) +       (587 * self privateGreen) +       (114 * self privateBlue)) / (1000 * ComponentMax)! !!Color methodsFor: 'access'!red    "Return the red component of this color, a float in the range [0.0..1.0]."    ^ self privateRed asFloat / ComponentMax! !!Color methodsFor: 'access'!saturation    "Return the saturation of this color, a value between 0.0 and 1.0."    | r g b max min |    r _ self privateRed.    g _ self privateGreen.    b _ self privateBlue.     max _ min _ r.    g > max ifTrue: [max _ g].    b > max ifTrue: [max _ b].    g < min ifTrue: [min _ g].    b < min ifTrue: [min _ b].    max = 0        ifTrue: [ ^ 0.0 ]        ifFalse: [ ^ (max - min) asFloat / max asFloat ].! !!Color methodsFor: 'equality'!= aColor    "Return true if the receiver equals the given color. This method handles TranslucentColors, too."    ^ aColor isColor and:        [aColor privateRGB = rgb and:        [aColor privateAlpha = self privateAlpha]]! !!Color methodsFor: 'equality'!hash    ^ rgb! !!Color methodsFor: 'queries'!isColor    ^ true! !!Color methodsFor: 'queries'!isOpaqueMask    ^ false! !!Color methodsFor: 'queries'!isTransparent    ^ false! !!Color methodsFor: 'transformations' stamp: 'tk 6/18/96'!* aNumber    "Answer this color with its RGB divided by the given number. "    "(Color brown * 2) display"    ^ Color        r: ((self red * aNumber) min: 1.0 max: 0.0)        g: ((self green * aNumber) min: 1.0 max: 0.0)        b: ((self blue * aNumber) min: 1.0 max: 0.0)! !!Color methodsFor: 'transformations' stamp: 'tk 6/18/96'!+ aColor    "Answer this color mixed with the given color in an additive color space.  "    "(Color blue + Color green) display"    ^ Color        r: ((self red + aColor red) min: 1.0 max: 0.0)        g: ((self green + aColor green) min: 1.0 max: 0.0)        b: ((self blue + aColor  blue) min: 1.0 max: 0.0)! !!Color methodsFor: 'transformations' stamp: 'tk 6/18/96'!- aColor    "Answer aColor is subtracted from the given color in an additive color space.  "    "(Color white - Color red) display"    ^ Color        r: ((self red - aColor red) min: 1.0 max: 0.0)        g: ((self green - aColor green) min: 1.0 max: 0.0)        b: ((self blue - aColor  blue) min: 1.0 max: 0.0)! !!Color methodsFor: 'transformations' stamp: 'tk 6/18/96'!/ aNumber    "Answer this color with its RGB divided by the given number. "    "(Color red / 2) display"    ^ Color        r: ((self red / aNumber) min: 1.0 max: 0.0)        g: ((self green / aNumber) min: 1.0 max: 0.0)        b: ((self blue / aNumber) min: 1.0 max: 0.0)! !!Color methodsFor: 'transformations'!alpha: alphaValue    "Return a new TransparentColor with the given amount of opacity ('alpha')."    ^ TranslucentColor basicNew setRgb: rgb alpha: alphaValue! !!Color methodsFor: 'transformations'!mixed: proportion with: aColor    "Answer this color mixed with the given color. The proportion, a number between 0.0 and 1.0, determines what what fraction of the receiver to use in the mix. For example, 0.9 would yield a color close to the receiver."    "Details: This method uses RGB interpolation; HSV interpolation can lead to surprises."    | frac1 frac2 |    frac1 _ proportion asFloat min: 1.0 max: 0.0.    frac2 _ 1.0 - frac1.    ^ Color        r: (self    red * frac1) + (aColor    red * frac2)         g: (self green * frac1) + (aColor green * frac2)         b: (self   blue * frac1) + (aColor  blue * frac2)! !!Color methodsFor: 'groups of shades' stamp: 'tk 6/18/96'!darkShades: thisMany    "An array of thisMany colors from black to the receiver.  Array is of length num. Very useful for displaying color based on a variable in your program.  "    "Color showColors: (Color red darkShades: 12)"    ^ self class black mix: self shades: thisMany! !!Color methodsFor: 'groups of shades' stamp: 'tk 6/18/96'!lightShades: thisMany    "An array of thisMany colors from white to self. Very useful for displaying color based on a variable in your program.  "    "Color showColors: (Color red lightShades: 12)"    ^ self class white mix: self shades: thisMany! !!Color methodsFor: 'groups of shades' stamp: 'tk 6/18/96'!mix: color2 shades: thisMany    "Return an array of thisMany colors from self to color2. Very useful for displaying color based on a variable in your program.  "    "Color showColors: (Color red mix: Color green shades: 12)"    | redInc greenInc blueInc rr gg bb c out |    thisMany = 1 ifTrue: [^ Array with: color2].    redInc _ color2 red - self red / (thisMany-1).    greenInc _ color2 green - self green / (thisMany-1).    blueInc _ color2 blue - self blue / (thisMany-1).    rr _ self red.  gg _ self green.  bb _ self blue.    out _ (1 to: thisMany) collect: [:num |        c _ Color r: rr g: gg b: bb.        rr _ rr + redInc.        gg _ gg + greenInc.        bb _ bb + blueInc.        c].    out at: out size put: color2.    "hide roundoff errors"    ^ out! !!Color methodsFor: 'groups of shades' stamp: 'tk 6/18/96'!wheel: thisMany    "An array of thisMany colors around the color wheel starting at self and ending all the way around the hue space just before self.  Array is of length thisMany.  Very useful for displaying color based on a variable in your program.  "    | sat bri hue step c |    thisMany = 1 ifTrue: [^ Array with: self].    sat _ self saturation.    bri _ self brightness.    hue _ self hue.    step _ 360.0 / thisMany.    ^ (1 to: thisMany) collect: [:num |        c _ Color h: hue s: sat v: bri.  "hue is taken mod 360"        hue _ hue + step.        c].! !!Color methodsFor: 'printing'!printOn: aStream    self storeOn: aStream.! !!Color methodsFor: 'printing'!shortPrintString    "Return a short (but less precise) print string for use where space is tight."    | s |    s _ WriteStream on: ''.    s        nextPutAll: '(' , self class name;        nextPutAll: ' r: ';        nextPutAll: (self red roundTo: 0.01) printString;        nextPutAll: ' g: ';        nextPutAll: (self green roundTo: 0.01) printString;        nextPutAll: ' b: ';        nextPutAll: (self blue roundTo: 0.01) printString;        nextPutAll: ')'.    ^ s contents! !!Color methodsFor: 'printing'!storeOn: aStream    aStream        nextPutAll: '(' , self class name;        nextPutAll: ' r: ';        nextPutAll: (self red roundTo: 0.001) printString;        nextPutAll: ' g: ';        nextPutAll: (self green roundTo: 0.001) printString;        nextPutAll: ' b: ';        nextPutAll: (self blue roundTo: 0.001) printString;        nextPutAll: ')'.! !!Color methodsFor: 'other' stamp: 'tk 6/14/96'!display    "Show a swatch of this color tracking the cursor until the next mouseClick. "    "Color red display"    | f |    f _ Form extent: 40@20 depth: Display depth.    f fillColor: self.    Cursor blank showWhile:        [f follow: [Sensor cursorPoint] while: [Sensor noButtonPressed]]! !!Color methodsFor: 'other'!name    "Return this color's name, if it has one, or nil if it doesn't. Only returns a name if it exactly matches the named color."    ColorNames do: [:each |        (Color perform: each) = self             ifTrue: [^ each]].    ^ nil! !!Color methodsFor: 'conversions' stamp: 'tk 6/14/96'!bitPatternForDepth: depth    "Return a Bitmap, possibly containing a stipple pattern, that best represents this color at the given depth. BitBlt calls this method to convert colors into Bitmaps. The resulting Bitmap may be multiple words to represent a stipple pattern of several lines.  "    "See also:    pixelValueAtDepth:    -- value for single pixel                pixelWordAtDepth:    -- a 32-bit word filled with the pixel value"    "Details: The pattern for the most recently requested depth is cached."    depth == cachedDepth ifTrue: [^ cachedBitPattern].    cachedDepth _ depth.    depth > 2 ifTrue: [^ cachedBitPattern _ Bitmap with: (self pixelWordForDepth: depth)].    depth = 1 ifTrue: [^ cachedBitPattern _ self halfTonePattern1].    depth = 2 ifTrue: [^ cachedBitPattern _ self halfTonePattern2].! !!Color methodsFor: 'conversions'!closestPixelValue1    "Return the nearest approximation to this color for a monochrome Form."    "fast special cases"    rgb = 0 ifTrue: [^ 1].  "black"    rgb = 16r3FFFFFFF ifTrue: [^ 0].  "white"    self luminance > 0.5        ifTrue: [^ 0]  "white"        ifFalse: [^ 1].  "black"! !!Color methodsFor: 'conversions'!closestPixelValue2    "Return the nearest approximation to this color for a 2-bit deep Form."    | lum |    "fast special cases"    rgb = 0 ifTrue: [^ 1].  "black"    rgb = 16r3FFFFFFF ifTrue: [^ 2].  "opaque white"    lum _ self luminance.    lum < 0.2 ifTrue: [^ 1].  "black"    lum > 0.6 ifTrue: [^ 2].  "opaque white"    ^ 3  "50% gray"! !!Color methodsFor: 'conversions'!closestPixelValue4    "Return the nearest approximation to this color for a 4-bit deep Form."    | bIndex |    "fast special cases"    rgb = 0 ifTrue: [^ 1].  "black"    rgb = 16r3FFFFFFF ifTrue: [^ 2].  "opaque white"    rgb = PureRed privateRGB ifTrue: [^ 4].    rgb = PureGreen privateRGB ifTrue: [^ 5].    rgb = PureBlue privateRGB ifTrue: [^ 6].    rgb = PureCyan privateRGB ifTrue: [^ 7].    rgb = PureYellow privateRGB ifTrue: [^ 8].    rgb = PureMagenta privateRGB ifTrue: [^ 9].    bIndex _ (self luminance * 8.0) rounded.  "bIndex in [0..8]"    ^ #(        1    "black"        10    "1/8 gray"        11    "2/8 gray"        12    "3/8 gray"        3    "4/8 gray"        13    "5/8 gray"        14    "6/8 gray"        15    "7/8 gray"        2    "opaque white"    ) at: bIndex + 1.! !!Color methodsFor: 'conversions'!closestPixelValue8    "Return the nearest approximation to this color for an 8-bit deep Form."    "fast special cases"    rgb = 0 ifTrue: [^ 1].  "black"    rgb = 16r3FFFFFFF ifTrue: [^ 255].  "white"    self saturation < 0.2 ifTrue: [        ^ GrayToIndexMap at: (self privateGreen >> 2) + 1.  "nearest gray"    ] ifFalse: [        "compute nearest entry in the color cube"        ^ 40 +          ((((self privateRed * 5) + HalfComponentMask) // ComponentMask) * 36) +          ((((self privateBlue * 5) + HalfComponentMask) // ComponentMask) * 6) +          (((self privateGreen * 5) + HalfComponentMask) // ComponentMask)].! !!Color methodsFor: 'conversions' stamp: 'di 6/23/97 23:27'!halfTonePattern1    "Return a halftone-pattern to approximate luminance levels on 1-bit deep Forms."    | lum |    lum _ self luminance.    lum < 0.1 ifTrue: [^ Bitmap with: 16rFFFFFFFF]. "black"    lum < 0.4 ifTrue: [^ Bitmap with: 16rBBBBBBBB with: 16rEEEEEEEE]. "dark gray"    lum < 0.6 ifTrue: [^ Bitmap with: 16r55555555 with: 16rAAAAAAAA]. "medium gray"    lum < 0.9 ifTrue: [^ Bitmap with: 16r44444444 with: 16r11111111]. "light gray"    ^ Bitmap with: 0  "1-bit white"! !!Color methodsFor: 'conversions'!halfTonePattern2    "Return a halftone-pattern to approximate luminance levels on 2-bit deep Forms."    | lum |    lum _ self luminance.    lum < 0.125 ifTrue: [^ Bitmap with: 16r55555555].  "black"    lum < 0.25 ifTrue: [^ Bitmap with: 16r55555555 with: 16rDDDDDDDD].  "1/8 gray"    lum < 0.375 ifTrue: [^ Bitmap with: 16rDDDDDDDD with: 16r77777777].  "2/8 gray"    lum < 0.5 ifTrue: [^ Bitmap with: 16rFFFFFFFF with: 16r77777777].  "3/8 gray"    lum < 0.625 ifTrue: [^ Bitmap with: 16rFFFFFFFF].  "4/8 gray"    lum < 0.75 ifTrue: [^ Bitmap with: 16rFFFFFFFF with: 16rBBBBBBBB].  "5/8 gray"    lum < 0.875 ifTrue: [^ Bitmap with: 16rEEEEEEEE with: 16rBBBBBBBB].  "6/8 gray"    lum < 1.0 ifTrue: [^ Bitmap with: 16rAAAAAAAA with: 16rBBBBBBBB].  "7/8 gray"    ^ Bitmap with: 16rAAAAAAAA  "opaque white""handy expression for computing patterns for 2x2 tiles; set p to a string of 4 letters (e.g., 'wggw' for a gray-and- white checkerboard) and print the result of evaluating:| p d w1 w2 |p _ 'wggw'.d _ Dictionary new.d at: $b put: '01'.d at: $w put: '10'.d at: $g put: '11'.w1 _ (d at: (p at: 1)), (d at: (p at: 2)).w1 _ '2r', w1, w1, w1, w1, w1, w1, w1, w1, ' hex'.w2 _ (d at: (p at: 3)), (d at: (p at: 4)).w2 _ '2r', w2, w2, w2, w2, w2, w2, w2, w2, ' hex'.Array with: (Compiler evaluate: w1) with: (Compiler evaluate: w2) "! !!Color methodsFor: 'conversions' stamp: 'tk 4/24/97'!indexInMap: aColorMap    "Return the index corresponding to this color in the given color map. RGB colors are truncated to 3-, 4-, or 5-bits per color component when indexing into such a colorMap.  "    aColorMap size = 2 ifTrue: [^ (self pixelValueForDepth: 1) + 1].    aColorMap size = 4 ifTrue: [^ (self pixelValueForDepth: 2) + 1].    aColorMap size = 16 ifTrue: [^ (self pixelValueForDepth: 4) + 1].    aColorMap size = 256 ifTrue: [^ (self pixelValueForDepth: 8) + 1].    aColorMap size = 512 ifTrue: [^ (self pixelValueForDepth: 9) + 1].    aColorMap size = 4096 ifTrue: [^ (self pixelValueForDepth: 12) + 1].    aColorMap size = 32768 ifTrue: [^ (self pixelValueForDepth: 16) + 1].    self error: 'unknown pixel depth'.! !!Color methodsFor: 'conversions'!pixelValueForDepth: d    "Returns an integer representing the bits that appear in a single pixel of this color in a Form of the given depth. The depth must be one of 1, 2, 4, 8, 16, or 32. Contrast with pixelWordForDepth: and bitPatternForDepth:, which return either a 32-bit word packed with the given pixel value or a multiple-word Bitmap containing a pattern. The inverse is the class message colorFromPixelValue:depth:"    "Details: For depths of 8 or less, the result is a colorMap index. For depths of 16 and 32, it is a direct color value with 5 or 8 bits per color component."    "Transparency: The pixel value zero is reserved for transparent. For depths greater than 8, black maps to the darkest possible blue."    | rgbBlack val |    d = 8 ifTrue: [^ self closestPixelValue8].  "common case"    d < 8 ifTrue: [        d = 4 ifTrue: [^ self closestPixelValue4].        d = 2 ifTrue: [^ self closestPixelValue2].        d = 1 ifTrue: [^ self closestPixelValue1]].    rgbBlack _ 1.  "closest black that is not transparent in RGB"    d = 16 ifTrue: [        "five bits per component; top bits ignored"        val _ (((rgb bitShift: -15) bitAnd: 16r7C00) bitOr:             ((rgb bitShift: -10) bitAnd: 16r03E0)) bitOr:             ((rgb bitShift: -5) bitAnd: 16r001F).        ^ val = 0 ifTrue: [rgbBlack] ifFalse: [val]].    d = 32 ifTrue: [        "eight bits per component; top 8 bits ignored"        val _ (((rgb bitShift: -6) bitAnd: 16rFF0000) bitOr:             ((rgb bitShift: -4) bitAnd: 16r00FF00)) bitOr:             ((rgb bitShift: -2) bitAnd: 16r0000FF).        ^ val = 0 ifTrue: [rgbBlack] ifFalse: [val]].    d = 12 ifTrue: [  "for indexing a color map with 4 bits per color component"        val _ (((rgb bitShift: -18) bitAnd: 16r0F00) bitOr:             ((rgb bitShift: -12) bitAnd: 16r00F0)) bitOr:             ((rgb bitShift: -6) bitAnd: 16r000F).        ^ val = 0 ifTrue: [rgbBlack] ifFalse: [val]].    d = 9 ifTrue: [  "for indexing a color map with 3 bits per color component"        val _ (((rgb bitShift: -21) bitAnd: 16r01C0) bitOr:             ((rgb bitShift: -14) bitAnd: 16r0038)) bitOr:             ((rgb bitShift: -7) bitAnd: 16r0007).        ^ val = 0 ifTrue: [rgbBlack] ifFalse: [val]].    self error: 'unknown pixel depth: ', d printString! !!Color methodsFor: 'conversions'!pixelWordFor: depth filledWith: pixelValue    "Return to a 32-bit word that concatenates enough copies of the given pixel value to fill the word (i.e., 32/depth copies). Depth should be one of 1, 2, 4, 8, 16, or 32. The pixel value should be an integer in 0..2^depth-1."    depth = 32 ifTrue: [^ pixelValue].    ^ (pixelValue bitAnd: (1 bitShift: depth) - 1) *         (#(16rFFFFFFFF                "replicates at every bit"            16r55555555 -            "replicates every 2 bits"            16r11111111 - - -            "replicates every 4 bits"            16r01010101 - - - - - - -    "replicates every 8 bits"            16r00010001) at: depth)    "replicates every 16 bits"! !!Color methodsFor: 'conversions'!pixelWordForDepth: depth    "Return to a 32-bit word that concatenates enough copies of the receiver's pixel value to fill the word (i.e., 32/depth copies). Depth should be one of 1, 2, 4, 8, 16, or 32. The pixel value should be an integer in 0..2^depth-1."    | pixelValue |    pixelValue _ self pixelValueForDepth: depth.    ^ self pixelWordFor: depth filledWith: pixelValue! !!Color methodsFor: 'private'!attemptToMutateError    "A color is immutable. Once a color's red, green, and blue have been initialized, you cannot change them. Instead, create a new Color and use it."    self error: 'Color objects are immutable once created'! !!Color methodsFor: 'private'!flushCache    "Flush my cached bit pattern."    cachedDepth _ nil.    cachedBitPattern _ nil.! !!Color methodsFor: 'private'!privateAlpha    "Private!! Return the raw alpha value for opaque. Used only for equality testing."    ^ 255! !!Color methodsFor: 'private'!privateBlue    "Private!! Return the internal representation of my blue component."    ^ rgb bitAnd: ComponentMask! !!Color methodsFor: 'private'!privateGreen    "Private!! Return the internal representation of my green component."    ^ (rgb >> GreenShift) bitAnd: ComponentMask! !!Color methodsFor: 'private'!privateRed    "Private!! Return the internal representation of my red component."    ^ (rgb bitShift: 0 - RedShift) bitAnd: ComponentMask! !!Color methodsFor: 'private'!privateRGB    "Private!! Return the internal representation of my RGB components."    ^ rgb! !!Color methodsFor: 'private'!setHue: hue saturation: saturation brightness: brightness    "Initialize this color to the given hue, saturation, and brightness. See the comment in the instance creation method for details."    | s v hf i f p q t |     s _ (saturation asFloat max: 0.0) min: 1.0.    v _ (brightness asFloat max: 0.0) min: 1.0.    "zero saturation yields gray with the given brightness"    s = 0.0 ifTrue: [ ^ self setRed: v green: v blue: v ].    hf _ hue asFloat.    (hf < 0.0 or: [hf >= 360.0])        ifTrue: [hf _ hf - ((hf quo: 360.0) asFloat * 360.0)].    hf _ hf / 60.0.    i _ hf asInteger.  "integer part of hue"    f _ hf fractionPart.         "fractional part of hue"    p _ (1.0 - s) * v.    q _ (1.0 - (s * f)) * v.    t _ (1.0 - (s * (1.0 - f))) * v.    0 = i ifTrue: [ ^ self setRed: v green: t blue: p ].    1 = i ifTrue: [ ^ self setRed: q green: v blue: p ].    2 = i ifTrue: [ ^ self setRed: p green: v blue: t ].    3 = i ifTrue: [ ^ self setRed: p green: q blue: v ].    4 = i ifTrue: [ ^ self setRed: t green: p blue: v ].    5 = i ifTrue: [ ^ self setRed: v green: p blue: q ].    self error: 'implementation error'.! !!Color methodsFor: 'private'!setRed: r green: g blue: b    "Initialize this color's r, g, and b components to the given values in the range [0.0..1.0].  Encoded in a single variable as 3 integers in [0..1023]."    rgb == nil ifFalse: [self attemptToMutateError].    rgb _        (((r * ComponentMax) rounded bitAnd: ComponentMask) bitShift: RedShift) +        (((g * ComponentMax) rounded bitAnd: ComponentMask) bitShift: GreenShift) +         ((b * ComponentMax) rounded bitAnd: ComponentMask).    cachedDepth _ nil.    cachedBitPattern _ nil.! !!Color methodsFor: 'private'!setRed: r green: g blue: b range: range    "Initialize this color's r, g, and b components to the given values in the range [0..r]."    rgb == nil ifFalse: [self attemptToMutateError].    rgb _        ((((r * ComponentMask) // range) bitAnd: ComponentMask) bitShift: RedShift) +        ((((g * ComponentMask) // range) bitAnd: ComponentMask) bitShift: GreenShift) +         (((b * ComponentMask) // range) bitAnd: ComponentMask).    cachedDepth _ nil.    cachedBitPattern _ nil.! !!Color class methodsFor: 'instance creation'!colorFromPixelValue: p depth: d    "Convert a pixel value for the given display depth into a color."    "Details: For depths of 8 or less, the pixel value is simply looked up in a table. For depths of 16 and 32, the color components are extracted and converted into a color."    | r g b alpha |    d = 8 ifTrue: [^ IndexedColors at: (p bitAnd: 16rFF) + 1].    d = 4 ifTrue: [^ IndexedColors at: (p bitAnd: 16r0F) + 1].    d = 2 ifTrue: [^ IndexedColors at: (p bitAnd: 16r03) + 1].    d = 1 ifTrue: [^ IndexedColors at: (p bitAnd: 16r01) + 1].    d = 16 ifTrue: [        "five bits per component; top bit ignored"        r _ (p bitShift: -10) bitAnd: 16r1F.        g _ (p bitShift: -5) bitAnd: 16r1F.        b _ p bitAnd: 16r1F.        ^ Color r: r g: g b: b range: 31].    d = 32 ifTrue: [        "eight bits per component; 8 bits of alpha"        r _ (p bitShift: -16) bitAnd: 16rFF.        g _ (p bitShift: -8) bitAnd: 16rFF.        b _ p bitAnd: 16rFF.        alpha _ p bitShift: -24.        alpha > 0            ifTrue: [^ (Color r: r g: g b: b range: 255) alpha: (alpha asFloat / 255.0)]            ifFalse: [^ (Color r: r g: g b: b range: 255)]].    self error: 'unknown pixel depth: ', d printString! !!Color class methodsFor: 'instance creation'!fromUser    "Displays a color palette using abstract colors, then waits for a mouse click. Try it at various display depths!!"    "Note: Since the color chart is cached, you may need to do 'ColorChart _ nil' after changing the colorPaletteForDepth:extent: method."    "Color fromUser"    | d startPt save tr oldColor c here s |    d _ Display depth.    ((ColorChart == nil) or: [ColorChart depth ~= Display depth])         ifTrue: [ColorChart _ self colorPaletteForDepth: d extent: (2 * 144)@80].    Sensor cursorPoint y < Display center y         ifTrue: [startPt _ 0@(Display boundingBox bottom - ColorChart height)]        ifFalse: [startPt _ 0@0].    save _ Form fromDisplay: (startPt extent: ColorChart extent).    ColorChart displayAt: startPt.    tr _ ColorChart extent - (50@19) corner: ColorChart extent.    tr _ tr translateBy: startPt.    oldColor _ nil.    [Sensor anyButtonPressed] whileFalse: [        c _ Display colorAt: (here _ Sensor cursorPoint).        (tr containsPoint: here)            ifFalse: [Display fill: (0@61+startPt extent: 20@19) fillColor: c]            ifTrue: [                c _ Color transparent.                Display fill: (0@61+startPt extent: 20@19) fillColor: Color white].        c = oldColor ifFalse: [            Display fillWhite: (20@61 + startPt extent: 135@19).            c isTransparent                ifTrue: [s _ c shortPrintString]                ifFalse: [                    s _ c shortPrintString.                    s _ s copyFrom: 7 to: s size - 1].            s displayAt: 20@61 + startPt.            oldColor _ c]].    save displayAt: startPt.    Sensor waitNoButton.    ^ c! !!Color class methodsFor: 'instance creation'!h: hue s: saturation v: brightness    "Create a color with the given hue, saturation, and brightness. Hue is given as the angle in degrees of the color on the color circle where red is zero degrees. Saturation and brightness are numbers in [0.0..1.0] where larger values are more saturated or brighter colors. For example, (Color h: 0 s: 1 v: 1) is pure red."    "Note: By convention, brightness is abbreviated 'v' to to avoid confusion with blue."    ^ self basicNew setHue: hue saturation: saturation brightness: brightness! !!Color class methodsFor: 'instance creation'!new    ^ self r: 0.0 g: 0.0 b: 0.0! !!Color class methodsFor: 'instance creation'!r: r g: g b: b alpha: alpha    ^ (self r: r g: g b: b) alpha: alpha! !!Color class methodsFor: 'instance creation'!r: r g: g b: b range: range    "Return a color with the given r, g, and b components specified as integers in the range [0..r]. This avoids the floating point arithmetic in the red:green:blue: message and is thus a bit faster for certain applications (such as computing a sequence of colors for a palette)."    ^ self basicNew setRed: r green: g blue: b range: range! !!Color class methodsFor: 'instance creation'!random    "Return a random color that isn't too dark or under-saturated."    ^ self basicNew        setHue: (360.0 * RandomStream next)        saturation: (0.3 + (RandomStream next * 0.7))        brightness: (0.4 + (RandomStream next * 0.6))! !!Color class methodsFor: 'class initialization'!initialize    "Color initialize"    "Details: Externally, the red, green, and blue components of color    are floats in the range [0.0..1.0]. Internally, they are represented    as integers in the range [0..ComponentMask] packing into a    small integer to save space and to allow fast hashing and    equality testing.    For a general description of color representations for computer    graphics, including the relationship between the RGB and HSV    color models used here, see Chapter 17 of Foley and van Dam,    Fundamentals of Interactive Computer Graphics, Addison-Wesley,    1982."    ComponentMask _ 1023.    HalfComponentMask _ 512.  "used to round up in integer calculations"    ComponentMax _ 1023.0.  "a Float used to normalize components"    RedShift _ 20.    GreenShift _ 10.    BlueShift _ 0.    PureRed         _ self r: 1 g: 0 b: 0.    PureGreen     _ self r: 0 g: 1 b: 0.    PureBlue     _ self r: 0 g: 0 b: 1.    PureYellow     _ self r: 1 g: 1 b: 0.    PureCyan     _ self r: 0 g: 1 b: 1.    PureMagenta _ self r: 1 g: 0 b: 1.    RandomStream _ Random new.    self initializeIndexedColors.    self initializeGrayToIndexMap.    self initializeNames.    self initializeHighLights.! !!Color class methodsFor: 'class initialization'!initializeGrayToIndexMap    "Build an array of gray values available in the 8-bit colormap. This array is indexed by a gray level between black (1) and white (256) and returns the pixel value for the corresponding gray level."    "Note: This method must be called after initializeIndexedColors, since it uses IndexedColors."    "Color initializeGrayToIndexMap"    | grayLevels grayIndices c distToClosest dist indexOfClosest |    "record the level and index of each gray in the 8-bit color table"    grayLevels _ OrderedCollection new.    grayIndices _ OrderedCollection new.    "Note: skip the first entry, which is reserved for transparent"    2 to: IndexedColors size do: [:i |        c _ IndexedColors at: i.        c saturation = 0.0 ifTrue: [  "c is a gray"            grayLevels add: (c privateBlue) >> 2.  "top 8 bits; R, G, and B are the same"            grayIndices add: i - 1]].  "pixel values are zero-based"    grayLevels _ grayLevels asArray.    grayIndices _ grayIndices asArray.    "for each gray level in [0..255], select the closest match"    GrayToIndexMap _ ByteArray new: 256.    0 to: 255 do: [:level |        distToClosest _ 10000.  "greater than distance to any real gray"        1 to: grayLevels size do: [:i |            dist _ (level - (grayLevels at: i)) abs.            dist < distToClosest ifTrue: [                distToClosest _ dist.                indexOfClosest _ grayIndices at: i]].        GrayToIndexMap at: (level + 1) put: indexOfClosest].! !!Color class methodsFor: 'class initialization' stamp: 'tk 6/22/96'!initializeHighLights    "Create a set of Bitmaps for quickly reversing areas of the screen without converting colors. "    "Color initializeHighLights"    | t |    t _ Array new: 32.    t at: 1 put: (Bitmap with: 16rFFFFFFFF).    t at: 2 put: (Bitmap with: 16rFFFFFFFF).    t at: 4 put: (Bitmap with: 16r55555555).    t at: 8 put: (Bitmap with: 16r7070707).    t at: 16 put: (Bitmap with: 16rFFFFFFFF).    t at: 32 put: (Bitmap with: 16rFFFFFFFF).    HighLightBitmaps _ t.! !!Color class methodsFor: 'class initialization'!initializeIndexedColors    "Build an array of colors corresponding to the fixed colormap used     for display depths of 1, 2, 4, or 8 bits."    "Color initializeIndexedColors"    | a index grayVal |    a _ Array new: 256.    "1-bit colors (monochrome)"    a at: 1 put: (Color r: 1.0 g: 1.0 b: 1.0).        "white or transparent"    a at: 2 put: (Color r: 0.0 g: 0.0 b: 0.0).    "black"    "additional colors for 2-bit color"    a at: 3 put: (Color r: 1.0 g: 1.0 b: 1.0).    "opaque white"    a at: 4 put: (Color r: 0.5 g: 0.5 b: 0.5).    "1/2 gray"    "additional colors for 4-bit color"    a at:  5 put: (Color r: 1.0 g: 0.0 b: 0.0).    "red"    a at:  6 put: (Color r: 0.0 g: 1.0 b: 0.0).    "green"    a at:  7 put: (Color r: 0.0 g: 0.0 b: 1.0).    "blue"    a at:  8 put: (Color r: 0.0 g: 1.0 b: 1.0).    "cyan"    a at:  9 put: (Color r: 1.0 g: 1.0 b: 0.0).    "yellow"    a at: 10 put: (Color r: 1.0 g: 0.0 b: 1.0).    "magenta"    a at: 11 put: (Color r: 0.125 g: 0.125 b: 0.125).        "1/8 gray"    a at: 12 put: (Color r: 0.25 g: 0.25 b: 0.25).        "2/8 gray"    a at: 13 put: (Color r: 0.375 g: 0.375 b: 0.375).        "3/8 gray"    a at: 14 put: (Color r: 0.625 g: 0.625 b: 0.625).        "5/8 gray"    a at: 15 put: (Color r: 0.75 g: 0.75 b: 0.75).        "6/8 gray"    a at: 16 put: (Color r: 0.875 g: 0.875 b: 0.875).        "7/8 gray"    "additional colors for 8-bit color"    "24 more shades of gray (1/32 increments but not repeating 1/8 increments)"    index _ 17.    1 to: 31 do: [:v |        (v \\ 4) = 0 ifFalse: [            grayVal _ v / 32.0.            a at: index put: (Color r: grayVal g: grayVal b: grayVal).            index _ index + 1]].    "The remainder of color table defines a color cube with six steps     for each primary color. Note that the corners of this cube repeat     previous colors, but this simplifies the mapping between RGB colors     and color map indices. This color cube spans indices 40 through 255     (indices 41-256 in this 1-based array)."    0 to: 5 do: [:r |        0 to: 5 do: [:g |            0 to: 5 do: [:b |                index _ 41 + ((36 * r) + (6 * b) + g).                index > 256 ifTrue: [                    self error: 'index out of range in color table compuation'].                a at: index put: (Color r: r g: g b: b range: 5)]]].    IndexedColors _ a.! !!Color class methodsFor: 'class initialization'!initializeNames    "Name some colors."    "Color initializeNames"    ColorNames _ OrderedCollection new.    self named: #black put: (Color r: 0 g: 0 b: 0).    self named: #veryVeryDarkGray put: (Color r: 0.125 g: 0.125 b: 0.125).    self named: #veryDarkGray put: (Color r: 0.25 g: 0.25 b: 0.25).    self named: #darkGray put: (Color r: 0.375 g: 0.375 b: 0.375).    self named: #gray put: (Color r: 0.5 g: 0.5 b: 0.5).    self named: #lightGray put: (Color r: 0.625 g: 0.625 b: 0.625).    self named: #veryLightGray put: (Color r: 0.75 g: 0.75 b: 0.75).    self named: #veryVeryLightGray put: (Color r: 0.875 g: 0.875 b: 0.875).    self named: #white put: (Color r: 1.0 g: 1.0 b: 1.0).    self named: #red put: (Color r: 1.0 g: 0 b: 0).    self named: #yellow put: (Color r: 1.0 g: 1.0 b: 0).    self named: #green put: (Color r: 0 g: 1.0 b: 0).    self named: #cyan put: (Color r: 0 g: 1.0 b: 1.0).    self named: #blue put: (Color r: 0 g: 0 b: 1.0).    self named: #magenta put: (Color r: 1.0 g: 0 b: 1.0).    self named: #brown put: (Color r: 0.6 g: 0.2 b: 0).    self named: #orange put: (Color r: 1.0 g: 0.6 b: 0).    self named: #lightRed put: (Color r: 1.0 g: 0.8 b: 0.8).    self named: #lightYellow put: (Color r: 1.0 g: 1.0 b: 0.8).    self named: #lightGreen put: (Color r: 0.8 g: 1.0 b: 0.6).    self named: #lightCyan put: (Color r: 0.4 g: 1.0 b: 1.0).    self named: #lightBlue put: (Color r: 0.8 g: 1.0 b: 1.0).    self named: #lightMagenta put: (Color r: 1.0 g: 0.8 b: 1.0).    self named: #lightBrown put: (Color r: 1.0 g: 0.6 b: 0.2).    self named: #lightOrange put: (Color r: 1.0 g: 0.8 b: 0.4).    self named: #transparent put: (TransparentColor new).    self named: #opaqueMask put: (OpaqueMaskColor new).! !!Color class methodsFor: 'class initialization' stamp: 'tk 6/13/96'!named: newName put: aColor    "Add a new color to the list and create an access message and a class variable for it.  The name should start with a lowercase letter.  (The class variable will start with an uppercase letter.)  (Color colorNames) returns a list of all color names.  "    | str cap sym accessor csym |    (aColor isKindOf: self) ifFalse: [^ self error: 'not a Color'].    str _ newName asString.    sym _ str asSymbol.    cap _ str capitalized.    csym _ cap asSymbol.    (self class canUnderstand: sym) ifFalse: [        "define access message"        accessor _ str, (String with: Character cr with: Character tab),             '^', cap.        self class compile: accessor            classified: 'named colors'].    (self classPool includesKey: csym) ifFalse: [        self addClassVarName: cap].    (ColorNames includes: sym) ifFalse: [        ColorNames add: sym].    ^ self classPool at: csym put: aColor! !!Color class methodsFor: 'examples'!colorRampForDepth: depth extent: aPoint    "Returns a form of the given size showing R, G, B, and gray ramps for the given depth. Useful for testing color conversions between different depths."    "(Color colorRampForDepth: Display depth extent: 256@80) display"    "(Color colorRampForDepth: 32 extent: 256@80) displayOn: Display at: 0@0 rule: Form paint"    | f dx dy r |    f _ Form extent: aPoint depth: depth.    dx _ aPoint x // 256.    dy _ aPoint y // 4.    0 to: 255 do: [:i |        r _ (dx * i)@0 extent: dx@dy.        f fill: r fillColor: (Color r: i g: 0 b: 0 range: 255).        r _ r translateBy: 0@dy.        f fill: r fillColor: (Color r: 0 g: i b: 0 range: 255).        r _ r translateBy: 0@dy.        f fill: r fillColor: (Color r: 0 g: 0 b: i range: 255).        r _ r translateBy: 0@dy.        f fill: r fillColor: (Color r: i g: i b: i range: 255)].    ^ f! !!Color class methodsFor: 'examples' stamp: 'tk 6/19/96'!hotColdShades: thisMany    "An array of thisMany colors showing temperature from blue to red to white hot.  (Later improve this by swinging in hue.)  "    "Color showColors: (Color hotColdShades: 25)"    | n s1 s2 s3 s4 s5 |    thisMany < 5 ifTrue: [^ self error: 'must be at least 5 shades'].    n _ thisMany // 5.    s1 _ self white mix: self yellow shades: (thisMany - (n*4)).    s2 _ self yellow mix: self red shades: n+1.    s2 _ s2 copyFrom: 2 to: n+1.    s3 _ self red mix: self green darker shades: n+1.    s3 _ s3 copyFrom: 2 to: n+1.    s4 _ self green darker mix: self blue shades: n+1.    s4 _ s4 copyFrom: 2 to: n+1.    s5 _ self blue mix: self black shades: n+1.    s5 _ s5 copyFrom: 2 to: n+1.    ^ s1, s2, s3, s4, s5! !!Color class methodsFor: 'examples'!showColorCube    "Show a 12x12x12 color cube."    "Color showColorCube"    0 to: 11 do: [:r |        0 to: 11 do: [:g |            0 to: 11 do: [:b |                    Display fill: (((r*60) + (b*5)) @ (g*5) extent: 5@5)                    fillColor: (Color r: r g: g b: b range: 11)]]].! !!Color class methodsFor: 'examples'!showColors: colorList    "Display the given collection of colors across the top of the Display."    | w r |    w _ Display width // colorList size.    r _ 0@0 extent: w@((w min: 30) max: 10).    colorList do: [:c |        Display fill: r fillColor: c.        r _ r translateBy: w@0].! !!Color class methodsFor: 'examples'!showHSVPalettes    "Shows a palette of hues, varying the saturation and brightness for each one. Best results are with depths 16 and 32."    "Color showHSVPalettes"    | left top c |    left _ top _ 0.    0 to: 179 by: 15 do: [:h |        0 to: 10 do: [:s |            left _ (h * 4) + (s * 4).            0 to: 10 do: [:v |                c _ Color h: h s: s asFloat / 10.0 v: v asFloat / 10.0.                top _ (v * 4).                Display fill: (left@top extent: 4@4) fillColor: c.                c _ Color h: h + 180 s: s asFloat / 10.0 v: v asFloat / 10.0.                top _ (v * 4) + 50.                Display fill: (left@top extent: 4@4) fillColor: c]]].! !!Color class methodsFor: 'examples'!showHuesInteractively    "Shows a palette of hues at a (saturation, brightness) point determined by the mouse position. Click the mouse button to exit and return the selected (saturation, brightness) point."    "Color showHuesInteractively"    | p s v |    [Sensor anyButtonPressed] whileFalse: [        p _ Sensor cursorPoint.        s _ p x asFloat / 300.0.        v _ p y asFloat / 300.0.        self showColors: (self wheel: 12 saturation: s brightness: v)].    ^ (s min: 1.0) @ (v min: 1.0)! !!Color class methodsFor: 'examples'!wheel: thisMany    "Return a collection of thisMany colors evenly spaced around the color wheel."    "Color showColors: (Color wheel: 12)"    ^ Color wheel: thisMany saturation: 0.9 brightness: 0.7! !!Color class methodsFor: 'examples'!wheel: thisMany saturation: s brightness: v    "Return a collection of thisMany colors evenly spaced around the color wheel, all of the given saturation and brightness."    "Color showColors: (Color wheel: 12 saturation: 0.4 brightness: 1.0)"    "Color showColors: (Color wheel: 12 saturation: 0.8 brightness: 0.5)"    ^ (Color h: 0.0 s: s v: v) wheel: thisMany! !!Color class methodsFor: 'named colors'!brown    ^Brown! !!Color class methodsFor: 'named colors'!opaqueMask    ^OpaqueMask! !!Color class methodsFor: 'named colors'!orange    ^Orange! !!Color class methodsFor: 'named colors'!transparent    ^Transparent! !!Color class methodsFor: 'named colors'!veryVeryDarkGray    ^VeryVeryDarkGray! !!Color class methodsFor: 'named colors'!veryVeryLightGray    ^VeryVeryLightGray! !!Color class methodsFor: 'colormaps'!cachedColormapFrom: sourceDepth to: destDepth    "Return a cached colormap for mapping between the given depths. Always return a real colormap, not nil; this allows the client to get an identity colormap that can then be copied and modified to do color transformations."    "Note: This method returns a shared, cached colormap to save time and space. Clients that need to modify a colormap returned by this method should make a copy and modify that!!"    "Note: The colormap cache may be cleared by evaluating 'Color shutDown'."    | key newMap |    key _ sourceDepth@destDepth.    CachedColormaps == nil ifTrue: [CachedColormaps _ Dictionary new].    ^ CachedColormaps at: key ifAbsent: [        newMap _ self computeColormapFrom: sourceDepth to: destDepth.        CachedColormaps at: key put: newMap.        sourceDepth >= 16 ifTrue: [            "use the same map from both 16- and 32-bits to a given depth"            CachedColormaps at: 16@destDepth put: newMap.            CachedColormaps at: 32@destDepth put: newMap].        newMap].! !!Color class methodsFor: 'colormaps'!colorMapIfNeededFrom: sourceDepth to: destDepth    "Return a colormap for mapping between the given depths, or nil if no colormap is needed."    "Note: This method returns a shared, cached colormap to save time and space. Clients that need to modify a colormap returned by this method should make a copy and modify that!!"    sourceDepth = destDepth ifTrue: [^ nil].  "not needed if depths are the same"    (sourceDepth >= 16) & (destDepth >= 16) ifTrue: [        "mapping is done in BitBlt by zero-filling or truncating each color component"        ^ nil].    ^ Color cachedColormapFrom: sourceDepth to: destDepth! !!Color class methodsFor: 'colormaps'!computeColormapFrom: sourceDepth to: destDepth    "Compute a colorMap for translating between the given depths. A colormap is a Bitmap whose entries contain the pixel values for the destination depth. Typical clients use cachedColormapFrom:to: instead."    | map bitsPerColor mask |    sourceDepth < 16 ifTrue: [        "source is 1-, 2-, 4-, or 8-bit indexed color"        map _ (IndexedColors copyFrom: 1 to: (1 bitShift: sourceDepth))                    collect: [:c | c pixelValueForDepth: destDepth].        map _ map as: Bitmap.    ] ifFalse: [        "source is 16-bit or 32-bit RGB; use colormap with 4 bits per color component"        bitsPerColor _ 4.        mask _ (1 bitShift: bitsPerColor) - 1.        map _ Bitmap new: (1 bitShift: (3 * bitsPerColor)).        0 to: map size - 1 do: [:i |            c _ Color                    r: ((i bitShift: 0 - (bitsPerColor * 2)) bitAnd: mask)                    g: ((i bitShift: 0 - bitsPerColor) bitAnd: mask)                    b: ((i bitShift: 0) bitAnd: mask)                    range: mask.            map at: i + 1 put: (c pixelValueForDepth: destDepth)]].    "Note: zero is transparent except when source depth is one-bit deep"    sourceDepth > 1 ifTrue: [map at: 1 put: 0].    ^ map! !!Color class methodsFor: 'other'!colorNames    "Return a collection of color names."    ^ ColorNames! !!Color class methodsFor: 'other' stamp: 'jm 9/25/97 13:52'!colorPaletteForDepth: depth extent: paletteExtent    "Returns a form of the given size showing a color palette for the given depth."    "(Color colorPaletteForDepth: Display depth extent: 720@100) display"    | c p f nSteps rect w h q |    f _ Form extent: paletteExtent depth: depth.    f fill: f boundingBox fillColor: Color white.    nSteps _ depth>8 ifTrue: [12] ifFalse: [6].    w _ paletteExtent x // (nSteps*nSteps).    h _ paletteExtent y - 20 // nSteps.    0 to: nSteps-1 do: [:r |        0 to: nSteps-1 do: [:g |            0 to: nSteps-1 do: [:b |                c _ Color r: r g: g b: b range: nSteps-1.                rect _ ((r*nSteps*w) + (b*w)) @ (g*h) extent: w@(h+1).                f fill: rect fillColor: c].            ].        ].    q _ Quadrangle origin: paletteExtent - (50@19) corner: paletteExtent.    q displayOn: f.    ('Trans.' asParagraph asForm) displayOn: f at: q origin + (9@0) rule: Form paint.    w _ ((paletteExtent x - q width - 130) // 64) max: 1.    p _ paletteExtent x - q width - (64 * w) - 1 @ (paletteExtent y - 19).    0 to: 63 do:        [ :v | c _ Color r: v g: v b: v range: 63.        f fill: ((v*w)@0 + p extent: (w+1)@19) fillColor: c].    ^ f! !!Color class methodsFor: 'other'!maskingMap: depth    "Return a color map that maps all colors except transparent to words of all ones. Used to create a mask for a Form whose transparent pixel value is zero. Cache the most recently used map."    | sizeNeeded |    depth <= 8        ifTrue: [sizeNeeded _ 1 bitShift: depth]        ifFalse: [sizeNeeded _ 4096].    MaskingMap size = sizeNeeded ifTrue: [^ MaskingMap].    MaskingMap _ Bitmap new: sizeNeeded withAll: 16rFFFFFFFF.    MaskingMap at: 1 put: 0.  "transparent"    ^ MaskingMap! !!Color class methodsFor: 'other'!pixelScreenForDepth: depth    "Return a 50% stipple containing alternating pixels of all-zeros and all-ones to be used as a mask at the given depth."    | mask bits |    mask _ (1 bitShift: depth) - 1.    bits _ 2 * depth.    [bits >= 32] whileFalse: [        mask _ mask bitOr: (mask bitShift: bits).  "double the length of mask"        bits _ bits + bits].    ^ Bitmap with: mask with: mask bitInvert32! !!Color class methodsFor: 'other'!shutDown    "Color shutDown"    ColorChart _ nil.        "Palette of colors for the user to pick from"    CachedColormaps _ nil.    "Maps to translate between color depths"    MaskingMap _ nil.        "Maps all colors except transparent to black for creating a mask"! !!ColorForm methodsFor: 'accessing'!colors    "Return my color palette. It may be nil."    ^ colors! !!ColorForm methodsFor: 'accessing'!colors: colorList    "Set my color palette to the given collection."    | colorArray colorCount newColors |    colorList ifNil: [        colors _ cachedDepth _ cachedColormap _ nil.        ^ self].    colorArray _ colorList asArray.    colorCount _ colorArray size.    newColors _ Array new: (1 bitShift: depth).    1 to: newColors size do: [:i |        i <= colorCount            ifTrue: [newColors at: i put: (colorArray at: i)]            ifFalse: [newColors at: i put: Color transparent]].    colors _ newColors.    cachedDepth _ nil.    cachedColormap _ nil.! !!ColorForm methodsFor: 'displaying'!displayOn: aDisplayMedium at: aDisplayPoint clippingBox: clipRectangle rule: rule fillColor: aForm    aDisplayMedium copyBits: self boundingBox        from: self        at: aDisplayPoint + self offset        clippingBox: clipRectangle        rule: rule        fillColor: aForm        map: (self colormapIfNeededForDepth: aDisplayMedium depth).! !!ColorForm methodsFor: 'displaying' stamp: 'di 7/17/97 10:04'!displayOnPort: port at: location    port copyForm: self to: location rule: Form paint! !!ColorForm methodsFor: 'pixel accessing'!colorAt: aPoint    "Return the color of the pixel at aPoint."    ^ colors at: (self pixelValueAt: aPoint) + 1! !!ColorForm methodsFor: 'pixel accessing'!colorAt: aPoint put: aColor    "Store the given color into the pixel at aPoint. The given color must match one of the colors in the receiver's colormap."    | i |    i _ colors indexOf: aColor        ifAbsent: [^ self error: 'trying to use a color that is not in my colormap'].    self pixelValueAt: aPoint put: i - 1.! !!ColorForm methodsFor: 'pixel accessing'!isTransparentAt: aPoint     "Return true if the receiver is transparent at the given point."    ^ (self colorAt: aPoint) = Color transparent! !!ColorForm methodsFor: 'other'!colormapIfNeededForDepth: destDepth    "Return a colormap for displaying the receiver at the given depth, or nil if no colormap is needed."    | newMap |    colors == nil ifTrue: [        "use the standard colormap"        ^ Color colorMapIfNeededFrom: depth to: destDepth].    destDepth = cachedDepth ifTrue: [^ cachedColormap].    newMap _ Bitmap new: colors size.    1 to: colors size do: [:i |        newMap            at: i            put: ((colors at: i) pixelValueForDepth: destDepth)].    cachedDepth _ destDepth.    ^ cachedColormap _ newMap.! !!ColorForm methodsFor: 'other'!twoToneFromDisplay: aRectangle backgroundColor: bgColor    "Copy one-bit deep ColorForm from the Display using a color map that maps all colors except the background color to black. Used for caching the contents of inactive MVC windows."    | map |    (width = aRectangle width and: [height = aRectangle height])        ifFalse: [self setExtent: aRectangle extent depth: depth].    "make a color map mapping the background color     to zero and all other colors to one"    map _ Bitmap new: (1 bitShift: (Display depth min: 9)).    1 to: map size do: [:i | map at: i put: 16rFFFFFFFF].    map at: (bgColor indexInMap: map) put: 0.    (BitBlt toForm: self)        destOrigin: 0@0;        sourceForm: Display;        sourceRect: aRectangle;        combinationRule: Form over;        colorMap: map;        copyBits.! !!ColorForm class methodsFor: 'all' stamp: 'tk 7/22/97 15:59'!transparentBorder: aForm    "Answer an instance of me that looks like aForm, but is transparent in regions near the edge.  Assumes one color around the edge."    "Cursor blank showWhile:        [(ColorForm transparentBorder: Form fromUser) followCursor]."    | shape colorMap shapeCopy figure pen |    shape _ Form extent: aForm extent offset: aForm offset.  "Copy the figure 1 bit deep"    colorMap _ Bitmap new: (1 bitShift: aForm depth) withAll: 1.    colorMap at: (aForm peripheralColor) + 1 put: 0.    shape copyBits: shape boundingBox from: aForm at: 0@0 colorMap: colorMap.    shapeCopy _ shape deepCopy.    shape fillPeriphery: (Color black).  "Blacken edge regions"    shapeCopy displayOn: shape at: 0@0 rule: Form reverse.    "Now shape is just the edge region"    "Need to copy the original form and zero the edge region if it wasn't a true zero before"    figure _ aForm deepCopy.    pen _ Pen newOnForm: figure.    pen sourceForm: shape.    pen combinationRule: Form erase1bitShape.    pen color: Color black.    pen place: 0@0; goto: 0@0."    shape displayOn: figure at: 0@0        clippingBox: figure boundingBox        rule: Form erase1bitShape fillColor: nil.    "    "<-- This is broken!!"    ^ figure asColorForm! !!ColorForm class methodsFor: 'all'!transparentFrom: aFormOrCursor    "Return a ColorForm copied from the given Form or Cursor with white mapped to transparent."    | f map |    aFormOrCursor depth <= 8 ifFalse: [        ^ self error: 'argument depth must be 8-bits per pixel or less'].    (aFormOrCursor isKindOf: ColorForm) ifTrue: [        f _ aFormOrCursor deepCopy.        map _ aFormOrCursor colors.    ] ifFalse: [        f _ ColorForm extent: aFormOrCursor extent depth: aFormOrCursor depth.        f copyBits: aFormOrCursor boundingBox            from: aFormOrCursor            at: 0@0            clippingBox: aFormOrCursor boundingBox            rule: Form over            fillColor: nil.        map _ Color indexedColors copyFrom: 1 to: (1 bitShift: aFormOrCursor depth)].    map _ map collect: [:c |        c = Color white ifTrue: [Color transparent] ifFalse: [c]].    f colors: map.    ^ f! !!ColorForm class methodsFor: 'all'!twoToneFromDisplay: aRectangle using: oldForm backgroundColor: bgColor    "Return a 1-bit deep ColorForm copied from the given rectangle of the display. All colors except the background color will be mapped to black."    | f |    ((oldForm ~~ nil) and: [oldForm extent = aRectangle extent]) ifTrue: [        f _ oldForm fromDisplay: aRectangle.    ] ifFalse: [        f _ ColorForm extent: aRectangle extent depth: 1.        f twoToneFromDisplay: aRectangle backgroundColor: bgColor.        f colors: (Array            with: bgColor            with: Color black)].    ^ f! !!ColorPickerMorph methodsFor: 'initialization' stamp: 'jm 9/27/97 06:56'!initialize    super initialize.    self form: ColorChart deepCopy.    selectedColor _ Color white.    sourceHand _ nil.    deleteOnMouseUp _ true.    updateContinuously _ true.    selector _ nil.    target _ nil.! !!ColorPickerMorph methodsFor: 'accessing' stamp: 'jm 9/25/97 16:20'!deleteOnMouseUp    ^ deleteOnMouseUp! !!ColorPickerMorph methodsFor: 'accessing' stamp: 'jm 9/25/97 16:18'!deleteOnMouseUp: aBoolean    deleteOnMouseUp _ aBoolean.! !!ColorPickerMorph methodsFor: 'accessing' stamp: 'jm 9/25/97 16:19'!selectedColor    ^ selectedColor! !!ColorPickerMorph methodsFor: 'accessing' stamp: 'jm 9/25/97 16:20'!selector    ^ selector! !!ColorPickerMorph methodsFor: 'accessing' stamp: 'jm 9/25/97 16:19'!selector: aSymbol    selector _ aSymbol.! !!ColorPickerMorph methodsFor: 'accessing' stamp: 'jm 9/25/97 16:20'!sourceHand    ^ sourceHand! !!ColorPickerMorph methodsFor: 'accessing' stamp: 'jm 9/25/97 16:19'!sourceHand: aHand    sourceHand _ aHand.! !!ColorPickerMorph methodsFor: 'accessing' stamp: 'jm 9/25/97 16:20'!target    ^ target! !!ColorPickerMorph methodsFor: 'accessing' stamp: 'jm 9/25/97 16:19'!target: anObject    target _ anObject.! !!ColorPickerMorph methodsFor: 'accessing' stamp: 'jm 9/27/97 06:45'!updateContinuously    ^ updateContinuously! !!ColorPickerMorph methodsFor: 'accessing' stamp: 'jm 9/27/97 06:44'!updateContinuously: aBoolean    updateContinuously _ aBoolean.! !!ColorPickerMorph methodsFor: 'event handling' stamp: 'jm 9/25/97 15:35'!handlesMouseDown: evt    ^ true! !!ColorPickerMorph methodsFor: 'event handling' stamp: 'jm 9/25/97 16:12'!mouseDown: evt    sourceHand _ evt hand.    self startStepping.! !!ColorPickerMorph methodsFor: 'event handling' stamp: 'jm 9/27/97 06:55'!mouseUp: evt    self stopStepping.    sourceHand _ nil.    deleteOnMouseUp ifTrue: [self delete].    self updateTargetColor.! !!ColorPickerMorph methodsFor: 'stepping' stamp: 'jm 9/25/97 16:05'!step    sourceHand ifNotNil:        [self pickColorAt: sourceHand position].! !!ColorPickerMorph methodsFor: 'stepping' stamp: 'jm 9/25/97 16:08'!stepTime    ^ 50! !!ColorPickerMorph methodsFor: 'private' stamp: 'jm 9/25/97 16:03'!pickColorAt: aPoint    | worldBox globalP c |    (FeedbackBox containsPoint: aPoint - self topLeft) ifTrue: [^ self].  "do nothing"    "pick up color, either inside or outside this world"    worldBox _ self world viewBox.    globalP _ aPoint + worldBox topLeft.  "get point in screen coordinates"    (worldBox containsPoint: globalP)        ifTrue: [c _ self world colorAt: aPoint belowMorph: Morph new]        ifFalse: [c _ Display colorAt: globalP].    "check for transparent color and update using appropriate feedback color"    (TransparentBox containsPoint: aPoint - self topLeft)        ifTrue: [self updateColor: Color transparent feedbackColor: Color white]        ifFalse: [self updateColor: c feedbackColor: c].! !!ColorPickerMorph methodsFor: 'private' stamp: 'jm 9/27/97 06:47'!updateColor: aColor feedbackColor: feedbackColor    "Set my selected color to the given color if it is different. Give user feedback. Inform the target of the change if the target and selector are not nil."     selectedColor = aColor ifTrue: [^ self].  "do nothing if color doesn't change"    originalForm fill: FeedbackBox fillColor: feedbackColor.    self form: originalForm.    selectedColor _ aColor.    updateContinuously ifTrue: [self updateTargetColor].! !!ColorPickerMorph methodsFor: 'private' stamp: 'jm 9/27/97 06:47'!updateTargetColor    ((target ~~ nil) and: [selector ~~ nil]) ifTrue: [        selector numArgs = 2            ifTrue: [target perform: selector with: selectedColor with: sourceHand]            ifFalse: [target perform: selector with: selectedColor]].! !!ColorPickerMorph methodsFor: 'menu' stamp: 'jm 9/28/97 14:36'!addCustomMenuItems: aCustomMenu hand: aHandMorph    super addCustomMenuItems: aCustomMenu hand: aHandMorph.    deleteOnMouseUp        ifTrue: [aCustomMenu add: 'stay up' action: #toggleDeleteOnMouseUp]        ifFalse: [aCustomMenu add: 'do not stay up' action: #toggleDeleteOnMouseUp].    updateContinuously        ifTrue: [aCustomMenu add: 'update only at end' action: #toggleUpdateContinuously]        ifFalse: [aCustomMenu add: 'update continuously' action: #toggleUpdateContinuously].! !!ColorPickerMorph methodsFor: 'menu' stamp: 'jm 9/27/97 06:53'!toggleDeleteOnMouseUp    deleteOnMouseUp _ deleteOnMouseUp not.! !!ColorPickerMorph methodsFor: 'menu' stamp: 'jm 9/27/97 06:54'!toggleUpdateContinuously    updateContinuously _ updateContinuously not.! !!ColorPickerMorph class methodsFor: 'all' stamp: 'jm 9/25/97 14:18'!initialize    "ColorPickerMorph initialize"    | chartExtent |    chartExtent _ 216@56.    ColorChart _ Color colorPaletteForDepth: 8 extent: chartExtent.    TransparentBox _ Rectangle origin: chartExtent - (50@19) extent: 50@19.    FeedbackBox _ 0@37 extent: 101@19.! !!CompiledMethod methodsFor: 'initialize-release'!copyWithTrailerBytes: bytes"Testing:    (CompiledMethod compiledMethodAt: #copyWithTrailerBytes:)        tempNamesPut: 'copy end '"    | copy end start |    start _ self initialPC.    end _ self endPC.    copy _ CompiledMethod newMethod: end - start + 1 + bytes size                header: self header.    1 to: self numLiterals do: [:i | copy literalAt: i put: (self literalAt: i)].    start to: end do: [:i | copy at: i put: (self at: i)].    1 to: bytes size do: [:i | copy at: end + i put: (bytes at: i)].    ^ copy! !!CompiledMethod methodsFor: 'accessing'!endPC    "Answer the index of the last bytecode."    | flagByte |    flagByte _ self last.    flagByte = 0 ifTrue:        ["If last byte = 0, may be either 0, 0, 0, 0 or just 0"        1 to: 4 do: [:i | (self at: self size - i) = 0 ifFalse: [^ self size - i]]].    flagByte < 252 ifTrue:        ["Magic sources (tempnames encoded in last few bytes)"        ^ self size - self last - 1].    "Normal 4-byte source pointer"    ^ self size - 4! !!CompiledMethod methodsFor: 'accessing' stamp: 'jm 9/18/97 21:06'!primitive    "Answer the primitive index associated with the receiver.    Zero indicates that this is not a primitive method.    We currently allow 11 bits of primitive index, but they are in two places    for  backward compatibility.  The time to unpack is negligible,    since the reconstituted full index is stored in the method cache."    | primBits |    primBits _ self header bitAnd: 16r300001FF.    primBits > 16r1FF        ifTrue: [^ (primBits bitAnd: 16r1FF) + (primBits bitShift: -19)]        ifFalse: [^ primBits]! !!CompiledMethod methodsFor: 'printing'!storeOn: aStream    | noneYet |    aStream nextPutAll: '(('.    aStream nextPutAll: self class name.    aStream nextPutAll: ' newMethod: '.    aStream store: self size - self initialPC + 1.    aStream nextPutAll: ' header: '.    aStream store: self header.    aStream nextPut: $).    noneYet _ self storeElementsFrom: self initialPC to: self endPC on: aStream.    1 to: self numLiterals do:        [:index |        noneYet            ifTrue: [noneYet _ false]            ifFalse: [aStream nextPut: $;].        aStream nextPutAll: ' literalAt: '.        aStream store: index.        aStream nextPutAll: ' put: '.        aStream store: (self literalAt: index)].    noneYet ifFalse: [aStream nextPutAll: '; yourself'].    aStream nextPut: $)! !!CompiledMethod methodsFor: 'printing' stamp: 'jm 9/3/97 11:05'!who     "Answer an Array of the class in which the receiver is defined and the     selector to which it corresponds."    Smalltalk allBehaviorsDo:        [:class |        class selectorsDo:            [:sel |            (class compiledMethodAt: sel) == self                 ifTrue: [^Array with: class with: sel]]].    ^ Array with: #unknown with: #unknown! !!CompiledMethod methodsFor: 'scanning'!readsField: varIndex     "Answer whether the receiver loads the instance variable indexed by the     argument."    self isReturnField ifTrue: [^self returnField + 1 = varIndex].    varIndex <= 16 ifTrue: [^ self scanFor: varIndex - 1].    varIndex <= 64 ifTrue: [^ self scanLongLoad: varIndex - 1].    ^ self scanVeryLongLoad: 64 offset: varIndex - 1! !!CompiledMethod methodsFor: 'scanning'!readsRef: literalAssociation     "Answer whether the receiver loads the argument."    | lit |    lit _ self literals indexOf: literalAssociation ifAbsent: [^false].    lit <= 32 ifTrue: [^self scanFor: 64 + lit - 1].    lit <= 64 ifTrue: [^self scanLongLoad: 192 + lit - 1].    ^ self scanVeryLongLoad: 128 offset: lit - 1! !!CompiledMethod methodsFor: 'scanning'!scanFor: byte     "Answer whether the receiver contains the argument as a bytecode."    ^ (InstructionStream on: self) scanFor: [:instr | instr = byte]"Smalltalk browseAllSelect: [:m | m scanFor: 134]"! !!CompiledMethod methodsFor: 'scanning'!scanLongStore: extension     "Answer whether the receiver contains a long store whose extension is     the argument."    | scanner |    scanner _ InstructionStream on: self.    ^scanner scanFor:         [:instr |  (instr = 129 or: [instr = 130]) and: [scanner followingByte = extension]]! !!CompiledMethod methodsFor: 'scanning'!scanVeryLongLoad: extension offset: offset    "Answer whether the receiver contains a long load whose extension is the     argument."    | scanner |    scanner _ InstructionStream on: self.    ^ scanner scanFor: [:instr | (instr = 132 and: [scanner followingByte = extension])                                            and: [scanner thirdByte = offset]]! !!CompiledMethod methodsFor: 'scanning' stamp: 'di 6/25/97 19:08'!scanVeryLongStore: extension offset: offset    "Answer whether the receiver contains a long load with the given offset.    Note that the constant +32 is the known difference between a    store and a storePop for instVars, and it will always fail on literal variables,    but these only use store (followed by pop) anyway."    | scanner ext |    scanner _ InstructionStream on: self.    ^ scanner scanFor:        [:instr | (instr = 132 and: [(ext _ scanner followingByte) = extension                                            or: ["might be a store/pop into rcvr"                                                ext = (extension+32)]])                            and: [scanner thirdByte = offset]]! !!CompiledMethod methodsFor: 'scanning'!sendsToSuper    "Answer whether the receiver sends any message to super."    | scanner |    scanner _ InstructionStream on: self.    ^ scanner scanFor:         [:instr |  instr = 16r85 or: [instr = 16r84                        and: [scanner followingByte between: 16r20 and: 16r3F]]]! !!CompiledMethod methodsFor: 'scanning'!writesField: field     "Answer whether the receiver stores into the instance variable indexed     by the argument."    self isQuick ifTrue: [^false].    field <= 8 ifTrue: [^ (self scanFor: 96 + field - 1)                        or: [self scanLongStore: field - 1]].    field <= 64 ifTrue: [^ self scanLongStore: field - 1].    ^ self scanVeryLongStore: 160 offset: field - 1! !!CompiledMethod methodsFor: 'scanning'!writesRef: ref     "Answer whether the receiver stores the argument."    | lit |    lit _ self literals indexOf: ref ifAbsent: [^false].    lit <= 64 ifTrue: [^ self scanLongStore: 192 + lit - 1].    ^ self scanVeryLongStore: 224 offset: lit - 1! !!CompiledMethod methodsFor: 'source code management'!copyWithTempNames: tempNames    | tempStr |    tempStr _ String streamContents:        [:strm | tempNames do: [:n | strm nextPutAll: n; space]].    ^ self copyWithTrailerBytes: (self qCompress: tempStr)! !!CompiledMethod methodsFor: 'source code management'!fileIndex    "Answer the index of the sources file on which this method is stored, as follows:        1:    .sources file        2:    .changes file        3 and 4 are also available for future extension of source code management"    self last < 252 ifTrue: [^ 0  "no source"].    ^ self last - 251    ! !!CompiledMethod methodsFor: 'source code management'!filePosition    "Answer the file position of this method's source code."    | pos |    self last < 252 ifTrue: [^ 0  "no source"].    pos _ 0.    self size - 1 to: self size - 3 by: -1 do: [:i | pos _ pos * 256 + (self at: i)].    ^ pos! !!CompiledMethod methodsFor: 'source code management' stamp: 'di 8/15/97 14:27'!getSourceFor: selector in: class    "Retrieve or reconstruct the source code for this method."    | source flagByte |    flagByte _ self last.    flagByte = 0 ifTrue:        ["No source pointer -- decompile without temp names"        ^ (class decompilerClass new decompile: selector in: class method: self)            decompileString].    flagByte < 252 ifTrue:        ["Magic sources -- decompile with temp names"        ^ ((class decompilerClass new withTempNames: self tempNames)                decompile: selector in: class method: self)            decompileString].    "Situation normal;  read the sourceCode from the file"    (source _ self getSourceFromFile) == nil ifFalse: [^ source].    "Something really wrong -- decompile blind (no temps)"    ^ (class decompilerClass new decompile: selector in: class method: self)            decompileString! !!CompiledMethod methodsFor: 'source code management'!getSourceFromFile    "Read the source code from file, determining source file index and    file position from the last 3 bytes of this method."    | position |    (position _ self filePosition) = 0 ifTrue: [^ nil].    ^ (RemoteString newFileNumber: self fileIndex position: position)            string! !!CompiledMethod methodsFor: 'source code management'!putSource: sourceStr fromParseNode: methodNode class: class category: catName    inFile: fileIndex priorMethod: priorMethod    ^ self putSource: sourceStr fromParseNode: methodNode inFile: fileIndex withPreamble:            [:file | class printCategoryChunk: catName on: file priorMethod: priorMethod.            file cr]! !!CompiledMethod methodsFor: 'source code management' stamp: '6/5/97 di'!putSource: sourceStr fromParseNode: methodNode class: class category: catName    withStamp: changeStamp inFile: fileIndex priorMethod: priorMethod    ^ self putSource: sourceStr fromParseNode: methodNode inFile: fileIndex withPreamble:            [:file |            class printCategoryChunk: catName on: file                withStamp: changeStamp priorMethod: priorMethod.            file cr]! !!CompiledMethod methodsFor: 'source code management'!putSource: sourceStr fromParseNode: methodNode inFile: fileIndex withPreamble: preambleBlock    "Store the source code for the receiver on an external file.    If no sources are available, i.e., SourceFile is nil, then store    temp names for decompilation at the end of the method.    If the fileIndex is 1, print on *.sources;  if it is 2, print on *.changes,    in each case, storing a 4-byte source code pointer at the method end."    | file remoteString |    (SourceFiles == nil or: [(file _ SourceFiles at: fileIndex) == nil]) ifTrue:        [^ self become: (self copyWithTempNames: methodNode tempNames)].    file setToEnd.    preambleBlock value: file.  "Write the preamble"    remoteString _ RemoteString newString: sourceStr                        onFileNumber: fileIndex toFile: file.    file nextChunkPut: ' '; flush.    self setSourcePosition: remoteString position inFile: fileIndex! !!CompiledMethod methodsFor: 'source code management'!qCompress: str    "A very simple text compression routine designed for method temp names.    Most common 12 chars get values 0-11 packed in one 4-bit nibble;    others get values 12-15 (2 bits) * 16 plus next nibble.    Last char of str must be a space so it may be dropped without    consequence if output ends on odd nibble."    | charTable odd ix oddNibble |    charTable _  "Character encoding table must match qDecompress:"    ' eatrnoislcm bdfghjkpquvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789'.    ^ ByteArray streamContents:        [:strm | odd _ true.  "Flag for odd or even nibble out"        str do:            [:char | ix _ (charTable indexOf: char) - 1.            (ix <= 12 ifTrue: [ix]                ifFalse: [Array with: ix//16+12 with: ix\\16])                do:                [:nibble | (odd _ odd not)                    ifTrue: [strm nextPut: oddNibble*16 + nibble]                    ifFalse: [oddNibble _ nibble]]].        strm nextPut: strm position]"  | m s |  m _ CompiledMethod new.s _ 'charTable odd ix oddNibble '.^ Array with: s size with: (m qCompress: s) size    with: (m qDecompress: (m qCompress: s))"! !!CompiledMethod methodsFor: 'source code management'!qDecompress: byteArray    "Decompress strings compressed by qCompress:.    Most common 12 chars get values 0-11 packed in one 4-bit nibble;    others get values 12-15 (2 bits) * 16 plus next nibble"    |  charTable extended ext |    charTable _  "Character encoding table must match qCompress:"    ' eatrnoislcm bdfghjkpquvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789'.    ^ String streamContents:        [:strm | extended _ false.  "Flag for 2-nibble characters"        byteArray do:            [:byte |             (Array with: byte//16 with: byte\\16)                do:                [:nibble | extended                    ifTrue: [strm nextPut: (charTable at: ext*16+nibble + 1). extended _ false]                    ifFalse: [nibble < 12 ifTrue: [strm nextPut: (charTable at: nibble + 1)]                                    ifFalse: [ext _ nibble-12.  extended _ true]]]]]! !!CompiledMethod methodsFor: 'source code management' stamp: 'di 6/15/97 09:14'!setSourcePointer: srcPointer    self setSourcePosition: srcPointer \\ 16r1000000 inFile: srcPointer // 16r1000000! !!CompiledMethod methodsFor: 'source code management'!setSourcePosition: position inFile: fileIndex     "Store the location of the source code for the receiver in the receiver. The     location consists of which source file (*.sources or *.changes) and the     position in that file."    fileIndex > 4 ifTrue: [^ self error: 'invalid file number'].    self at: self size put: 251 + fileIndex.    1 to: 3 do:         [:i | self at: self size - i put: ((position bitShift: (i-3)*8) bitAnd: 16rFF)].! !!CompiledMethod methodsFor: 'source code management'!setTempNamesIfCached: aBlock    "This is a cache used by the debugger, independent of the storage of    temp names when the system is converted to decompilation with temps."    TempNameCache == nil ifTrue: [^self].    TempNameCache key == self        ifTrue: [aBlock value: TempNameCache value]! !!CompiledMethod methodsFor: 'source code management' stamp: 'di 6/15/97 09:13'!sourcePointer    ^ (self fileIndex * 16r1000000) + self filePosition! !!CompiledMethod methodsFor: 'source code management'!tempNames    | byteCount bytes |    byteCount _ self at: self size.    byteCount = 0 ifTrue: [^ Array new].    bytes _ (ByteArray new: byteCount)        replaceFrom: 1 to: byteCount with: self         startingAt: self size - byteCount.    ^ (self qDecompress: bytes) findTokens: ' '! !!CompiledMethod class methodsFor: 'class initialization'!initialize    "CompiledMethod initialize"    "Initialize class variables specifying the size of the temporary frame    needed to run instances of me."    SmallFrame _ 12.    "Context range for temps+stack"    LargeFrame _ 32.! !!CompiledMethod class methodsFor: 'instance creation'!new    "This will not make a meaningful method, but it could be used    to invoke some otherwise useful method in this class."    ^ self newMethod: 0 header: 0! !!CompiledMethod class methodsFor: 'instance creation' stamp: 'jm 9/18/97 21:06'!newBytes: numberOfBytes nArgs: nArgs nTemps: nTemps nStack: stackSize nLits: nLits primitive: primitiveIndex    "Answer an instance of me. The header is specified by the message     arguments. The remaining parts are not as yet determined."    | largeBit primBits |    largeBit _ (nTemps + stackSize) > SmallFrame ifTrue: [1] ifFalse: [0].    primBits _ primitiveIndex <= 16r1FF        ifTrue: [primitiveIndex]        ifFalse: ["For now the high 2 bits of primitive no. are in high bits of header"                (primitiveIndex bitAnd: 16r1FF) + ((primitiveIndex bitAnd: 16r600) bitShift: 19)].    ^ self newMethod: numberOfBytes + 4     " +4 to store source code ptr"         header: (nArgs bitShift: 24) +                (nTemps bitShift: 18) +                (largeBit bitShift: 17) +                (nLits bitShift: 9) +                primBits! !!Compiler methodsFor: 'public access'!evaluate: textOrStream in: aContext to: receiver notifying: aRequestor ifFail: failBlock    "Compiles the sourceStream into a parse tree, then generates code into a     method. This method is then installed in the receiver's class so that it     can be invoked. In other words, if receiver is not nil, then the text can     refer to instance variables of that receiver (the Inspector uses this). If     aContext is not nil, the text can refer to temporaries in that context (the     Debugger uses this). If aRequestor is not nil, then it will receive a     notify:at: message before the attempt to evaluate is aborted. Finally, the     compiled method is invoked from here as DoIt or (in the case of     evaluation in aContext) DoItIn:. The method is subsequently removed     from the class, but this will not get done if the invocation causes an     error which is terminated. Such garbage can be removed by executing:     Smalltalk allBehaviorsDo: [:cl | cl removeSelector: #DoIt; removeSelector:     #DoItIn:]."    | methodNode method value |    class _ (aContext == nil ifTrue: [receiver] ifFalse: [aContext receiver]) class.    self from: textOrStream class: class context: aContext notifying: aRequestor.    methodNode _ self translate: sourceStream noPattern: true ifFail:        [^failBlock value].    method _ methodNode generate: #(0 0 0 0).    context == nil        ifTrue: [class addSelector: #DoIt withMethod: method.                value _ receiver DoIt.                class removeSelectorSimply: #DoIt.                ^value]        ifFalse: [class addSelector: #DoItIn: withMethod: method.                value _ receiver DoItIn: context.                class removeSelectorSimply: #DoItIn:.                ^value]! !!Compiler methodsFor: 'public access'!format: textOrStream in: aClass notifying: aRequestor    "Compile a parse tree from the argument, textOrStream. Answer a string     containing the original code, formatted nicely.    If the leftShift key is pressed, then decorate the resulting text with    color and hypertext actions"    | aNode |    self from: textOrStream        class: aClass        context: nil        notifying: aRequestor.    aNode _ self format: sourceStream noPattern: false ifFail: [^nil].    Sensor leftShiftDown        ifTrue: [^ aNode decompileText]        ifFalse: [^ aNode decompileString]! !!CompositionScanner methodsFor: 'scanning'!composeLine: lineIndex fromCharacterIndex: startIndex inParagraph: aParagraph     "Answer an instance of TextLineInterval that represents the next line in the paragraph."    | runLength done stopCondition |    spaceX _ destX _ leftMargin _ aParagraph leftMarginForCompositionForLine: lineIndex.    destY _ 0.    rightMargin _ aParagraph rightMarginForComposition.    leftMargin >= rightMargin ifTrue: [self error: 'No room between margins to compose'].    lastIndex _ startIndex.    "scanning sets last index"    lineHeight _ textStyle lineGrid.  "may be increased by setFont:..."    baseline _ textStyle baseline.    self setStopConditions.    "also sets font"    runLength _ text runLengthFor: startIndex.    runStopIndex _ (lastIndex _ startIndex) + (runLength - 1).    line _ TextLineInterval        start: lastIndex        stop: 0        internalSpaces: 0        paddingWidth: 0.    spaceCount _ 0.    done _ false.    [done]        whileFalse:             [stopCondition _ super                scanCharactersFrom: lastIndex                to: runStopIndex                in: text string                rightX: rightMargin                stopConditions: stopConditions                displaying: false.            "See setStopConditions for stopping conditions for composing."            (self perform: stopCondition)                ifTrue: [^line lineHeight: lineHeight + textStyle leading                            baseline: baseline + textStyle leading]]! !!CompositionScanner methodsFor: 'scanning'!setActualFont: aFont        "Keep track of max height and ascent for auto lineheight"        | descent |        super setActualFont: aFont.        descent _ lineHeight - baseline max: font descent.        baseline _ baseline max: font ascent.        lineHeight _ lineHeight max: baseline + descent! !!CompositionScanner methodsFor: 'scanning'!setFont: fontNumber        "Keep track of max height and ascent for auto lineheight"        | descent |        super setFont: fontNumber.        descent _ lineHeight - baseline max: font descent.        baseline _ baseline max: font ascent.        lineHeight _ lineHeight max: baseline + descent! !!CompositionScanner methodsFor: 'stop conditions'!crossedX    "There is a word that has fallen across the right edge of the composition     rectangle. This signals the need for wrapping which is done to the last     space that was encountered, as recorded by the space stop condition."    line stop: spaceIndex.    spaceCount > 1            ifTrue:    ["The common case. First back off the space at which we wrap."                spaceCount _ spaceCount - 1.                spaceIndex _ spaceIndex - 1.                ["Check to see if any spaces preceding the one at which we wrap.                    Double space after a period, most likely."                (spaceCount > 1 and: [(text at: spaceIndex) = Space])]                    whileTrue:                        [spaceCount _ spaceCount - 1.                        "Account for backing over a run which might                            change width of space."                        font _ textStyle fontAt:                                (text fontNumberAt: spaceIndex).                        spaceIndex _ spaceIndex - 1.                        spaceX _ spaceX - (font widthOf: Space)].                        line paddingWidth: rightMargin - spaceX.                        line internalSpaces: spaceCount]        ifFalse:    [spaceCount = 1                    ifTrue:    ["wrap at space, but no internal spaces"                            line internalSpaces: 0.                            line paddingWidth: rightMargin - spaceX]                    ifFalse:    ["Neither internal nor trailing spaces, almost never happen,                                she says confidently."                            lastIndex _ lastIndex - 1.                            [destX <= rightMargin]                            whileFalse:                                [destX _ destX - (font widthOf:                                                    (text at: lastIndex)).                                        "bug --doesn't account for backing over                                         run and changing actual width of                                        characters. Also doesn't account for                                        backing over a tab.  Happens only                                        when no spaces in line, presumably rare."                                lastIndex _ lastIndex - 1].                            spaceX _ destX.                            line paddingWidth: rightMargin - destX.                            lastIndex < line first                                ifTrue:    [line stop: line first]                                ifFalse:    [line stop: lastIndex]]].    ^true! !ConciseInspector comment:'An Inspector that omits the self and all inst vars lines'!!ContextPart methodsFor: 'instruction decoding' stamp: 'sn 8/21/97 22:15'!send: selector super: superFlag numArgs: numArgs    "Simulate the action of bytecodes that send a message with selector,     selector. The argument, superFlag, tells whether the receiver of the     message was specified with 'super' in the source method. The arguments     of the message are found in the top numArgs locations on the stack and     the receiver just below them."    | receiver arguments answer |    arguments _ Array new: numArgs.    numArgs to: 1 by: -1 do: [ :i | arguments at: i put: self pop].    receiver _ self pop.    (selector == #halt or: [selector == #halt:]) ifTrue:        [self error: 'Cant simulate halt.  Proceed to bypass it.'.        self push: nil. ^self].    selector == #doPrimitive:receiver:args:        ifTrue: [answer _ receiver                     doPrimitive: (arguments at: 1)                    receiver: (arguments at: 2)                    args: (arguments at: 3).                self push: answer.                ^self].    ^self send: selector to: receiver with: arguments super: superFlag! !!ContextPart methodsFor: 'debugger access'!mclass     "Answer the class in which the receiver's method was found."    self receiver class selectorAtMethod: self method setClass: [:mclass].    ^mclass! !!ContextPart methodsFor: 'debugger access'!sourceCode    | selector methodClass |    selector _ self receiver class selectorAtMethod: self method        setClass: [:mclass | methodClass _ mclass].    ^ methodClass sourceCodeAt: selector! !!ContextPart methodsFor: 'debugger access'!tempNames    "Answer an OrderedCollection of the names of the receiver's temporary     variables, which are strings."    self method setTempNamesIfCached: [:names | ^names].    names _ (self mclass compilerClass new            parse: self sourceCode            in: self mclass            notifying: nil) tempNames.    self method cacheTempNames: names.    ^names! !!ContextPart methodsFor: 'printing'!printOn: aStream     | selector class |    selector _         (class _ self receiver class)             selectorAtMethod: self method             setClass: [:mclass].    selector == #?        ifTrue:             [aStream nextPut: $?; print: self method who.            ^self].    aStream nextPutAll: class name.    mclass == class         ifFalse:             [aStream nextPut: $(.            aStream nextPutAll: mclass name.            aStream nextPut: $)].    aStream nextPutAll: '>>'.    aStream nextPutAll: selector! !!ContextPart methodsFor: 'system simulation' stamp: 'sn 8/22/97 21:55'!stepToSendOrReturn    "Simulate the execution of bytecodes until either sending a message or     returning a value to the receiver (that is, until switching contexts)."    [self willReallySend | self willReturn]        whileFalse: [self step]! !!ContextPart methodsFor: 'private'!doPrimitive: primitiveIndex receiver: receiver args: arguments     "Simulate a primitive method whose index is primitiveIndex.  The    simulated receiver and arguments are given as arguments to this message.""    NOTE: In order for perform:WithArguments: to work reliably here,    this method must be forced to invoke a large context.  This is done    by adding extra temps until the following expression evaluates as true:        (ContextPart compiledMethodAt: #doPrimitive:receiver:args:) frameSize > 20"    | primitiveMethod value t1 t2 t3 |    "If successful, push result and return resuming context,        else ^ #simulatorFail"    (primitiveIndex = 80 and: [receiver isKindOf: ContextPart])        ifTrue: [^self push:                     ((BlockContext new: receiver size)                        home: receiver home                        startpc: pc + 2                        nargs: (arguments at: 1))].    (primitiveIndex = 81 and: [receiver isMemberOf: BlockContext])        ifTrue: [^receiver pushArgs: arguments from: self].    primitiveIndex = 83         ifTrue: [^ self send: arguments first to: receiver                    with: arguments allButFirst                    super: false].    arguments size > 6 ifTrue: [^#simulatorFail].    primitiveMethod _ TryPrimitiveMethods at: arguments size + 1.    "slam num into primitive instead of 100 such messages in Object"    primitiveMethod bePrimitive: primitiveIndex.    "Class flushCache."  "in case interp caches primitive #"    value _ receiver perform: (TryPrimitiveSelectors at: arguments size+1)                withArguments: arguments.    value == #simulatorFail        ifTrue: [^ #simulatorFail]        ifFalse: [^ self push: value]! !!ContextPart class methodsFor: 'examples'!tallyInstructions: aBlock    "This method uses the simulator to count the number of occurrences of    each of the Smalltalk instructions executed during evaluation of aBlock.    Results appear in order of the byteCode set."    | tallies |    tallies _ Bag new.    thisContext sender        runSimulated: aBlock        contextAtEachStep:            [:current | tallies add: current nextByte].    ^tallies sortedElements    "ContextPart tallyInstructions: [3.14159 printString]"! !!ContextPart class methodsFor: 'examples'!tallyMethods: aBlock    "This method uses the simulator to count the number of calls on each method    invoked in evaluating aBlock. Results are given in order of decreasing counts."    | prev tallies |    tallies _ Bag new.    prev _ aBlock.    thisContext sender        runSimulated: aBlock        contextAtEachStep:            [:current |            current == prev ifFalse: "call or return"                [prev sender == nil ifFalse: "call only"                    [tallies add: current printString].                prev _ current]].    ^tallies sortedCounts    "ContextPart tallyMethods: [3.14159 printString]"! !!ContextPart class methodsFor: 'examples'!trace: aBlock        "ContextPart trace: [3 factorial]"    "This method uses the simulator to print calls and returned values in the Transcript."    | prev |    Transcript clear.    prev _ aBlock.    ^ thisContext sender        runSimulated: aBlock        contextAtEachStep:            [:current |            Sensor anyButtonPressed ifTrue: [^ nil].            current == prev                ifFalse:                    [prev sender == nil ifTrue:  "returning"                        [Transcript space; nextPut: $^; print: current top].                    Transcript cr;                        nextPutAll: (String new: (current depthBelow: aBlock) withAll: $ );                        print: current receiver; space; nextPutAll: current selector; endEntry.                    prev _ current]]! !!ContextPart class methodsFor: 'examples'!trace: aBlock onFileNamed: fileName        "ContextPart trace: [3 factorial]"    "This method uses the simulator to print calls to a file."    | prev f sel |    f _ FileStream fileNamed: fileName.    prev _ aBlock.    thisContext sender        runSimulated: aBlock        contextAtEachStep:            [:current |            Sensor anyButtonPressed ifTrue: [^ nil].            current == prev                ifFalse:                    [f cr;                        nextPutAll: (String new: (current depthBelow: aBlock) withAll: $ );                        print: current receiver class; space; nextPutAll: (sel _ current selector); flush.                    prev _ current.                    sel == #error: ifTrue: [self halt]]].    f close! !!ContextStackListController methodsFor: 'initialize-release'!release    model release.  "restore low space watcher"    super release.! !!ContextStackListController methodsFor: 'menu messages'!fullStack    "Change from displaying the minimal stack to a full one."    model contextStackList size > 15 "Already expanded"        ifTrue:            [view flash]        ifFalse:            [model contextStackIndex = 0                ifFalse: [model toggleContextStackIndex: model contextStackIndex].            self controlTerminate.            model fullyExpandStack.            self controlInitialize]! !!ContextStackListController methodsFor: 'menu messages'!proceed    "Proceed execution of the receiver's model, starting after the expression at     which an interruption occurred."    self controlTerminate.    Smalltalk okayToProceedEvenIfSpaceIsLow ifTrue: [        model proceed: view topView controller.    ].    self controlInitialize! !!ContextVariablesInspector methodsFor: 'selecting'!replaceSelectionValue: anObject     "Refer to the comment in Inspector|replaceSelectionValue:."    selectionIndex = 1        ifTrue: [^object]        ifFalse: [^object tempAt: selectionIndex - 2 put: anObject]! !!ControlManager methodsFor: 'accessing' stamp: 'sw 9/27/96'!controllersSatisfying: aBlock    "Return a list of scheduled controllers satisfying aBlock.  "    ^ scheduledControllers select:        [:aController | (aBlock value: aController) == true]! !!ControlManager methodsFor: 'accessing' stamp: 'sw 10/9/96'!removeAllControllersSatisfying: aBlock    "Unschedule and delete all controllers satisfying aBlock.  May not leave the screen exactly right sometimes. "    (self controllersSatisfying:  aBlock) do:        [:aController | aController closeAndUnschedule]! !!ControlManager methodsFor: 'accessing' stamp: 'di 10/4/97 09:05'!scheduledWindowControllers    "Same as scheduled controllers, but without ScreenController.    Avoids null views just after closing, eg, a debugger."    ^ scheduledControllers select:        [:c | c ~~ screenController and: [c view ~~ nil]]! !!ControlManager methodsFor: 'scheduling'!interruptName: labelString    "Create a Notifier on the active scheduling process with the given label. Make the Notifier the active controller."    | suspendingList newActiveController |    suspendingList _ activeControllerProcess suspendingList.    suspendingList isNil ifTrue: [        activeControllerProcess == Processor activeProcess            ifTrue: [activeControllerProcess suspend].    ] ifFalse: [        suspendingList remove: activeControllerProcess.        activeControllerProcess offList].    activeController ~~ nil ifTrue: [        "Carefully de-emphasis the current window."        activeController view topView deEmphasizeForDebugger].    newActiveController _        (DebuggerView            openInterrupt: labelString            onProcess: activeControllerProcess) controller.    newActiveController centerCursorInView.    self activeController: newActiveController.! !!ControlManager methodsFor: 'displaying' stamp: 'di 10/4/97 09:03'!restore    "Clear the screen to gray and then redisplay all the scheduled views.  Try to be a bit intelligent about the view that wants control and not display it twice if possible."    scheduledControllers first view uncacheBits.  "assure refresh"    self unschedule: screenController; scheduleOnBottom: screenController.    screenController view window: Display boundingBox; displayDeEmphasized.    self scheduledWindowControllers reverseDo:        [:aController | aController view displayDeEmphasized].! !!ControlManager methodsFor: 'displaying'!updateGray    "From Georg Gollmann - 11/96.  tell the Screen Controller's model to use the currently-preferred desktop color."    "ScheduledControllers updateGray"    (screenController view model isMemberOf: InfiniteForm)        ifTrue: [screenController view model: (InfiniteForm with:Preferences desktopColor)]! !!ControlManager class methodsFor: 'exchange'!newScheduler: controlManager    "When switching projects, the control scheduler has to be exchanged. The     active one is the one associated with the current project."    Smalltalk at: #ScheduledControllers put: controlManager.    ScheduledControllers restore.    controlManager searchForActiveController! !!ControlManager class methodsFor: 'snapshots' stamp: 'di 6/16/97 11:42'!shutDown  "Saves space in snapshots"    ScheduledControllers unCacheWindows! !!CRFillInTheBlankController methodsFor: 'sensor access'!dispatchOnCharacter: char with: typeAheadStream    "Accept and terminate the interation if the user hits a CR or the enter key."    (char = Character cr) | (char = Character enter)        ifTrue:            [sensor keyboard.  "gobble the character"            self accept.            ^ true]        ifFalse:            [^ super dispatchOnCharacter: char with: typeAheadStream].! !!Curve methodsFor: 'private' stamp: 'di 9/26/97 09:53'!addHandles    super addHandles.    self updateHandles! !!Curve methodsFor: 'private' stamp: '6/9/97 21:28 di'!computeCurve    "Compute an array for the coefficients.  This is copied from Flegal's old    code in the Spline class."    | length extras verts |    verts _ closed ifTrue: [vertices copyWith: vertices first]                ifFalse: [vertices].    length _ verts size.    extras _ 0.    coefficients _ Array new: 8.    1 to: 8 do: [:i | coefficients at: i put: (Array new: length + extras)].    1 to: 5 by: 4 do:         [:k |         1 to: length do:            [:i | (coefficients at: k)                    at: i put: (k = 1                        ifTrue: [(verts at: i) x asFloat]                        ifFalse: [(verts at: i) y asFloat])].            1 to: extras do: [:i | (coefficients at: k)                    at: length + i put: ((coefficients at: k)                        at: i + 1)].            self derivs: (coefficients at: k)                first: (coefficients at: k + 1)                second: (coefficients at: k + 2)                third: (coefficients at: k + 3)].    extras > 0         ifTrue: [1 to: 8 do:                     [:i |                     coefficients at: i put: ((coefficients at: i)                                            copyFrom: 2 to: length + 1)]]! !!Curve methodsFor: 'private' stamp: '6/10/97 16:29 di'!curveBounds    "Compute the bounds from actual curve traversal, with leeway for borderWidth.    Also note the next-to-first and next-to-last points for arrow directions."    | curveBounds |    self computeCurve.    curveBounds _ vertices first corner: vertices last.    ntfPoint _ nil.    self lineSegmentsDo:        [:p1 :p2 | ntfPoint == nil ifTrue: [ntfPoint _ p2].        curveBounds _ curveBounds encompass: p2.        ntlPoint _ p1].    ^ curveBounds topLeft asIntegerPoint - 1        corner: (curveBounds bottomRight + (borderWidth+1)) asIntegerPoint! !!Curve methodsFor: 'private' stamp: '6/9/97 10:32 di'!derivs: a first: point1 second: point2 third: point3    "Compute the first, second and third derivitives (in coefficients) from    the Points in this Path (coefficients at: 1 and coefficients at: 5)."    | len v anArray |    len _ a size.    len < 2 ifTrue: [^self].    len > 2 ifTrue:        [v _ Array new: len.         v  at: 1 put: 4.0.         anArray _ Array new: len.         anArray at: 1 put: (6.0 * ((a at: 1) - ((a at: 2) * 2.0) + (a at: 3))).         2 to: len - 2 do:            [:i |             v  at: i put: (4.0 - (1.0 / (v at: i-1))).            anArray at: i                 put: (6.0 * ((a at: i) - ((a at: i+1) * 2.0) + (a at: i+2))                        - ((anArray at: i-1) / (v at: i-1)))].         point2 at: len-1 put: ((anArray at: len-2) / (v at: len-2)).         len - 2 to: 2 by: 0-1 do:             [:i |             point2 at: i                 put: ((anArray at: i-1) - (point2 at: i+1) / (v at: i-1))]].    point2 at: 1 put: (point2 at: len put: 0.0).    1 to: len - 1 do:        [:i | point1 at: i                 put: ((a at: i+1) - (a at: i) -                         ((point2 at: i) * 2.0 + (point2 at: i+1) / 6.0)).              point3 at: i put: ((point2 at: i+1) - (point2 at: i))]! !!Curve methodsFor: 'private' stamp: 'di 6/25/97 23:22'!lineSegmentsDo: endPointsBlock    "Emit a sequence of line segments into endPointsBlock to approximate this spline."    | n t x y x1 x2 x3 y1 y2 y3 beginPoint endPoint |    vertices size < 1 ifTrue: [^ self].    beginPoint _ (x _ (coefficients at: 1) at: 1) @ (y _ (coefficients at: 5) at: 1).    1 to: (coefficients at: 1) size - 1 do:         [:i |  "taylor series coefficients"        x1 _ (coefficients at: 2) at: i.        y1 _ (coefficients at: 6) at: i.        x2 _ ((coefficients at: 3) at: i) / 2.0.        y2 _ ((coefficients at: 7) at: i) / 2.0.        x3 _ ((coefficients at: 4) at: i) / 6.0.        y3 _ ((coefficients at: 8) at: i) / 6.0.        "guess n"        n _ 5 max: (x2 abs + y2 abs * 2.0 + ((coefficients at: 3) at: i+1) abs                                    + ((coefficients at: 7) at: i+1) abs / 100.0) rounded.        1 to: n - 1 do:             [:j |             t _ j asFloat / n.            endPoint _ (x3 * t + x2 * t + x1 * t + x) @ (y3 * t + y2 * t + y1 * t + y).            endPointsBlock value: beginPoint asIntegerPoint                            value: endPoint asIntegerPoint.            beginPoint _ endPoint].        endPoint _ (x _ (coefficients at: 1) at: i+1) @ (y _ (coefficients at: 5) at: i+1).        endPointsBlock value: beginPoint asIntegerPoint                        value: endPoint asIntegerPoint.        beginPoint _ endPoint]! !!Curve methodsFor: 'private' stamp: '6/9/97 12:08 di'!nextToFirstPoint  "For arrow direction"    ^ ntfPoint! !!Curve methodsFor: 'private' stamp: '6/9/97 12:08 di'!nextToLastPoint  "For arrow direction"    ^ ntlPoint! !!Curve methodsFor: 'private' stamp: '6/9/97 13:57 di'!privateMoveBy: delta    super privateMoveBy: delta.    self computeCurve! !!Curve methodsFor: 'private' stamp: 'di 9/26/97 10:01'!updateHandles    | midPts nextVertIx tweens newVert |    midPts _ OrderedCollection new.    nextVertIx _ 2.    tweens _ OrderedCollection new.    self lineSegmentsDo:        [:p1 :p2 |        tweens addLast: p2.        p2 = (vertices atWrap: nextVertIx) ifTrue:            ["Found endPoint."            midPts addLast: (tweens at: tweens size // 2)                        + (tweens at: tweens size + 1 // 2) // 2.            tweens _ OrderedCollection new.            nextVertIx _ nextVertIx + 1]].    midPts withIndexDo:        [:midPt :vertIndex |        (closed or: [vertIndex < vertices size]) ifTrue:            [newVert _ handles at: vertIndex*2.            newVert position: midPt - (newVert extent // 2) + (2@0)]].! !CurveFitter class comment:'I represent a conic section determined by three points p1,p2 and p3. I interpolate p1 and p3 and am tangent to line p1,p2 at p1 and line p3,p2 at p3.'!!CurveFitter methodsFor: 'displaying' stamp: '6/9/97 10:16 di'!displayOn: aDisplayMedium transformation: aTransformation clippingBox: clipRect rule: anInteger fillColor: aForm    | transformedPath newCurveFitter |    transformedPath _ aTransformation applyTo: self.    newCurveFitter _ CurveFitter new.    newCurveFitter firstPoint: transformedPath firstPoint.    newCurveFitter secondPoint: transformedPath secondPoint.    newCurveFitter thirdPoint: transformedPath thirdPoint.    newCurveFitter form: self form.    newCurveFitter        displayOn: aDisplayMedium        at: 0 @ 0        clippingBox: clipRect        rule: anInteger        fillColor: aForm! !!CurveFitter class methodsFor: 'examples' stamp: '6/9/97 10:16 di'!example    "Designate three locations on the screen by clicking any button. The    curve determined by the points will be displayed with a long black form."    | aCurveFitter aForm |      aForm _ Form extent: 1@30.            "make a long thin Form for display "    aForm fillBlack.                            "turn it black"    aCurveFitter _ CurveFitter new.    aCurveFitter form: aForm.                        "set the form for display"                "collect three Points and show them on the dispaly"    aCurveFitter firstPoint: Sensor waitButton. Sensor waitNoButton.    aForm displayOn: Display at: aCurveFitter firstPoint.    aCurveFitter secondPoint: Sensor waitButton. Sensor waitNoButton.    aForm displayOn: Display at: aCurveFitter secondPoint.    aCurveFitter thirdPoint: Sensor waitButton. Sensor waitNoButton.    aForm displayOn: Display at: aCurveFitter thirdPoint.    aCurveFitter displayOn: Display                    "display the CurveFitter"    "CurveFitter example"! !CustomMenu comment:'I am used to build menus on-the-fly. I maintain lists of menu items, actions (usually symbols to be sent as messages), and menu section dividing lines to which my clients may append new entries and lines by sending me the messages:    add: aString action: anAction    addLineAfter the menu is constructed, it may be invoked with one of the following messages:    invoke: initialSelection    invokeI am a subclass of ActionMenu, so I inherit a number of instance variables. The ones I am particularly concerned with are:    items _ an OrderedCollection of strings to appear in the menu    selectors _ an OrderedCollection of Symbols to be used as message selectors    lineArray _ an OrderedCollection of line positions    lastLine _ used to keep track of the last line to avoid making duplicate entries in lineArray'!!CustomMenu methodsFor: 'initialize-release'!initialize    labels _ OrderedCollection new.    selections _ OrderedCollection new.    dividers _ OrderedCollection new.    lastDivider _ 0.! !!CustomMenu methodsFor: 'construction'!add: aString action: actionItem    "Add the given string as the next menu item. If it is selected, the given action (usually but not necessarily a symbol) will be returned to the client."    | s |    s _ String new: aString size + 2.    s at: 1 put: Character space.    s replaceFrom: 2 to: s size - 1 with: aString.    s at: s size put: Character space.    labels addLast: s.    selections addLast: actionItem.! !!CustomMenu methodsFor: 'construction'!addLine    "Append a line to the menu after the last entry. Suppress duplicate lines."    (lastDivider ~= selections size) ifTrue: [        lastDivider _ selections size.        dividers addLast: lastDivider].! !!CustomMenu methodsFor: 'invocation'!invokeOn: targetObject defaultSelection: defaultSelection    "Invoke the menu with the given default selection (i.e. one of my 'action' symbols). Answer the 'action' selector associated with the menu item chosen by the user or nil if none is chosen."    | sel |    sel _ self startUp: defaultSelection.    sel = nil ifFalse: [^ targetObject perform: sel].    ^ nil! !!CustomMenu methodsFor: 'invocation'!startUp    "Build and invoke this menu with no initial selection. Answer the selection associated with the menu item chosen by the user or nil if none is chosen."    ^ self startUp: nil! !!CustomMenu methodsFor: 'invocation'!startUp: initialSelection    "Build and invoke this menu with the given initial selection. Answer the selection associated with the menu item chosen by the user or nil if none is chosen."    ^ self startUp: initialSelection withCaption: nil! !!CustomMenu methodsFor: 'invocation'!startUp: initialSelection withCaption: caption    "Build and invoke this menu with the given initial selection and caption. Answer the selection associated with the menu item chosen by the user or nil if none is chosen."    self build.    (initialSelection notNil) ifTrue: [self preSelect: initialSelection].    ^ super startUpWithCaption: caption! !!CustomMenu methodsFor: 'private'!build    "Turn myself into an invokable ActionMenu."    | stream |    stream _ WriteStream on: (String new).    labels do: [: label | stream nextPutAll: label; cr].    (labels isEmpty) ifFalse: [stream skip: -1].  "remove final cr"    self labels: stream contents        font: (TextStyle default fontAt: 1)        lines: dividers.! !!CustomMenu methodsFor: 'private'!preSelect: action    "Pre-select and highlight the menu item associated with the given action."    | i |    i _ selections indexOf: action ifAbsent: [^ self].    marker _ marker        align: marker topLeft        with: (marker left)@(frame inside top + (marker height * (i - 1))).    selection _ i.! !!CustomMenu class methodsFor: 'instance creation'!new    ^ super new initialize! !!CustomMenu class methodsFor: 'example'!example    "CustomMenu example"    | menu |    menu _ CustomMenu new.    menu add: 'apples' action: #apples.    menu add: 'oranges' action: #oranges.    menu addLine.    menu addLine.  "extra lines ignored"    menu add: 'peaches' action: #peaches.    menu addLine.    menu add: 'pears' action: #pears.    menu addLine.    ^ menu startUp: #apples! !!DamageRecorder methodsFor: 'all'!blackenDamageOn: aCanvas    "For testing. Blackens the damaged rectangles momentarily so you can see the incremental redisplay at work."    | c |    invalidRects do: [:r |        c _ aCanvas copyClipRect: r.        c fillColor: Color black].! !!DamageRecorder methodsFor: 'all'!doFullRepaint    "Record that a full redisplay is needed. No further damage rectangles will be recorded until after the next reset."    ^ totalRepaint _ true.! !!DamageRecorder methodsFor: 'all'!invalidRectsFullBounds: aRectangle    "Return a collection of damaged rectangles for the given canvas. If a total repaint has been requested, return the given rectangle."    totalRepaint        ifTrue: [^ Array with: aRectangle]        ifFalse: [^ invalidRects copy].! !!DamageRecorder methodsFor: 'all'!recordInvalidRect: aRectangle    "Record the given rectangle in my damage list, a list of rectagular areas of the display that should be redraw on the next display cycle."    "Details: Damaged rectangles are often identical or overlap significantly. In these cases, we merge them to reduce the number of damage rectangles that must be processed when the display is updated. Moreover, above a certain threshold, we ignore the individual rectangles completely, and simply do a complete repaint on the next cycle."    totalRepaint ifTrue: [^ self].  "planning full repaint; don't bother collecting damage"    invalidRects do: [:rect |        (rect intersects: aRectangle) ifTrue: [            "merge rectangle in place (see note below) if there is any overlap"            rect setOrigin: (rect origin min: aRectangle origin) truncated                corner: (rect corner max: aRectangle corner) truncated.            ^ self]].    invalidRects size >= 10 ifTrue: [        "if there are too many separate areas, just repaint all"        totalRepaint _ true.        ^ self].    "add the given rectangle to the damage list"    "Note: We make a deep copy of all rectangles added to the damage list,     since rectangles in this list may be extended in place."    invalidRects addLast: (aRectangle topLeft truncated corner: aRectangle bottomRight truncated).! !!DamageRecorder methodsFor: 'all'!reset    "Clear the damage list."    invalidRects _ OrderedCollection new.    totalRepaint _ false.! !!DamageRecorder methodsFor: 'all'!updateIsNeeded    "Return true if the display needs to be updated."    ^ totalRepaint or: [invalidRects size > 0]! !!DamageRecorder class methodsFor: 'instance creation'!new    ^ super new reset! !DataStream comment:'This is the save-to-disk facility. A DataStream can store one or more objects in a persistent form.To handle objects with sharing and cycles, you must use aReferenceStream instead of a DataStream.  (Or SmartRefStream.)  ReferenceStream is typicallyfaster and produces smaller files because it doesn''t repeatedly write the same Symbols.Here is the way to use DataStream and ReferenceStream:    rr _ ReferenceStream fileNamed: ''test.obj''.    rr nextPut: <your object>.    rr close.To get it back:    rr _ ReferenceStream fileNamed: ''test.obj''.    <your object> _ rr next.    rr close.Each object to be stored has two opportunities to control what gets stored. The high level, more useful hook is objectToStoreOnDataStream [externalize]. The low level hook is storeDataOn:. The read-in counterparts to these messages are comeFullyUpOnReload [internalize] and (class) readDataFrom:size:. See these methods, the class DiskProxy, and the class IOWeakArray for more information about externalizing and internalizing.Public messages:    (class) on:    (class) fileNamed:    (class) fileTypeCode    atEnd    beginInstance:size: (for use by storeDataOn: methods)    beginReference: (for use by readDataFrom:size: methods)    close    next    next:    nextPut:    nextPutAll:    reset    setType:    sizeNOTE: A DataStream should be treated as a read-stream *or* as awrite-stream, *not* as a read/write-stream.[TBD] We should be able to make this much faster via tight-loopbyte-string I/O. It looks like FileStream (and WriteStream)nextPutAll: do a reasonable job *if* it doesn''t have to push thewriteLimit, in which case it iterates with nextPut:. It could in manycases set the writeLimit and then use the fast case(replaceFrom:to:with:startingAt:), or fill a buffer at at time viathe fast case working on a substring.    This approach would handle Strings, ByteArrays, and all othervariable-byte classes. If(nextPutAll: aCollection) in some casesstill reverts to (aCollection do: [:e | self nextPut: e]), then we''dwant to make Obj respond to do:. Then we could speed up innerloop activities like nextPutInt32:.[TBD] Every DataStream should begin with 4 signature bytes."on:" should emit or check the signature. But the current mechanism doesn''t alwaysknow when the stream is started or ended.[TBD] Cf. notes in DataStream>>beginInstance:size: andObject>>readDataFrom:size:.[TBD] We could save disk space & I/O time by using short, 1-byte sizefields whenever possible. E.g. almost all Symbols are shorter than256 chars. We could do this either by (1) using different typeID codesto indicate when a 1-byte length follows, a scheme which could stillread all the old files but would take more code, or (2) avariable-length code for sizes.    -- 11/15/92 jhm'!!DataStream methodsFor: 'all' stamp: '6/9/97 08:14 tk'!beginInstance: aClass size: anInteger    "This is for use by storeDataOn: methods.     Cf. Object>>storeDataOn:."        "Addition of 1 seems to make extra work, since readInstance        has to compensate.  Here for historical reasons dating back        to Kent Beck's original implementation in late 1988.        In ReferenceStream, class is just 5 bytes for shared symbol.        SmartRefStream puts out the names and number of class's instances variables for checking."    byteStream nextNumber: 4 put: anInteger + 1.    self nextPut: aClass name! !!DataStream methodsFor: 'all'!byteStream    ^ byteStream! !!DataStream methodsFor: 'all' stamp: 'tk 8/16/96'!checkForPaths: anObject    "After an object is fully internalized, it should have no PathFromHome in it.    The only exception is Array, as pointed to by an IncomingObjects.  "    | pfh |    pfh _ Smalltalk at: #PathFromHome ifAbsent: [^ self].    1 to: anObject class instSize do:        [:i | (anObject instVarAt: i) class == pfh ifTrue: [            self error: 'Unresolved Path']].! !!DataStream methodsFor: 'all'!close    "Close the stream."    | bytes |    byteStream closed         ifFalse: [            bytes _ byteStream position.            byteStream close]        ifTrue: [bytes _ 'unknown'].    ^ bytes! !!DataStream methodsFor: 'all' stamp: '6/10/97 16:50 tk'!next    "Answer the next object in the stream."    | type selector anObject isARefType pos |    type _ byteStream next.    type ifNil: [pos _ byteStream position.    "absolute!!!!"        byteStream close.    "clean up"        byteStream position = 0             ifTrue: [self error: 'The file did not exist in this directory']             ifFalse: [self error: 'Unexpected end of object file'].        pos.    "so can see it in debugger"        ^ nil].    type = 0 ifTrue: [pos _ byteStream position.    "absolute!!!!"        byteStream close.    "clean up"        self error: 'Expected start of object, but found 0'.        ^ nil].    isARefType _ self noteCurrentReference: type.    selector _ #(readNil readTrue readFalse readInteger            readString readSymbol readByteArray            readArray readInstance readReference readBitmap            readClass readUser readFloat readRectangle readShortInst) at: type.    anObject _ self perform: selector. "A method that recursively        calls next (readArray, readInstance, objectAt:) must save &        restore the current reference position."    isARefType ifTrue: [self beginReference: anObject].    "After reading the externalObject, internalize it.     #readReference is a special case. Either:       (1) We actually have to read the object, recursively calling           next, which internalizes the object.       (2) We just read a reference to an object already read and           thus already interalized.     Either way, we must not re-internalize the object here."    selector == #readReference ifFalse:        [anObject _ self internalize: anObject.        self checkForPaths: anObject].    ^ anObject! !!DataStream methodsFor: 'all' stamp: 'tk 5/8/97'!nextAndClose    "Speedy way to grab one object.  "    | obj |    obj _ self next.    self close.    ^ obj! !!DataStream methodsFor: 'all' stamp: 'jhm 11/15/92'!nextPut: anObject    "Write anObject to the receiver stream. Answer anObject.     NOTE: If anObject is a reference type (one that we write cross-references to) but its externalized form (result of objectToStoreOnDataStream) isn't (e.g. CompiledMethod and ViewState), then we should remember its externalized form but not add to 'references'. Putting that object again should just put its external form again. That's more compact and avoids seeks when reading. But we just do the simple thing here, allowing backward-references for non-reference types like nil. So objectAt: has to compensate. Objects that externalize nicely won't contain the likes of ViewStates, so this shouldn't hurt much.     : writeReference: -> errorWriteReference:."    | typeID selector objectToStore |    typeID _ self typeIDFor: anObject.    (self tryToPutReference: anObject typeID: typeID)        ifTrue: [^ anObject].    (objectToStore _ anObject objectToStoreOnDataStream) == anObject        ifFalse: [typeID _ self typeIDFor: objectToStore].    byteStream nextPut: typeID.    selector _ #(writeNil: writeTrue: writeFalse: writeInteger:         writeString: writeSymbol: writeByteArray:        writeArray: writeInstance: errorWriteReference: writeBitmap:        writeClass: writeUser: writeFloat: writeRectangle: == "dummy 16" ) at: typeID.    self perform: selector with: objectToStore.    ^ anObject! !!DataStream methodsFor: 'all' stamp: '     6/9/97'!objectAt: anInteger    "PRIVATE -- Read & return the object at a given stream position.  08:18 tk  anInteger is a relative file position. "    | savedPosn anObject refPosn |    savedPosn _ byteStream position.    "absolute"    refPosn _ self getCurrentReference.    "relative position"    byteStream position: anInteger + basePos.    "was relative"    anObject _ self next.    self setCurrentReference: refPosn.    "relative position"    byteStream position: savedPosn.        "absolute"    ^ anObject! !!DataStream methodsFor: 'all' stamp: '6/9/97 08:46 tk'!outputReference: referencePosn    "PRIVATE -- Output a reference to the object at integer stream position referencePosn (relative to basePos). To output a weak reference to an object not yet written, supply (self vacantRef) for referencePosn."    byteStream nextPut: 10. "reference typeID"    byteStream nextNumber: 4 put: referencePosn    "relative position"! !!DataStream methodsFor: 'all' stamp: '6/9/97 08:32 tk'!readArray    "PRIVATE -- Read the contents of an Array.     We must do beginReference: here after instantiating the Array     but before reading its contents, in case the contents reference     the Array. beginReference: will be sent again when we return to     next, but that's ok as long as we save and restore the current     reference position over recursive calls to next."    | count array refPosn |    count _ byteStream nextNumber: 4.    refPosn _ self beginReference: (array _ Array new: count).        "relative pos"    1 to: count do: [:i |        array at: i put: self next].    self setCurrentReference: refPosn.        "relative pos"    ^ array! !!DataStream methodsFor: 'all' stamp: 'tk 1/8/97'!readInstance    "PRIVATE -- Read the contents of an arbitrary instance.     ASSUMES: readDataFrom:size: sends me beginReference: after it       instantiates the new object but before reading nested objects.     NOTE: We must restore the current reference position after       recursive calls to next.    Let the instance, not the class read the data.  "    | instSize aSymbol refPosn anObject newClass |    instSize _ (byteStream nextNumber: 4) - 1.    refPosn _ self getCurrentReference.    aSymbol _ self next.    newClass _ Smalltalk at: aSymbol asSymbol.    anObject _ newClass isVariable     "Create object here"            ifFalse: [newClass basicNew]            ifTrue: [newClass basicNew: instSize - (newClass instSize)].    self setCurrentReference: refPosn.  "before readDataFrom:size:"    anObject _ anObject readDataFrom: self size: instSize.    self setCurrentReference: refPosn.  "before returning to next"    ^ anObject! !!DataStream methodsFor: 'all' stamp: ' 6/9/97'!readRectangle    "Read a compact Rectangle.  Rectangles with values outside +/- 2047 were stored as normal objects (type=9).  They will not come here.  17:22 tk"    "Encoding is four 12-bit signed numbers.  48 bits in next 6 bytes.  17:24 tk"    | acc left top right bottom |    acc _ byteStream nextNumber: 3.    left _ acc bitShift: -12.    (left bitAnd: 16r800) ~= 0 ifTrue: [left _ left - 16r1000].    "sign"    top _ acc bitAnd: 16rFFF.    (top bitAnd: 16r800) ~= 0 ifTrue: [top _ top - 16r1000].    "sign"    acc _ byteStream nextNumber: 3.    right _ acc bitShift: -12.    (right bitAnd: 16r800) ~= 0 ifTrue: [right _ right - 16r1000].    "sign"    bottom _ acc bitAnd: 16rFFF.    (bottom bitAnd: 16r800) ~= 0 ifTrue: [bottom _ bottom - 16r1000].    "sign"        ^ Rectangle left: left right: right top: top bottom: bottom! !!DataStream methodsFor: 'all' stamp: ' 6/9/97'!readReference    "PRIVATE -- Read the contents of an object reference. Cf. outputReference:.    11/15/92 jhm: Support weak references.    08:09 tk Data on file is relative to base position (where DataStream took over)."    | referencePosition |    ^ (referencePosition _ (byteStream nextNumber: 4)) = self vacantRef    "relative"        ifTrue:  [nil]        ifFalse: [self objectAt: referencePosition]        "relative pos"! !!DataStream methodsFor: 'all' stamp: 'tk 1/8/97'!readShortInst    "Read the contents of an arbitrary instance that has a short header.     ASSUMES: readDataFrom:size: sends me beginReference: after it       instantiates the new object but before reading nested objects.     NOTE: We must restore the current reference position after       recursive calls to next.    Let the instance, not the class read the data.  "    | instSize aSymbol refPosn anObject newClass |    instSize _ (byteStream next) - 1.    "one byte of size"    refPosn _ self getCurrentReference.    aSymbol _ self readShortRef.    "class symbol in two bytes of file pos"    newClass _ Smalltalk at: aSymbol asSymbol.    anObject _ newClass isVariable     "Create object here"            ifFalse: [newClass basicNew]            ifTrue: [newClass basicNew: instSize - (newClass instSize)].    self setCurrentReference: refPosn.  "before readDataFrom:size:"    anObject _ anObject readDataFrom: self size: instSize.    self setCurrentReference: refPosn.  "before returning to next"    ^ anObject! !!DataStream methodsFor: 'all' stamp: '6/10/97 17:03 tk'!readShortRef    "Read an object reference from two bytes only.  Original object must be in first 65536 bytes of the file."    | referencePosition |    ^ (referencePosition _ (byteStream nextNumber: 2)) = self vacantRef    "relative"        ifTrue:  [nil]        ifFalse: [self objectAt: referencePosition]        "relative pos"! !!DataStream methodsFor: 'all' stamp: 'tk 5/29/97'!rootObject    "Return the object at the root of the tree we are filing out.  "    ^ topCall! !!DataStream methodsFor: 'all' stamp: 'tk 5/29/97'!rootObject: anObject    "Return the object at the root of the tree we are filing out.  "    topCall _ anObject! !!DataStream methodsFor: 'all' stamp: '6/9/97 08:03 di'!setStream: aStream    "PRIVATE -- Initialization method."    aStream binary.    basePos _ aStream position.    "Remember where we start.  Earlier part of file contains a class or method file-in.  Allow that to be edited.  We don't deal in absolute file locations."    byteStream _ aStream.! !!DataStream methodsFor: 'all' stamp: 'tk 5/13/97'!typeIDFor: anObject    "Return the typeID for anObject's class.  This is where the tangle of objects is clipped to stop everything from going out.      Other classes can control their instance variables by defining objectToStoreOnDataStream.    Morphs exclude objects not in their tree.  "    | tt |    tt _ anObject ioType.    tt == #User ifTrue: [^ 13].    "HS Object whose class must be reconstructed"    (anObject isKindOf: View) ifTrue: [^ 1 "nil"].    "blocked"    (anObject isKindOf: Controller) ifTrue: [        Transcript cr; show: 'Refused to store a Controller'. ^         1 "nil"].    (anObject isKindOf: CompiledMethod) ifTrue: [        Transcript cr; show: 'Refused to store a CompiledMethod'.         ^ 1 "nil"].    (anObject isKindOf: BlockContext) ifTrue: [        Transcript cr; show: 'Refused to store a BlockContext'.         ^ 1 "nil"].    (anObject isMorph) ifTrue: [        (anObject couldBeOwnedBy: self rootObject)             ifTrue: [^ 9] "normal, might have nil owner"            ifFalse: [^ 1 "Only let out members of our subtree"]].        ^ TypeMap at: anObject class ifAbsent: [9 "instance of any normal class"]    "See DataStream initialize.  nil=1. true=2. false=3. a SmallInteger=4. a String=5. a Symbol=6.  a ByteArray=7. an Array=8. other = 9.  a Bitmap=11. a Metaclass=12. a Float=14.  a Rectangle=15. any instance that can have a short header=16."! !!DataStream methodsFor: 'all' stamp: 'jhm 11/15/92'!vacantRef    "Answer the magic 32-bit constant we use ***ON DISK*** as a stream 'reference     position' to identify a reference that's not yet filled in. This must be a     value that won't be used as an ordinary reference. Cf. outputReference: and     readReference. --      NOTE: We could use a different type ID for vacant-refs rather than writing        object-references with a magic value. (The type ID and value are        overwritten by ordinary object-references when weak refs are fullfilled.)"    ^ -1! !!DataStream methodsFor: 'all' stamp: 'tk 7/29/96'!writeClass: aClass    "PRIVATE -- For now, no classes may be written.  HyperSqueak user unique classes have not state other than methods and should be reconstructed.  Could put standard fileOut code here if necessary.  ."    "Just halt for now -- 9/20/96 di."    self error: 'Should not be trying to write a class'"    Obj classPool at: #ErrorHolder put: aClass.    Transcript cr; show: 'The class ', aClass printString,' is trying to be written out.  See Obj class variable ErrorHolder.'."! !!DataStream methodsFor: 'all' stamp: 'jm 7/31/97 16:16'!writeRectangle: anObject    "Write the contents of a Rectangle.  See if it can be a compact Rectangle (type=15).  Rectangles with values outside +/- 2047 were stored as normal objects (type=9).  17:22 tk"    | ok right bottom top left acc |    ok _ true.    (right _ anObject right) > 2047 ifTrue: [ok _ false].    right < -2048 ifTrue: [ok _ false].    (bottom _ anObject bottom) > 2047 ifTrue: [ok _ false].    bottom < -2048 ifTrue: [ok _ false].    (top _ anObject top) > 2047 ifTrue: [ok _ false].    top < -2048 ifTrue: [ok _ false].    (left _ anObject left) > 2047 ifTrue: [ok _ false].    left < -2048 ifTrue: [ok _ false].    ok _ ok & left isInteger & right isInteger & top isInteger & bottom isInteger.    ok ifFalse: [        byteStream skip: -1; nextPut: 9; skip: 0. "rewrite type to be normal instance"        ^ anObject storeDataOn: self].    acc _ ((left bitAnd: 16rFFF) bitShift: 12) + (top bitAnd: 16rFFF).    byteStream nextNumber: 3 put: acc.    acc _ ((right bitAnd: 16rFFF) bitShift: 12) + (bottom bitAnd: 16rFFF).    byteStream nextNumber: 3 put: acc.! !!DataStream class methodsFor: 'all'!fileNamed: aString    "Here is the way to use DataStream and ReferenceStream:rr _ ReferenceStream fileNamed: 'test.obj'.rr nextPut: <your object>.rr close."    | strm |    strm _ self on: (FileStream fileNamed: aString).        "will be binary"    strm byteStream setFileTypeToObject.        "Type and Creator not to be text, so can attach correctly to an email msg"    ^ strm! !!DataStream class methodsFor: 'all' stamp: '6/10/97 16:51 tk'!initialize    "TypeMap maps Smalltalk classes to type ID numbers which identify the data stream primitive formats.  nextPut: writes these IDs to the data stream.  NOTE: Changing these type ID numbers will invalidate all extant data stream files.  Adding new ones is OK.     See nextPut:, next, typeIDFor:, & ReferenceStream>>isAReferenceType:"    "DataStream initialize"    | refTypes t |    refTypes _ OrderedCollection new.    t _ TypeMap _ Dictionary new: 30. "sparse for fast hashing"    t at: UndefinedObject put: 1.   refTypes add: 0.    t at: True put: 2.   refTypes add: 0.    t at: False put: 3.   refTypes add: 0.    t at: SmallInteger put: 4.     refTypes add: 0.    t at: String put: 5.   refTypes add: 1.    t at: Symbol put: 6.   refTypes add: 1.    t at: ByteArray put: 7.   refTypes add: 1.        "Does anything use this?"    t at: Array put: 8.   refTypes add: 1.    "(type ID 9 is for arbitrary instances, cf. typeIDFor:)"        refTypes add: 1.    "(type ID 10 is for references, cf. ReferenceStream>>tryToPutReference:)"        refTypes add: 0.    t at: Bitmap put: 11.   refTypes add: 1.    t at: Metaclass put: 12.   refTypes add: 0.    "Type ID 13 is used for HyperSqueak User classes that must be reconstructed."        refTypes add: 1.    t at: Float put: 14.  refTypes add: 1.    t at: Rectangle put: 15.  refTypes add: 1.    "Allow compact Rects."    "type ID 16 is an instance with short header.  See beginInstance:size:"        refTypes add: 1.    "t at:  put: 17.  refTypes add: 0."    ReferenceStream refTypes: refTypes.    "save it"! !!DataStream class methodsFor: 'all'!newFileNamed: aString    "Here is the way to use DataStream and ReferenceStream:rr _ ReferenceStream fileNamed: 'test.obj'.rr nextPut: <your object>.rr close."    | strm |    strm _  self on: (FileStream newFileNamed: aString).        "will be binary"    strm byteStream setFileTypeToObject.        "Type and Creator not to be text, so can attach correctly to an email msg"    ^ strm! !!DataStream class methodsFor: 'all'!oldFileNamed: aString    "Here is the way to use DataStream and ReferenceStream:rr _ ReferenceStream oldFileNamed: 'test.obj'.^ rr nextAndClose."    | strm ff |    ff _ FileStream oldFileOrNoneNamed: aString.    ff ifNil: [^ nil].    strm _ self on: (ff binary).    ^ strm! !!DataStream class methodsFor: 'all' stamp: 'di 6/24/97 00:18'!on: aStream    "Open a new DataStream onto a low-level I/O stream."    ^ self basicNew setStream: aStream        "aStream binary is in setStream:"! !!Debugger methodsFor: 'initialize-release' stamp: 'sw 10/30/96'!expandStack    "This initialization occurs when the interrupted context is to modelled by     a DebuggerView, rather than a NotifierView (which can not display     more than five message-sends.    : expand the default number of frames from 7 to 15"    self newStack: (contextStackTop stackOfSize: 15).    contextStackIndex _ 0.    receiverInspector _ Inspector inspect: nil.    contextVariablesInspector _ ContextVariablesInspector inspect: nil.    proceedValue _ nil! !!Debugger methodsFor: 'accessing'!contents: aString notifying: aController     "The retrieved information has changed and its source must now be     updated. In this case, the retrieved information is the method of the     selected context."    | selector classOfMethod category method priorMethod parseNode |    contextStackIndex = 0 ifTrue: [^self].    (self selectedContext isKindOf: MethodContext)        ifFalse:            [(self confirm:'I will have to revert to the method fromwhich this block originated.  Is that OK?')                ifTrue: [self resetContext: self selectedContext home]                ifFalse: [^self]].    classOfMethod _ self selectedClass.    category _ self selectedMessageCategoryName.    Cursor execute showWhile:        [method _ classOfMethod        compile: aString        notifying: aController        trailer: #(0 0 0 0)        ifFail: [^ false]        elseSetSelectorAndNode:             [:sel :methodNode | selector _ sel.            selector == self selectedMessageName                ifFalse: [self notify: 'can''t change selector'. ^ false].            priorMethod _ (classOfMethod includesSelector: selector)                ifTrue: [classOfMethod compiledMethodAt: selector]                ifFalse: [nil].            sourceMap _ methodNode sourceMap.            tempNames _ methodNode tempNames.            parseNode _ methodNode].        method cacheTempNames: tempNames].    category isNil ifFalse: "Skip this for DoIts"        [method putSource: aString asString                fromParseNode: parseNode                class: classOfMethod                category: category                inFile: 2 priorMethod: priorMethod.        classOfMethod organization classify: selector under: category].    contents _ aString copy.    self selectedContext restartWith: method.    contextVariablesInspector object: nil.    self resetContext: self selectedContext.    ^true! !!Debugger methodsFor: 'code execution' stamp: 'sn 8/22/97 21:44'!send    "Send the selected message in the accessed method, and take control in     the method invoked to allow further step or send."    | currentContext |    Sensor leftShiftDown ifTrue: [self halt].    self okToChange ifFalse: [^ self].    self checkContextSelection.    externalInterrupt ifFalse: [contextStackTop push: proceedValue].    externalInterrupt _ true. "simulation leaves same state as interrupting"    currentContext _ self selectedContext.    currentContext stepToSendOrReturn.    self contextStackIndex > 1 | currentContext willReturn        ifTrue:             [self changed: #notChanged]        ifFalse:             [currentContext _ currentContext step.            currentContext stepToSendOrReturn.            self resetContext: currentContext]! !!Debugger methodsFor: 'code execution' stamp: 'sn 9/6/97 16:27'!step    "Send the selected message in the accessed method, and regain control     after the invoked method returns."        | currentContext oldMethod |    self okToChange ifFalse: [^ self].    self checkContextSelection.    externalInterrupt ifFalse: [contextStackTop push: proceedValue].    externalInterrupt _ true. "simulation leaves same state as interrupting"    currentContext _ self selectedContext.    self contextStackIndex > 1        ifTrue:             [currentContext completeCallee: contextStackTop.            self resetContext: currentContext]        ifFalse:             [currentContext stepToSendOrReturn.            currentContext willReturn                ifTrue:                     [oldMethod _ currentContext method.                    currentContext _ currentContext step.                    currentContext stepToSendOrReturn.                    self resetContext: currentContext.                    oldMethod == currentContext method "didnt used to update pc here"                        ifTrue: [self changed: #pc]]                ifFalse:                     [currentContext completeCallee: currentContext step.                    self changed: #pc.                    self updateInspectors]]! !!Debugger methodsFor: 'private'!resumeProcess: aScheduledController    aScheduledController view erase.    Smalltalk installLowSpaceWatcher.  "restart low space handler"    interruptedProcess suspendedContext method            == (Process compiledMethodAt: #terminate) ifFalse:        [contextStackIndex > 1            ifTrue: [interruptedProcess popTo: self selectedContext]            ifFalse: [interruptedProcess install: self selectedContext].        ScheduledControllers                        activeControllerNoTerminate: interruptedController                        andProcess: interruptedProcess].    "if old process was terminated, just terminate current one"    interruptedProcess _ nil.     aScheduledController closeAndUnscheduleNoErase.    Processor terminateActive! !!DebuggerStub methodsFor: 'initialization' stamp: 'di 6/17/97 09:15'!extent: newExtent    | inner |    super extent: newExtent.    inner _ self innerBounds.    shortStackPane bounds: (inner topLeft + (1@(self labelHeight+1)) corner: inner bottomRight - 1)! !!DebuggerStub methodsFor: 'initialization' stamp: 'di 6/17/97 09:12'!initPanes    self addMorph: (shortStackPane _ ScrollPane new model: self slotName: 'shortStackPane').! !!DebuggerStub methodsFor: 'initialization' stamp: 'di 6/17/97 09:22'!setStackText: textOrString    shortStackPane scroller removeAllMorphs; addMorph:        (TextMorph new contents: textOrString asText)! !!DebuggerStub class methodsFor: 'instance creation' stamp: 'di 6/22/97 09:14'!includeInNewMorphMenu    "Not to be instantiated from the menu"    ^ false! !!DebuggerStub class methodsFor: 'instance creation' stamp: 'di 6/18/97 05:34'!openContext: haltContext label: labelString contents: contentsString    | stub |    World addMorph: (stub _ (self labelled: labelString) setStackText: contentsString).    stub changed! !!DebuggerView class methodsFor: 'instance creation'!debugger: aDebugger     "Answer a DebuggerView whose model is aDebugger. It consists of three     subviews, a ContextStackView (the ContextStackListView and     ContextStackCodeView), an InspectView of aDebugger's variables, and an     InspectView of the variables of the currently selected method context."    | topView stackListView stackCodeView rcvrVarView rcvrValView ctxtVarView ctxtValView |    aDebugger expandStack.    topView _ self new model: aDebugger.    stackListView _ ContextStackListView new model: aDebugger.        stackListView window: (0 @ 0 extent: 150 @ 50).        stackListView borderWidthLeft: 2 right: 2 top: 2 bottom: 0.        topView addSubView: stackListView.    stackCodeView _ ContextStackCodeView new model: aDebugger.        stackCodeView controller: ContextStackCodeController new.        stackCodeView window: (0 @ 0 extent: 150 @ 75).        stackCodeView borderWidthLeft: 2 right: 2 top: 2 bottom: 0.        topView addSubView: stackCodeView below: stackListView.    rcvrVarView _ InspectListView new model: aDebugger receiverInspector.        rcvrVarView window: (0 @ 0 extent: 25 @ 50).        rcvrVarView borderWidthLeft: 2 right: 0 top: 2 bottom: 2.        topView addSubView: rcvrVarView below: stackCodeView.    rcvrValView _ InspectCodeView new model: aDebugger receiverInspector.        rcvrValView window: (0 @ 0 extent: 50 @ 50).        rcvrValView borderWidthLeft: 2 right: 0 top: 2 bottom: 2.        topView addSubView: rcvrValView toRightOf: rcvrVarView.    ctxtVarView _ InspectListView new model: aDebugger contextVariablesInspector.        ctxtVarView window: (0 @ 0 extent: 25 @ 50).        ctxtVarView borderWidthLeft: 2 right: 0 top: 2 bottom: 2.        topView addSubView: ctxtVarView toRightOf: rcvrValView.    ctxtValView _ InspectCodeView new model: aDebugger contextVariablesInspector.        ctxtValView window: (0 @ 0 extent: 50 @ 50).        ctxtValView borderWidthLeft: 2 right: 2 top: 2 bottom: 2.        topView addSubView: ctxtValView toRightOf: ctxtVarView.    ^ topView! !!DebuggerView class methodsFor: 'instance creation'!lowSpaceChoices    "Return a notifier message string to be presented when space is running low."    ^ 'Warning!! Squeak is almost out of memory!!Low space detection is now disabled. It will be restored when you close or proceed from this error notifier. Don''t panic, but do proceed with caution.Here are some suggestions:Ñ If you suspect an infinite recursion (the same methods calling each other again and again), then close this debugger, and fix the problem.Ñ If you want this computation to finish, then make more space available (read on) and choose "proceed" in this debugger. Here are some ways to make more space available...   > Close any windows that are not needed.   > Get rid of some large objects (e.g., images).   > Leave this window on the screen, choose "save as..." from the screen menu, quit, restart the Squeak VM with a larger memory allocation, then restart the image you just saved, and choose "proceed" in this window.Ñ If you want to investigate further, choose "debug" in this window.  Do not use the debugger "fullStack" command unless you are certain that the stack is not very deep (as it will be if the problem is an infinite recursion).'! !!DebuggerView class methodsFor: 'instance creation' stamp: 'di 6/24/97 11:48'!openContext: haltContext label: aString contents: contentsString    "Create and schedule a simple view on a Debugger on haltContext.    The view is labeled with aString and shows a short sender stack."    ErrorRecursion        ifTrue:             [ErrorRecursion _ false.            self primitiveError: aString].    ErrorRecursion _ true.    World ifNotNil:            ["Put up a Morphic debugger in Morphic worlds"            "Written so that Morphic can still be removed."            (Smalltalk at: #DebuggerStub) openContext: haltContext                label: aString                contents: contentsString.            ErrorRecursion _ false.            Project current spawnNewProcess.            ^ Processor activeProcess suspend].    self openNotifier: (Debugger context: haltContext)        contents: contentsString        label: aString.    ErrorRecursion _ false.    Processor activeProcess suspend! !!DebuggerView class methodsFor: 'instance creation'!openNotifier: aDebugger contents: msgString label: label    "Create and schedule a simple view with a debugger which can be opened later."    | msg aStringHolderView topView nLines displayPoint |    Cursor normal show.    Sensor flushKeyboard.    msg _ msgString.    (label beginsWith: 'Space is low')        ifTrue: [msg _ self lowSpaceChoices, msg].    aStringHolderView _        StringHolderView container: (StringHolder new contents: msg).    aStringHolderView controller: (NotifyStringHolderController debugger: aDebugger).    topView _ StandardSystemView new.    topView model: aStringHolderView model.    topView addSubView: aStringHolderView.    topView label: label.    nLines _ 1 + (msg occurrencesOf: Character cr).    topView minimumSize: 350 @ (14 * nLines + 6).    displayPoint _        ScheduledControllers activeController == nil            ifTrue: [Display boundingBox center]            ifFalse: [ScheduledControllers activeController view displayBox center].    topView controller openNoTerminateDisplayAt: displayPoint.    ^ topView! !!Decompiler methodsFor: 'initialize-release'!initSymbols: aClass    | nTemps namedTemps |    constructor method: method class: aClass literals: method literals.    constTable _ constructor codeConstants.    instVars _ Array new: aClass instSize.    nTemps _ method numTemps.    namedTemps _ tempVars == nil ifTrue: [Array new] ifFalse: [tempVars].    tempVars _ (1 to: nTemps) collect:                [:i | i <= namedTemps size                    ifTrue: [constructor codeTemp: i - 1 named: (namedTemps at: i)]                    ifFalse: [constructor codeTemp: i - 1]]! !!Decompiler methodsFor: 'initialize-release'!withTempNames: tempNameArray    tempVars _ tempNameArray! !!Decompiler methodsFor: 'control' stamp: 'tao 8/20/97 22:51'!blockForCaseTo: end    "Decompile a range of code as in statementsForCaseTo:, but return a block node."    | exprs block oldBase |    oldBase _ blockStackBase.    blockStackBase _ stack size.    exprs _ self statementsForCaseTo: end.    block _ constructor codeBlock: exprs returns: lastReturnPc = lastPc.    blockStackBase _ oldBase.    lastReturnPc _ -1.  "So as not to mislead outer calls"    ^block! !!Decompiler methodsFor: 'control'!checkForBlock: receiver    "We just saw a blockCopy: message. Check for a following block."    | savePc jump args argPos block |    receiver == constructor codeThisContext ifFalse: [^false].    savePc _ pc.    (jump _ self interpretJump) notNil        ifFalse:            [pc _ savePc.  ^nil].    "Definitely a block"    jump _ jump + pc.    argPos _ statements size.    [self willStorePop]        whileTrue:            [stack addLast: ArgumentFlag.  "Flag for doStore:"            self interpretNextInstructionFor: self].    args _ Array new: statements size - argPos.    1 to: args size do:  "Retrieve args"        [:i | args at: i put: statements removeLast.        (args at: i) scope: -1  "flag args as block temps"].    block _ self blockTo: jump.    stack addLast: (constructor codeArguments: args block: block).    ^true! !!Decompiler methodsFor: 'control' stamp: 'tao 8/20/97 22:51'!statementsForCaseTo: end    "Decompile the method from pc up to end and return an array of    expressions. If at run time this block will leave a value on the stack,    set hasValue to true. If the block ends with a jump or return, set exit    to the destination of the jump, or the end of the method; otherwise, set    exit = end. Leave pc = end.    Note that stack initially contains a CaseFlag which will be removed by    a subsequent Pop instruction, so adjust the StackPos accordingly."    | blockPos stackPos t |    blockPos _ statements size.    stackPos _ stack size - 1. "Adjust for CaseFlag"    [pc < end]        whileTrue:            [lastPc _ pc.  limit _ end.  "for performs"            self interpretNextInstructionFor: self].    "If there is an additional item on the stack, it will be the value    of this block."    (hasValue _ stack size > stackPos)        ifTrue:            [statements addLast: stack removeLast].    lastJumpPc = lastPc ifFalse: [exit _ pc].    ^self popTo: blockPos! !!Decompiler methodsFor: 'instruction decoding' stamp: 'tao 8/20/97 22:49'!case: dist    "statements = keyStmts CascadeFlag keyValueBlock ... keyStmts"    | nextCase end thenJump stmtStream elements b node cases otherBlock |    nextCase _ pc + dist.    end _ limit.    "Now add CascadeFlag & keyValueBlock to statements"    statements addLast: stack removeLast.    stack addLast: CaseFlag. "set for next pop"    statements addLast: (self blockForCaseTo: nextCase).    stack last == CaseFlag        ifTrue: "Last case"            ["ensure jump is within block (in case thenExpr returns wierdly I guess)"            stack removeLast. "get rid of CaseFlag".            thenJump _ exit <= end ifTrue: [exit] ifFalse: [nextCase].            stmtStream _ ReadStream on: (self popTo: stack removeLast).            elements _ OrderedCollection new.            b _ OrderedCollection new.            [stmtStream atEnd] whileFalse:                [(node _ stmtStream next) == CascadeFlag                    ifTrue:                        [elements addLast: (constructor                            codeMessage: (constructor codeBlock: b returns: false)                            selector: (constructor codeSelector: #-> code: #macro)                            arguments: (Array with: stmtStream next)).                         b _ OrderedCollection new]                    ifFalse: [b addLast: node]].            b size > 0 ifTrue: [self error: 'Bad cases'].            cases _ constructor codeBrace: elements.            otherBlock _ self blockTo: thenJump.            stack addLast:                (constructor                    codeMessage: stack removeLast                    selector: (constructor codeSelector: #caseOf:otherwise: code: #macro)                    arguments: (Array with: cases with: otherBlock))]! !!Decompiler methodsFor: 'instruction decoding' stamp: 'tao 8/20/97 22:54'!doPop    stack last == CaseFlag        ifTrue: [stack removeLast]        ifFalse: [statements addLast: stack removeLast].! !!Decompiler methodsFor: 'instruction decoding'!jump: dist if: condition    | savePc elseDist sign elsePc elseStart end cond ifExpr thenBlock elseBlock thenJump        elseJump condHasValue b |    stack last == CascadeFlag ifTrue: [^self case: dist].    elsePc _ lastPc.    elseStart _ pc + dist.    end _ limit.    "Check for bfp-jmp to invert condition.    Don't be fooled by a loop with a null body."    sign _ condition.    savePc _ pc.    ((elseDist _ self interpretJump) notNil and: [elseDist >= 0 and: [elseStart = pc]])        ifTrue: [sign _ sign not.  elseStart _ pc + elseDist]        ifFalse: [pc _ savePc].    ifExpr _ stack removeLast.    thenBlock _ self blockTo: elseStart.    condHasValue _ hasValue.    "ensure jump is within block (in case thenExpr returns)"    thenJump _ exit <= end ifTrue: [exit] ifFalse: [elseStart].    "if jump goes back, then it's a loop"    thenJump < elseStart        ifTrue:            ["thenJump will jump to the beginning of the while expr.  In the case of            while's with a block in the condition, the while expr            should include more than just the last expression: find all the            statements needed by re-decompiling."            pc _ thenJump.            b _ self statementsTo: elsePc.            "discard unwanted statements from block"            b size - 1 timesRepeat: [statements removeLast].            statements addLast: (constructor                    codeMessage: (constructor codeBlock: b returns: false)                    selector: (constructor codeSelector: (sign ifTrue: [#whileFalse:] ifFalse: [#whileTrue:]) code: #macro)                    arguments: (Array with: thenBlock)).            pc _ elseStart.            self convertToDoLoop]        ifFalse:            [elseBlock _ self blockTo: thenJump.            elseJump _ exit.            "if elseJump is backwards, it is not part of the elseExpr"            elseJump < elsePc                ifTrue: [pc _ lastPc].            cond _ constructor                        codeMessage: ifExpr                        selector: (constructor codeSelector: #ifTrue:ifFalse: code: #macro)                        arguments:                            (sign                                ifTrue: [Array with: elseBlock with: thenBlock]                                ifFalse: [Array with: thenBlock with: elseBlock]).            condHasValue                ifTrue: [stack addLast: cond]                ifFalse: [statements addLast: cond]]! !!Decompiler methodsFor: 'private'!convertToDoLoop    "If statements contains the pattern        var _ startConst.        [var <= limit] whileTrue: [...statements... var _ var + incConst]    then replace this by        startConst to: limit by: incConst do: [:var | ...statements...]"    | initStmt toDoStmt limitStmt |    statements size < 2 ifTrue: [^ self].    initStmt _ statements at: statements size-1.    (toDoStmt _ statements last toDoFromWhileWithInit: initStmt)        == nil ifTrue: [^ self].    statements removeLast; removeLast; addLast: toDoStmt.    initStmt variable scope: -1.  "Flag arg as block temp"    statements size < 2 ifTrue: [^ self].    limitStmt _ statements at: statements size-1.    (toDoStmt _ statements last toDoWithLimit: limitStmt)        == nil ifTrue: [^ self].    statements removeLast; removeLast; addLast: toDoStmt.    limitStmt variable scope: -2.  "Flag limit var as block temp"! !!Decompiler methodsFor: 'private'!decompile: aSelector in: aClass method: aMethod using: aConstructor    | block |    constructor _ aConstructor.    method _ aMethod.    self initSymbols: aClass.  "create symbol tables"    method isQuick        ifTrue: [block _ self quickMethod]        ifFalse:             [stack _ OrderedCollection new: method frameSize.            statements _ OrderedCollection new: 20.            super method: method pc: method initialPC.            block _ self blockTo: method endPC + 1.            stack isEmpty ifFalse: [self error: 'stack not empty']].    ^constructor        codeMethod: aSelector        block: block        tempVars: (tempVars select: [:t | t scope >=0])        primitive: method primitive        class: aClass! !!Decompiler class methodsFor: 'class initialization' stamp: 'tao 8/20/97 20:50'!initialize    CascadeFlag _ 'cascade'.  "A unique object"    CaseFlag _ 'case'. "Ditto"    ArgumentFlag _ 'argument'.  "Ditto"    "Decompiler initialize"! !!DecompilerConstructor methodsFor: 'constructor'!codeConstants    "Answer with an array of the objects representing self, true, false, nil,    -1, 0, 1, 2."    ^(Array with: NodeSelf with: NodeTrue with: NodeFalse with: NodeNil)        , ((-1 to: 2) collect: [:i | LiteralNode new key: i code: LdMinus1 + i + 1])! !!DecompilerConstructor methodsFor: 'constructor'!codeTemp: index    ^ TempVariableNode new        name: 't' , (index + 1) printString        index: index        type: LdTempType        scope: 0! !!DecompilerConstructor methodsFor: 'constructor'!codeTemp: index named: tempName    ^ TempVariableNode new        name: tempName        index: index        type: LdTempType        scope: 0! !!Delay methodsFor: 'delaying' stamp: 'jm 9/12/97 11:11'!unschedule    "Unschedule this Delay. Do nothing if it wasn't scheduled."    | done |    AccessProtect critical: [        done _ false.        [done] whileFalse:            [SuspendedDelays remove: self ifAbsent: [done _ true]].        ActiveDelay == self ifTrue: [            SuspendedDelays isEmpty                ifTrue: [                    ActiveDelay _ nil.                    ActiveDelayStartTime _ nil]                ifFalse: [                    SuspendedDelays removeFirst activate]]].! !!Delay methodsFor: 'delaying' stamp: 'jm 9/12/97 09:10'!wait    "Schedule this Delay, then wait on its semaphore. The current process will be suspended for the amount of time specified when this Delay was created."    self schedule.    delaySemaphore wait.! !!Delay methodsFor: 'private' stamp: 'jm 9/11/97 13:31'!activate    "Private!! Make the receiver the Delay to be awoken when the next timer interrupt occurs. This method should only be called from a block protected by the AccessProtect semaphore."    ActiveDelay _ self.    ActiveDelayStartTime _ Time millisecondClockValue.    TimingSemaphore initSignals.    Delay primSignal: TimingSemaphore atMilliseconds: resumptionTime.! !!Delay methodsFor: 'private' stamp: 'jm 9/11/97 14:49'!adjustResumptionTimeOldBase: oldBaseTime newBase: newBaseTime    "Private!! Adjust the value of the system's millisecond clock at which this Delay will be awoken. Used to adjust resumption times after a snapshot or clock roll-over."    resumptionTime _ newBaseTime + (resumptionTime - oldBaseTime).! !!Delay methodsFor: 'private' stamp: 'jm 9/11/97 11:54'!resumptionTime    "Answer the value of the system's millisecondClock at which the receiver's suspended Process will resume."    ^ resumptionTime! !!Delay methodsFor: 'private' stamp: 'jm 9/12/97 11:10'!schedule    "Private!! Schedule this Delay, but return immediately rather than waiting. The receiver's semaphore will be signalled when its delay duration has elapsed."    beingWaitedOn ifTrue: [self error: 'This Delay has already been scheduled.'].    AccessProtect critical: [        beingWaitedOn _ true.        resumptionTime _ Time millisecondClockValue + delayDuration.        ActiveDelay == nil            ifTrue: [self activate]            ifFalse: [                resumptionTime < ActiveDelay resumptionTime                    ifTrue: [                        SuspendedDelays add: ActiveDelay.                        self activate]                    ifFalse: [SuspendedDelays add: self]]].! !!Delay methodsFor: 'private' stamp: 'jm 9/12/97 08:56'!setDelay: millisecondCount forSemaphore: aSemaphore    "Private!! Initialize this delay to signal the given semaphore after the given number of milliseconds."    delayDuration _ millisecondCount.    delaySemaphore _ aSemaphore.    beingWaitedOn _ false.! !!Delay methodsFor: 'private' stamp: 'jm 9/11/97 11:54'!signalWaitingProcess    "The delay time has elapsed; signal the waiting process."    beingWaitedOn _ false.    delaySemaphore signal.! !!Delay class methodsFor: 'instance creation' stamp: 'jm 9/15/97 17:09'!forMilliseconds: anInteger    "Return a new Delay for the given number of milliseconds. Sending 'wait' to this Delay will cause the sender's process to be suspended for approximately that length of time."    anInteger < 0 ifTrue: [self error: 'delay times cannot be negative'].    ^ self new        setDelay: anInteger        forSemaphore: Semaphore new! !!Delay class methodsFor: 'instance creation' stamp: 'jm 9/15/97 17:09'!forSeconds: anInteger    "Return a new Delay for the given number of seconds. Sending 'wait' to this Delay will cause the sender's process to be suspended for approximately that length of time."    anInteger < 0 ifTrue: [self error: 'delay times cannot be negative'].    ^ self new        setDelay: anInteger * 1000        forSemaphore: Semaphore new! !!Delay class methodsFor: 'instance creation' stamp: 'jm 9/12/97 11:06'!howToUse    "An instance of Delay responds to the message 'wait' by suspending the caller's process for a certain amount of time. The duration of the pause is specified when the Delay is created with the message forMilliseconds: or forSeconds:. A Delay can be used again when the current wait has finished. For example, a clock process might repeatedly wait on a one-second Delay.    The maximum delay is (SmallInteger maxVal // 2) milliseconds, or about six days. A delay in progress when an image snapshot is saved is resumed when the snapshot is re-started. Delays work across millisecond clock roll-overs."! !!Delay class methodsFor: 'instance creation' stamp: 'jm 9/15/97 17:10'!timeoutSemaphore: aSemaphore afterMSecs: anInteger    "Create and schedule a Delay to signal the given semaphore when the given number of milliseconds has elapsed. Return the scheduled Delay. The timeout can be cancelled by sending 'unschedule' to this Delay."    "Details: This mechanism is used to provide a timeout when waiting for an external event, such as arrival of data over a network connection, to signal a semaphore. The timeout ensures that the semaphore will be signalled within a reasonable period of time even if the event fails to occur. Typically, the waiting process cancels the timeout request when awoken, then determines if the awaited event has actually occurred."    anInteger < 0 ifTrue: [self error: 'delay times cannot be negative'].    ^ (self new setDelay: anInteger forSemaphore: aSemaphore) schedule! !!Delay class methodsFor: 'snapshotting' stamp: 'jm 9/11/97 14:59'!restoreResumptionTimes    "Private!! Restore the resumption times of all scheduled Delays after a snapshot or clock roll-over. This method should be called only while the AccessProtect semaphore is held."    | newBaseTime |    newBaseTime _ Time millisecondClockValue.    SuspendedDelays do: [:d | d adjustResumptionTimeOldBase: 0 newBase: newBaseTime].    ActiveDelay == nil ifFalse: [        ActiveDelay adjustResumptionTimeOldBase: 0 newBase: newBaseTime.        ActiveDelay activate].! !!Delay class methodsFor: 'snapshotting' stamp: 'jm 9/11/97 15:15'!saveResumptionTimes    "Private!! Record the resumption times of all Delays relative to a base time of zero. This is done prior to snapshotting or adjusting the resumption times after a clock roll-over. This method should be called only while the AccessProtect semaphore is held."    | oldBaseTime |    oldBaseTime _ Time millisecondClockValue.    ActiveDelay == nil        ifFalse: [            oldBaseTime < ActiveDelayStartTime                ifTrue: [oldBaseTime _ ActiveDelayStartTime].  "clock rolled over"            ActiveDelay adjustResumptionTimeOldBase: oldBaseTime newBase: 0].    SuspendedDelays do:        [:d | d adjustResumptionTimeOldBase: oldBaseTime newBase: 0].! !!Delay class methodsFor: 'snapshotting' stamp: 'jm 9/11/97 15:00'!shutDown    "Suspend the active delay, if any, before snapshotting. It will be reactived when the snapshot is resumed."    "Details: This prevents a timer interrupt from waking up the active delay in the midst snapshoting, since the active delay will be restarted when resuming the snapshot and we don't want to process the delay twice."    AccessProtect wait.    self primSignal: nil atMilliseconds: 0.    self saveResumptionTimes.! !!Delay class methodsFor: 'snapshotting' stamp: 'jm 9/11/97 15:01'!startUp    "Restart active delay, if any, when resuming a snapshot."    self restoreResumptionTimes.    ActiveDelay == nil ifFalse: [ActiveDelay activate].    AccessProtect signal.! !!Delay class methodsFor: 'timer process' stamp: 'jm 9/11/97 15:15'!startTimerInterruptWatcher    "Reset the class variables that keep track of active Delays and re-start the timer interrupt watcher process. Any currently scheduled delays are forgotten."    "Delay startTimerInterruptWatcher"    | p |    self primSignal: nil atMilliseconds: 0.    TimingSemaphore == nil        ifFalse: [TimingSemaphore terminateProcess].    TimingSemaphore _ Semaphore new.    AccessProtect _ Semaphore forMutualExclusion.    SuspendedDelays _         SortedCollection sortBlock:             [:d1 :d2 | d1 resumptionTime <= d2 resumptionTime].    ActiveDelay _ nil.    p _ [self timerInterruptWatcher] newProcess.    p priority: Processor timingPriority.    p resume.! !!Delay class methodsFor: 'timer process' stamp: 'jm 9/11/97 15:13'!timerInterruptWatcher    "This loop runs in its own process. It waits for a timer interrupt and wakes up the active delay. Note that timer interrupts are only enabled when there are active delays."    [true] whileTrue: [        TimingSemaphore wait.        AccessProtect critical: [            ActiveDelay == nil ifFalse: [                ActiveDelay signalWaitingProcess.                Time millisecondClockValue < ActiveDelayStartTime                    ifTrue: [  "clock wrapped"                        self saveResumptionTimes.                        self restoreResumptionTimes]].            SuspendedDelays isEmpty                ifTrue: [                    ActiveDelay _ nil.                    ActiveDelayStartTime _ nil]                ifFalse: [                    SuspendedDelays removeFirst activate]]].! !!Delay class methodsFor: 'example' stamp: 'jm 9/11/97 11:23'!testDelayOf: delay for: testCount rect: r    "Delay testDelayOf: 100 for: 20 rect: (10@10 extent: 30@30).     Delay testDelayOf: 400 for: 20 rect: (50@10 extent: 30@30)."    | onDelay offDelay |    onDelay _ Delay forMilliseconds: 50.    offDelay _ Delay forMilliseconds: delay - 50.    Display fillBlack: r.    [1 to: testCount do: [:i |        Display fillWhite: r.        onDelay wait.        Display reverse: r.        offDelay wait].    ] forkAt: Processor userInterruptPriority.! !!Delay class methodsFor: 'primitives' stamp: 'jm 9/11/97 10:54'!primSignal: aSemaphore atMilliseconds: aSmallInteger    "Signal the semaphore when the millisecond clock reaches the value of the second argument. Fail if the first argument is neither a Semaphore nor nil. Essential. See Object documentation whatIsAPrimitive."    <primitive: 136>    self primitiveFailed! !!Dictionary methodsFor: 'accessing' stamp: 'tk 2/18/97'!keyAtValue: value ifAbsent: exceptionBlock    "Answer the key that is the external name for the argument, value. If     there is none, answer the result of evaluating exceptionBlock.    : Use =, not ==, so stings like 'this' can be found.  Note that MethodDictionary continues to use == so it will be fast."     self associationsDo:         [:association | value = association value ifTrue: [^association key]].    ^exceptionBlock value! !!Dictionary methodsFor: 'accessing'!keys    "Answer a Set containing the receiver's keys."    | aSet |    aSet _ Set new: self size.    self keysDo: [:key | aSet add: key].    ^ aSet! !!Dictionary methodsFor: 'removing'!removeUnreferencedKeys   "Undeclared removeUnreferencedKeys"    ^ self unreferencedKeys do: [:key | self removeKey: key].! !!Dictionary methodsFor: 'removing'!unreferencedKeys        "TextConstants unreferencedKeys"    | n |    ^ 'Scanning for references . . .'        displayProgressAt: Sensor cursorPoint        from: 0 to: self size        during:        [:bar | n _ 0.        self keys select:            [:key | bar value: (n _ n+1).            (Smalltalk allCallsOn: (self associationAt: key)) isEmpty]]! !!Dictionary methodsFor: 'printing' stamp: 'di 6/20/97 09:10'!printOn: aStream    aStream nextPutAll: self class name, ' ('.    self associationsDo: [:element | element printOn: aStream. aStream space].    aStream nextPut: $)! !!Dictionary methodsFor: 'private'!scanFor: anObject    "Scan the key array for the first slot containing either a nil (indicating an empty slot) or an element that matches anObject. Answer the index of that slot or zero if no slot is found. This method will be overridden in various subclasses that have different interpretations for matching elements."    | element start finish |    start _ (anObject hash \\ array size) + 1.    finish _ array size.    "Search from (hash mod size) to the end."    start to: finish do:        [:index | ((element _ array at: index) == nil or: [element key = anObject])            ifTrue: [^ index ]].    "Search from 1 to where we started."    1 to: start-1 do:        [:index | ((element _ array at: index) == nil or: [element key = anObject])            ifTrue: [^ index ]].    ^ 0  "No match AND no empty slot"! !!Dictionary methodsFor: 'user interface'!inspect    "Open a DictionaryInspector on the receiver.  N.B.: this is    an inspector without trash, since InspectorTrash doesn't do the    obvious thing right now.  Use basicInspect to get a normal    (less useful) type of inspector."    DictionaryInspector openOn: self withEvalPane: false! !!Dictionary methodsFor: 'user interface' stamp: 'sw 6/28/96'!inspectFormsWithLabel: aLabel    "Open a Form Dictionary inspector on the receiver, with the given label.  "    ^ DictionaryInspector openOn: self withEvalPane: false        withLabel: aLabel        valueViewClass: FormInspectView! !!Dictionary methodsFor: 'user interface'!inspectWithLabel: aLabel    "Open a DictionaryInspector on the receiver.  N.B.: this is    an inspector without trash, since InspectorTrash doesn't do the    obvious thing right now.  Use basicInspect to get a normal    (less useful) type of inspector."    DictionaryInspector openOn: self withEvalPane: false withLabel: aLabel! !!DictionaryListController class methodsFor: 'class initialization'!initialize    DictionaryListYellowButtonMenu _        PopUpMenu labels:'inspectreferencesobjects pointing to this valueadd keyremove'        lines: #( 3 ).    DictionaryListYellowButtonMessages _        #(inspectSelection selectionReferences objectReferencesToSelection addEntry removeSelection )    "DictionaryListController initialize"! !DiskProxy comment:'A DiskProxy is an externalized form of an object to write on aDataStream. It contains a "constructor" message to regeneratethe object, in context, when sent a comeFullyUpOnReload message(i.e. "internalize").We are now using DiskProxy for shared system objects like StrikeFonts.The idea is to define, for each kind of object that needs specialexternalization, a class method that will internalize the object byreconstructing it from its defining state. We call this a"constructor" method. Then externalize such an object as a frozenmessage that invokes this method--a DiskProxy.(Here is the old comment:Constructing a new object is good for any object that (1) can not beexternalized simply by snapshotting and reloading its instancevariables (like a CompiledMethod or a Picture), or (2) wants to befree to evolve its internal representation without making storedinstances obsolete (and dangerous). Snapshotting and reloading anobject"s instance variables is a dangerous breach of encapsulation.The internal structure of the class is then free to evolve. Allexternalized instances will be useful as long as theconstructor methods are maintained with the same semantics.There may be several constructor methods for a particular class. Thisis useful for (1) instances with characteristically differentdefining state, and (2) newer, evolved forms of an object and itsconstructors, with the old constructor methods kept around so olddata can still be properly loaded.)Create one like this example from class Picture    DiskProxy global: #Picture            selector: #fromByteArray:                args: (Array with: self storage asByteArray)* See also subclass DiskProxyQ that will construct an object inthe above manner and then send it a sequence of messages. This may savecreating a wide variety of constructor methods. It is also useful becausethe newly read-in DiskProxyQ can catch messages like #objectContainedIn:(via #doesNotUnderstand:) and add them to the queue of messages tosend to the new object.* We may also want a subclass of DiskProxy that evaluates a stringexpression to compute the receiver of the constructor message.My instance variables:* globalObjectName -- the Symbol name of a global object in the    System dictionary (usually a class).* constructorSelector -- the constructor message selector Symbol to    send to the global object (perform:withArguments:), typically a    variation on newFrom:.* constructorArgs -- the Array of arguments to pass in the    constructor message.-- 11/9/92 Jerry Morrison'!!DiskProxy methodsFor: 'all'!comeFullyUpOnReload    "Internalize myself into a fully alive object after raw loading    from a DataStream. (See my class comment.)    The sender (the DataStream facility) will substitute the answer for myself."    | globalObj |    globalObj _ Smalltalk at: globalObjectName        ifAbsent: [^ self halt: 'can''t internalize'].    Symbol hasInterned: constructorSelector ifTrue: [:selector |        ^ globalObj perform: selector                withArguments: constructorArgs].    ^ nil     "was not in proper form"! !!DiskProxy methodsFor: 'all'!global: globalNameSymbol selector: selectorSymbol args: argArray    "Initialize self as a DiskProxy constructor with the given    globalNameSymbol, selectorSymbol, and argument Array.    I will internalize by looking up the global object name in the    SystemDictionary (Smalltalk) and sending it this message with    these arguments."    globalObjectName _ globalNameSymbol asSymbol.    constructorSelector _ selectorSymbol asSymbol.    constructorArgs _ argArray.! !!DisplayMedium methodsFor: 'coloring'!fillBlack    "Set all bits in the receiver to black (ones)."    self fill: self boundingBox fillColor: Color black! !!DisplayMedium methodsFor: 'coloring'!fillBlack: aRectangle     "Set all bits in the receiver's area defined by aRectangle to black (ones)."    self fill: aRectangle rule: Form over fillColor: Color black! !!DisplayMedium methodsFor: 'coloring'!fillWhite    "Set all bits in the form to white."    self fill: self boundingBox fillColor: Color white.! !!DisplayMedium methodsFor: 'coloring'!fillWhite: aRectangle    "Set all bits in the receiver's area defined by aRectangle to white."    self fill: aRectangle rule: Form over fillColor: Color white.! !!DisplayMedium methodsFor: 'coloring'!fillWithColor: aColor    "Fill the receiver's bounding box with the given color."    self fill: self boundingBox fillColor: aColor.! !!DisplayMedium methodsFor: 'bordering'!border: aRectangle width: borderWidth     "Paint a border whose rectangular area is defined by aRectangle. The     width of the border of each side is borderWidth. Uses black for     drawing the border."    self border: aRectangle width: borderWidth fillColor: Color black.! !!DisplayObject methodsFor: 'display box access'!initialExtent    "Included here for when a FormView is being opened    as a window.  (4@4) covers border widths."    ^ self extent + (4@4) ! !!DisplayScanner methodsFor: 'scanning'!displayLines: linesInterval in: aParagraph clippedBy: visibleRectangle    "The central display routine. The call on the primitive     (scanCharactersFrom:to:in:rightX:) will be interrupted according to an     array of stop conditions passed to the scanner at which time the code to     handle the stop condition is run and the call on the primitive continued     until a stop condition returns true (which means the line has     terminated)."    | runLength done stopCondition leftInRun |    "leftInRun is the # of characters left to scan in the current run; when 0,        it is time to call 'self setStopConditions'"    leftInRun _ 0.    super initializeFromParagraph: aParagraph clippedBy: visibleRectangle.    paragraph _ aParagraph.    fillBlt _ self copy.  "Blt to fill spaces, tabs, margins"    fillBlt sourceForm: nil; sourceOrigin: 0@0; fillColor: aParagraph backgroundColor.    rightMargin _ aParagraph rightMarginForDisplay.    lineY _ aParagraph topAtLineIndex: linesInterval first.    linesInterval do:         [:lineIndex |         leftMargin _ aParagraph leftMarginForDisplayForLine: lineIndex.        runX _ destX _ leftMargin.        line _ aParagraph lines at: lineIndex.        lineHeight _ line lineHeight.        fillBlt destX: visibleRectangle left destY: lineY            width: leftMargin - visibleRectangle left height: lineHeight; copyBits.        lastIndex _ line first.        leftInRun <= 0            ifTrue: [self setStopConditions.  "also sets the font"                    leftInRun _ text runLengthFor: line first].        destY _ lineY + line baseline - font ascent.  "Should have happened in setFont"        runLength _ leftInRun.        (runStopIndex _ lastIndex + (runLength - 1)) > line last             ifTrue: [runStopIndex _ line last].        leftInRun _ leftInRun - (runStopIndex - lastIndex + 1).        spaceCount _ 0.        done _ false.        [done]            whileFalse:                 [stopCondition _ self scanCharactersFrom: lastIndex                        to: runStopIndex                        in: text string                        rightX: rightMargin                        stopConditions: stopConditions                        displaying: true.                "see setStopConditions for stopping conditions for displaying."                done _ self perform: stopCondition].        fillBlt destX: destX destY: lineY width: visibleRectangle right-destX height: lineHeight; copyBits.        lineY _ lineY + lineHeight]! !!DisplayScanner methodsFor: 'stop conditions'!crossedX    "This condition will sometimes be reached 'legally' during display, when,     for instance the space that caused the line to wrap actually extends over     the right boundary. This character is allowed to display, even though it     is technically outside or straddling the clipping ectangle since it is in     the normal case not visible and is in any case appropriately clipped by     the scanner."    self fillLeading.    ^ true ! !!DisplayScanner methodsFor: 'stop conditions'!endOfRun    "The end of a run in the display case either means that there is actually     a change in the style (run code) to be associated with the string or the     end of this line has been reached."    | runLength |    self fillLeading.  "Fill any leading above or below the font"    lastIndex = line last ifTrue: [^true].    runX _ destX.    runLength _ text runLengthFor: (lastIndex _ lastIndex + 1).    (runStopIndex _ lastIndex + (runLength - 1)) > line last         ifTrue: [runStopIndex _ line last].    self setStopConditions.    ^ false! !!DisplayScanner methodsFor: 'stop conditions'!paddedSpace    "Each space is a stop condition when the alignment is right justified.     Padding must be added to the base width of the space according to     which space in the line this space is and according to the amount of     space that remained at the end of the line when it was composed."    | oldX |    spaceCount _ spaceCount + 1.    oldX _ destX.    destX _ destX + spaceWidth + (line justifiedPadFor: spaceCount).    fillBlt destX: oldX destY: destY width: destX - oldX height: height; copyBits.    lastIndex _ lastIndex + 1.    ^ false! !!DisplayScanner methodsFor: 'stop conditions'!tab    | oldX |    oldX _ destX.    destX _ (textStyle alignment == Justified and: [self leadingTab not])        ifTrue:        "imbedded tabs in justified text are weird"            [destX + (textStyle tabWidth - (line justifiedTabDeltaFor: spaceCount)) max: destX]        ifFalse:             [textStyle                nextTabXFrom: destX                leftMargin: leftMargin                rightMargin: rightMargin].    fillBlt destX: oldX destY: destY width: destX - oldX height: height;        copyBits.    lastIndex _ lastIndex + 1.    ^ false! !!DisplayScanner methodsFor: 'private'!fillLeading    "At the end of every run (really only needed when font size changes),    fill any extra leading above and below the font in the larger line height"    "Fill space above the font"    fillBlt destX: runX destY: lineY width: destX - runX height: destY - lineY;        copyBits.    "Fill space below the font"    fillBlt destY: (destY + height); height: (lineY + lineHeight) - (destY + height);        copyBits.! !!DisplayScanner methodsFor: 'private'!setFont     | map |    foregroundColor _ paragraph foregroundColor.    super setFont.  "Sets font and emphasis bits"    lastSourceDepth = sourceForm depth ifFalse:        ["Set up color map for a different source depth (color font)"        "Note this may need some caching for reasonable efficiency"        map _ (Color cachedColormapFrom: sourceForm depth to: destForm depth) copy.        map at: 1 put: ((paragraph backgroundColor bitPatternForDepth: destForm depth) at: 1).        self colorMap: map.        lastSourceDepth _ sourceForm depth].    sourceForm depth = 1 ifTrue:        [(colorMap == nil or: [destForm depth = 1]) ifFalse:            [colorMap at: 2 put: ((foregroundColor bitPatternForDepth: destForm depth) at: 1)]].    destY _ lineY + line baseline - font ascent! !!DisplayScanner methodsFor: 'private'!textColor: textColor    foregroundColor _ textColor! !!DisplayScreen methodsFor: 'displaying'!copyBits: rect from: sf at: destOrigin clippingBox: clipRect rule: cr fillColor: hf map: map    ((BitBlt        destForm: self        sourceForm: sf        fillColor: hf        combinationRule: cr        destOrigin: destOrigin        sourceOrigin: rect origin        extent: rect extent        clipRect: (clipRect intersect: clippingBox)) colorMap: map) copyBits! !!DisplayScreen methodsFor: 'displaying'!flash: aRectangle     "Flash the area of the screen defined by the given rectangle."    self reverse: aRectangle.    (Delay forMilliseconds: 100) wait.    self reverse: aRectangle.! !!DisplayScreen methodsFor: 'private' stamp: 'di 6/16/97 11:36'!newDepth: pixelSize"    Display newDepth: 8.    Display newDepth: 1."    self newDepthNoRestore: pixelSize.    ScheduledControllers unCacheWindows; restore.! !!DisplayScreen methodsFor: 'private' stamp: 'tk 12/10/96'!newDepthNoRestore: pixelSize    "Change depths.  Check if there is enough space!!  , di"    | area need |    pixelSize = depth ifTrue: [^ self  "no change"].    pixelSize < depth ifFalse:        ["Make sure there is enough space"        area _ Display boundingBox area. "pixels"        ScheduledControllers scheduledWindowControllers do:            [:aController | aController view cacheBitsAsTwoTone ifFalse:                [area _ area + aController view windowBox area]].        need _ (area * pixelSize // 8) - (area * depth // 8)  "new bytes needed"                + 80000.  "lowSpaceThreshold (should be shared)"        (Smalltalk garbageCollectMost <= need            and: [Smalltalk garbageCollect <= need])            ifTrue: [self halt: 'Insufficient free space']].    self depth: pixelSize.      self setExtent: self extent.    ScheduledControllers updateGray.    DisplayScreen startUp! !!DisplayScreen methodsFor: 'disk I/O' stamp: 'tk 5/13/97'!objectToStoreOnDataStream    "I am about to be written on an object file.  Write a reference to the Display in the other system instead.  "    "A path to me"    ^ DiskProxy global: #Display selector: #yourself args: #()! !!DisplayText methodsFor: 'converting'!asParagraph    "Answer a Paragraph whose text and style are identical to that of the     receiver."    | para |    para _ Paragraph withText: text style: textStyle.    para foregroundColor: foreColor backgroundColor: backColor.    backColor = Color transparent ifTrue: [para rule: Form paint].    ^ para! !!DisplayText methodsFor: 'color'!backgroundColor    backColor == nil ifTrue: [^ Color transparent].    ^ backColor! !!DisplayText methodsFor: 'color'!foregroundColor    foreColor == nil ifTrue: [^ Color black].    ^ foreColor! !!DisplayText class methodsFor: 'examples'!example    "Continually prints two lines of text wherever you point with the cursor     and press any mouse button.  Terminate by pressing any key on the     keyboard."    | tx |    tx _ 'this is a line of characters andthis is the second line.' asDisplayText.    tx foregroundColor: Color black backgroundColor: Color transparent.    tx _ tx alignedTo: #center.    [Sensor anyButtonPressed]        whileFalse:            [tx displayOn: Display at: Sensor cursorPoint]    "DisplayText example."! !!DosFileDirectory methodsFor: 'file creation'!fileClass    ^ StandardFileStream! !!DosFileDirectory class methodsFor: 'initialization'!pathNameDelimiter    ^ $\! !!DualChangeSorter methodsFor: 'everything' stamp: 'sw 6/18/96'!open    "1991, tk.  Modified 5/16/96 sw: decrease minimum size drastically     : more modest minimum size, and other minor adjustments     : more useful choice for initial cs in second sorter"    | topView |    leftCngSorter _ ChangeSorter new initializeFor: Smalltalk changes.    leftCngSorter parent: self.    rightCngSorter _ ChangeSorter new initializeFor: ChangeSorter secondaryChangeSet.    rightCngSorter parent: self.    topView _ StandardSystemView new.    topView model: self.    topView label: leftCngSorter label.    topView minimumSize: 300 @ 200.    self openView: topView.    topView controller open! !!DualChangeSorter methodsFor: 'everything'!openView: topView    "Create views of dual side-by-side change sorter views""    | leftView rightView |    leftView _ View new.    leftView model: leftCngSorter.    leftView window: (0 @ 0 extent: 360 @ 360).    leftView borderWidthLeft: 0 right: 0 top: 0 bottom: 0."    leftCngSorter openView: topView offsetBy: 0@0."    rightView _ View new.    rightView model: rightCngSorter.    rightView window: (0 @ 0 extent: 360 @ 360).    rightView borderWidthLeft: 0 right: 0 top: 0 bottom: 0."    rightCngSorter openView: topView offsetBy: 360@0."    topView addSubView: leftView.    topView addSubView: rightView toRightOf: leftView."! !DummyStream comment:'The purpose of this class is to absorb all steam messages and do nothing.  This is so ReferenceStream can pretend to write on it while traversing all objects it would normally write.  We need to know what those object are.  8/17/96 tk'!!DummyStream methodsFor: 'all' stamp: '6/10/97 17:14 tk'!skip: aNumber    "Do nothing."! !!EllipseMorph methodsFor: 'all'!containsPoint: aPoint    | radius other delta xOverY |    (bounds containsPoint: aPoint) ifFalse: [^ false].  "quick elimination"    radius _ bounds height asFloat / 2.    other _ bounds width asFloat / 2.    delta _ aPoint - bounds topLeft - (other@radius).    xOverY _ bounds width asFloat / bounds height asFloat.    ^ (delta x asFloat / xOverY) squared + delta y squared <= radius squared! !!EllipseMorph methodsFor: 'all' stamp: 'di 6/20/97 11:29'!doesBevels    ^ false! !!EllipseMorph methodsFor: 'all'!drawOn: aCanvas     aCanvas fillOval: bounds        color: color        borderWidth: borderWidth        borderColor: borderColor.! !!EllipseMorph methodsFor: 'all'!initialize    super initialize.    color _ Color yellow.    borderColor _ Color black.    borderWidth _ 1.! !EmphasizedMenu comment:'A selection menu in which individual selections are allowed to have different emphases.  Emphases allowed are: bold, italic, struckThrough, and plain.  Provide an emphasis array, with one element per selection, to use.  Refer to the class method #example.'!!EmphasizedMenu methodsFor: 'display'!startUpWithCaption: captionOrNil    self setEmphasis.    ^ super startUpWithCaption: captionOrNil! !!EmphasizedMenu methodsFor: 'emphasis'!emphases: emphasisArray    emphases _ emphasisArray! !!EmphasizedMenu methodsFor: 'emphasis' stamp: 'sw 12/11/96'!onlyBoldItem: itemNumber    "Set up emphasis such that all items are plain except for the given item number.  "    emphases _ (Array new: selections size) atAllPut: nil.    emphases at: itemNumber put: #bold! !!EmphasizedMenu methodsFor: 'private' stamp: 'sw 12/11/96'!setEmphasis    "Set up the receiver to reflect the emphases in the emphases array.  "    | selStart selEnd currEmphasis |    labelString _ labelString asText.    emphases size == 0 ifTrue: [^ self].    selStart _ 1.    1 to: selections size do:        [:line |            selEnd _ selStart + (selections at: line) size - 1.            ((currEmphasis _ emphases at: line) size > 0 and: [currEmphasis ~~ #plain]) ifTrue:                [labelString addAttribute: (TextEmphasis perform: currEmphasis)                    from: selStart to: selEnd].            selStart _ selEnd + 2]! !!EmphasizedMenu class methodsFor: 'instance creation' stamp: 'sw 12/11/96'!example1    "An example of how to get an EmphasizedMenu to work for you.  "    (self selections:             #('how' 'well' 'does'   'this'   'work?')         emphases:             #(bold     0    italic struckOut plain))        startUpWithCaption: 'A Menu with Emphases'"EmphasizedMenu example1"! !!EmphasizedMenu class methodsFor: 'instance creation'!example2    "EmphasizedMenu example2"    | aMenu |    aMenu _ EmphasizedMenu selections: #('One' 'Two' 'Three' 'Four').    aMenu onlyBoldItem: 3.    aMenu startUpWithCaption: 'Only the Bold'! !!EmphasizedMenu class methodsFor: 'instance creation' stamp: 'sw 12/11/96'!example3    "An example of how to get an EmphasizedMenu to work for you.  "    ^ (self selectionAndEmphasisPairs:         #('how' bold   'well'    0  'does'  italic   'this'  struckOut  'work' plain))        startUpWithCaption: 'A Menu with Emphases'"EmphasizedMenu example3"! !!EmphasizedMenu class methodsFor: 'instance creation' stamp: 'sw 12/23/96'!selectionAndEmphasisPairs: interleavedList    "An alternative form of call.  "    | selList  emphList |    selList _ OrderedCollection new.    emphList _ OrderedCollection new.    interleavedList pairsDo:        [:aSel :anEmph |            selList add: aSel.            emphList add: anEmph].    ^ self selections:selList emphases: emphList! !!EmphasizedMenu class methodsFor: 'instance creation' stamp: 'sw 12/11/96'!selections: selList emphases: emphList    "Answer an instance of the receiver with the given selections and emphases.  "    ^ (self selections: selList) emphases: emphList"(EmphasizedMenu selections: #('how' 'well' 'does' 'this' 'work?') emphases: #(bold 0 italic struckOut plain)) startUp" ! !!Encoder methodsFor: 'initialize-release'!fillDict: dict with: nodeClass mapping: keys to: codeArray    | codeStream |    codeStream _ ReadStream on: codeArray.    keys do:         [:key | dict                 at: key                put:  (nodeClass new name: key key: key code: codeStream next)]! !!Encoder methodsFor: 'initialize-release'!init: aClass context: aContext notifying: req    | node n homeNode indexNode |    requestor _ req.    class _ aClass.    nTemps _ 0.    supered _ false.    self initScopeAndLiteralTables.    n _ -1.    class allInstVarNames do:         [:variable |         node _ VariableNode new                    name: variable                    index: (n _ n + 1)                    type: LdInstType.        scopeTable at: variable put: node].    aContext == nil        ifFalse:             [homeNode _ self bindTemp: 'homeContext'.            "first temp = aContext passed as arg"            n _ 0.            aContext tempNames do:                 [:variable |                 indexNode _ self encodeLiteral: (n _ n + 1).                node _ MessageNode new                            receiver: homeNode                            selector: #tempAt:                            arguments: (Array with: indexNode)                            precedence: 3                            from: self.                scopeTable at: variable put: node]].    sourceRanges _ Dictionary new: 32! !!Encoder methodsFor: 'encoding'!encodeVariable: name ifUnknown: action    | varNode |    varNode _         scopeTable             at: name            ifAbsent:                 [self lookupInPools: name                     ifFound: [:assoc | ^self global: assoc name: name].                ^action value].    ^varNode! !!Encoder methodsFor: 'encoding'!litIndex: literal    | p |    p _ literalStream position.    p = 256 ifTrue:        [self notify: 'More than 256 literals referenced. You must split or otherwise simplify this method.The 257th literal is: ', literal printString. ^nil].        "Would like to show where it is in the source code,          but that info is hard to get."    literalStream nextPut: literal.    ^ p! !!Encoder methodsFor: 'temps'!autoBind: name     "Declare a block argument as a temp if not already declared."    | node |    node _ scopeTable             at: name            ifAbsent:                 [(self lookupInPools: name ifFound: [:assoc | assoc])                    ifTrue: [self notify: 'Name already used in a Pool or Global'].                ^ (self reallyBind: name) nowHasDef nowHasRef scope: 1].    node isTemp        ifTrue: [node scope >= 0 ifTrue:                    [^ self notify: 'Name already used in this method'].                node nowHasDef nowHasRef scope: 1]        ifFalse: [^ self notify: 'Name already used in this class'].    ^node! !!Encoder methodsFor: 'temps' stamp: 'jm 9/18/97 21:06'!bindArg: name     "Declare an argument."    | node |    nTemps >= 15        ifTrue: [^self notify: 'Too many arguments'].    node _ self bindTemp: name.    ^ node nowHasDef nowHasRef! !!Encoder methodsFor: 'temps'!newTemp: name    nTemps _ nTemps + 1.    ^ TempVariableNode new        name: name        index: nTemps - 1        type: LdTempType        scope: 0! !!Encoder methodsFor: 'results'!tempNames     | tempNodes |    tempNodes _ SortedCollection sortBlock: [:n1 :n2 | n1 code <= n2 code].    scopeTable associationsDo:        [:assn | (assn value isMemberOf: TempVariableNode)            ifTrue: [tempNodes add: assn value]].    ^ tempNodes collect: [:node | node key]! !!Encoder methodsFor: 'results'!tempsAndBlockArgs    | tempNodes var |    tempNodes _ OrderedCollection new.    scopeTable associationsDo:        [:assn | var _ assn value.        ((var isTemp and: [var isArg not])                    and: [var scope = 0 or: [var scope = -1]])            ifTrue: [tempNodes add: var]].    ^ tempNodes! !!Encoder methodsFor: 'results'!unusedTempNames     | unused |    unused _ OrderedCollection new.    scopeTable associationsDo:        [:assn | (assn value isUnusedTemp)            ifTrue: [unused add: assn value key]].    ^ unused! !!Encoder methodsFor: 'source mapping'!sourceMap    "Answer with a sorted set of associations (pc range)."    ^ (sourceRanges keys collect:         [:key |  Association key: key pc value: (sourceRanges at: key)])            asSortedCollection! !!Encoder methodsFor: 'private'!lookupInPools: name ifFound: assocBlock    | |    Symbol         hasInterned: name         ifTrue: [:sym | ^class scopeHas: sym ifTrue: assocBlock].    ^ class scopeHas: name ifTrue: assocBlock.  "Its a string in the pool"! !EventHandler comment:'Events in Morphic originate in a Hand, pass to a target morph, and are then dispatched by an EventHandler.  EventHandlers support redirection of mouse and keyboard activity by specifying and independent recipient object and message selector for each of the possible events.  In addition each eventHandler can supply an optional value parameter for distinguishing between, eg, events from a number of otherwise identical source morphs.The basic protocol of an event handler is to receive a message of the form    mouseDown: event in: targetMorphand redirect this as one of    mouseDownRecipient perform: mouseDownSelector0    mouseDownRecipient perform: mouseDownSelector1 with: event    mouseDownRecipient perform: mouseDownSelector2 with: event with: targetMorph    mouseDownRecipient perform: mouseDownSelector3 with: event with: targetMorph with: valueParameterdepending on the arity of the mouseDownSelector.'!!EventHandler methodsFor: 'initialization'!on: eventName send: selector to: recipient    eventName = #mouseDown ifTrue:        [mouseDownRecipient _ recipient.  mouseDownSelector _ selector. ^ self].    eventName = #mouseStillDown ifTrue:        [mouseStillDownRecipient _ recipient.  mouseStillDownSelector _ selector. ^ self].    eventName = #mouseUp ifTrue:        [mouseUpRecipient _ recipient.  mouseUpSelector _ selector. ^ self].    eventName = #mouseEnter ifTrue:        [mouseEnterRecipient _ recipient.  mouseEnterSelector _ selector. ^ self].    eventName = #mouseLeave ifTrue:        [mouseLeaveRecipient _ recipient.  mouseLeaveSelector _ selector. ^ self].    eventName = #keyStroke ifTrue:        [keyStrokeRecipient _ recipient.  keyStrokeSelector _ selector. ^ self].    self error: 'Event name, ' , eventName , ' is not recognizable.'! !!EventHandler methodsFor: 'initialization'!on: eventName send: selector to: recipient withValue: value    selector numArgs = 3 ifFalse:        [self halt: 'Warning: value parameters are passed as last of 3 arguments'].    self on: eventName send: selector to: recipient.    valueParameter _ value! !!EventHandler methodsFor: 'testing'!handlesMouseDown: evt    mouseDownRecipient ifNotNil: [^ true].    mouseStillDownRecipient ifNotNil: [^ true].    mouseUpRecipient ifNotNil: [^ true].    ^ false! !!EventHandler methodsFor: 'testing'!handlesMouseOver: evt    mouseEnterRecipient ifNotNil: [^ true].    mouseLeaveRecipient ifNotNil: [^ true].    ^ false! !!EventHandler methodsFor: 'testing'!mouseDownRecipient    ^ mouseDownRecipient! !!EventHandler methodsFor: 'testing'!mouseDownSelector    ^ mouseDownSelector! !!EventHandler methodsFor: 'testing'!mouseUpSelector    ^ mouseUpSelector! !!EventHandler methodsFor: 'events'!handleEvent: evt fromMorph: sourceMorph    "Handle the given event by using the event type to decide what to do. This method is less efficient than the specific event handling messages."    "Note: This method cannot be used for mouse enter and leave transitions, since these events are just mouseMove events whose interpretation depends on context."    evt isMouse ifTrue: [        evt isMouseMove ifTrue: [            ^ self mouseStillDown: evt fromMorph: sourceMorph].        evt isMouseDown ifTrue: [            ^ self mouseDown: evt fromMorph: sourceMorph].        evt isMouseUp ifTrue: [            ^ self mouseUp: evt fromMorph: sourceMorph]].    evt isKeystroke ifTrue: [        ^ self keyStroke: evt fromMorph: sourceMorph].! !!EventHandler methodsFor: 'events'!keyStroke: event fromMorph: sourceMorph    ^ self send: keyStrokeSelector to: keyStrokeRecipient withEvent: event fromMorph: sourceMorph! !!EventHandler methodsFor: 'events'!mouseDown: event fromMorph: sourceMorph    ^ self send: mouseDownSelector to: mouseDownRecipient withEvent: event fromMorph: sourceMorph! !!EventHandler methodsFor: 'events'!mouseEnter: event fromMorph: sourceMorph    ^ self send: mouseEnterSelector to: mouseEnterRecipient withEvent: event fromMorph: sourceMorph! !!EventHandler methodsFor: 'events'!mouseLeave: event fromMorph: sourceMorph    ^ self send: mouseLeaveSelector to: mouseLeaveRecipient withEvent: event fromMorph: sourceMorph! !!EventHandler methodsFor: 'events'!mouseStillDown: event fromMorph: sourceMorph    ^ self send: mouseStillDownSelector to: mouseStillDownRecipient withEvent: event fromMorph: sourceMorph! !!EventHandler methodsFor: 'events'!mouseUp: event fromMorph: sourceMorph    ^ self send: mouseUpSelector to: mouseUpRecipient withEvent: event fromMorph: sourceMorph! !!EventHandler methodsFor: 'events'!send: selector to: recipient withEvent: event fromMorph: sourceMorph    | arity |    recipient ifNil: [^ self].    arity _ selector numArgs.    arity = 0 ifTrue:        [^ recipient perform: selector].    arity = 1 ifTrue:        [^ recipient perform: selector with: event].    arity = 2 ifTrue:        [^ recipient perform: selector with: event with: sourceMorph].    arity = 3 ifTrue:        [^ recipient perform: selector with: event with: sourceMorph with: valueParameter].    self error: 'Event handling selectors must be Symbols and take 0-3 arguments'! !!EventRecorder methodsFor: 'as yet unclassified'!handleEvent: anEvent    "Start, Stop, and record events.  Playback.  5/21/97 tk""state = nil   stopped, not recording     = #record    recording    = #play        playing backControl 1 = start recordingControl 2 = stop recording (or playing back)Control 3 = start playing back"state == nil ifTrue: [^ self testControl: anEvent].state == #record ifTrue: [tape addLast: anEvent.    ^ self testControl: anEvent].state == #play ifTrue: [^ self testControl: anEvent].    "ignore my own events.      Playback happens from another method.""AA _ EventRecorder new.hands first startReportingEventsTo: AA. "! !!EventRecorder methodsFor: 'as yet unclassified'!testControl: anEvent    "See if it is a control event for me.  Control 1 = start recordingControl 2 = stop recording (or playing back)Control 3 = start playing back"    anEvent isKeystroke ifFalse: [^ self].    anEvent controlKeyPressed ifFalse: [^ self].    anEvent commandKeyPressed ifTrue: [^ self].    "not this"    anEvent optionKeyPressed ifTrue: [^ self].    "not this"    anEvent shiftPressed ifTrue: [^ self].    "not this"    anEvent keyCharacter = $1 ifTrue: ["start recording"        tape ifNil: [tape _ OrderedCollection new].        state _ #record].    anEvent keyCharacter = $2 ifTrue: ["stop recording (or playing back)"        state _ nil].    anEvent keyCharacter = $3 ifTrue: ["start playing back"        state _ #play.        tape ifNotNil: [            tape do: [:evt |                 anEvent hand world runStepMethods.                anEvent hand handleEvent: evt.                anEvent hand world displayWorld]].        state _ nil].! !!ExternalStream methodsFor: 'accessing'!nextInto: buffer     "fill buffer from my collection"    (buffer isMemberOf: Bitmap) ifTrue:        [1 to: buffer size do:            [:index | buffer at: index put: (self nextNumber: 4)].        ^ buffer].    1 to: buffer size do:        [:index | buffer at: index put: self next].    ^ buffer! !!ExternalStream methodsFor: 'nonhomogeneous accessing' stamp: 'di 9/19/97 09:12'!nextLitteEndianNumber: n     "Answer the next n bytes as a positive Integer or LargePositiveInteger, where the bytes are ordered from least significant to most significant."    | s bytes |    bytes _ self next: n.    s _ 0.    n to: 1 by: -1 do: [: i | s _ (s bitShift: 8) bitOr: (bytes at: i)].    ^ s! !!ExternalStream methodsFor: 'nonhomogeneous accessing' stamp: 'di 9/19/97 14:34'!nextLitteEndianNumber: n put: value    "Answer the next n bytes as a positive Integer or LargePositiveInteger, where the bytes are ordered from least significant to most significant."    | bytes |    bytes _ ByteArray new: n.    1 to: n do: [: i | bytes at: i put: (value digitAt: i)].    self nextPutAll: bytes! !!ExternalStream methodsFor: 'nonhomogeneous accessing'!nextNumber: n     "Answer the next n bytes as a positive Integer or LargePositiveInteger."    | s |    s _ 0.    1 to: n do:         [:i | s _ (s bitShift: 8) bitOr: self next].    ^ s normalize! !!ExternalStream methodsFor: 'nonhomogeneous accessing' stamp: '6/9/97 18:27 tk'!nextNumber: n put: v     "Append to the receiver the argument, v, which is a positive     SmallInteger or a LargePositiveInteger, as the next n bytes.    Possibly pad with leading zeros."    1 to: n do: [:i | self nextPut: (v digitAt: n+1-i)].    ^ v! !FFT comment:'This class implements the Fast Fourier Transform roughly as described on page 367of "Theory and Application of Digital Signal Processing" by Rabiner and Gold.Each instance caches tables used for transforming a given size (n = 2^nu samples) of data.It would have been cleaner using complex numbers, but often the data is all real.'!!FFT methodsFor: 'initialization' stamp: 'di 6/17/97 07:47'!nu: order    "Initialize variables and tables for transforming 2^nu points"    |  j perms k |    nu _ order.    n _ 2 bitShift: nu-1.    "Initialize permutation table (bit-reversed indices)"    j_0.    perms _ WriteStream on: (Array new: n).    0 to: n-2 do:        [:i |        i < j ifTrue: [perms nextPut: i+1; nextPut: j+1].        k _ n // 2.        [k <= j] whileTrue: [j _ j-k.  k _ k//2].        j _ j + k].    permTable _ perms contents.    "Initialize sin table 0..pi/2 in n/4 steps."    sinTable _ (0 to: n/4) collect: [:i | (i asFloat / (n//4) * Float pi / 2.0) sin]! !!FFT methodsFor: 'initialization' stamp: 'di 6/17/97 07:47'!realData: real    realData _ real.    imagData _ real collect: [:i | 0.0]  "imaginary component all zero"! !!FFT methodsFor: 'initialization' stamp: 'di 6/17/97 07:47'!realData: real imagData: imag    realData _ real.    imagData _ imag! !!FFT methodsFor: 'transforming' stamp: 'di 6/17/97 07:47'!permuteData    | i end a b |    i _ 1.    end _ permTable size.    [i <= end] whileTrue:        [a _ permTable at: i.        b _ permTable at: i+1.        realData swap: a with: b.        imagData swap: a with: b.        i _ i + 2]! !!FFT methodsFor: 'transforming' stamp: 'di 6/17/97 07:47'!scaleData    "Scale all elements by 1/n when doing inverse"    | realN |    realN _ n asFloat.    1 to: n do:        [:i |        realData at: i put: (realData at: i) / realN.        imagData at: i put: (imagData at: i) / realN]! !!FFT methodsFor: 'transforming' stamp: 'di 6/17/97 07:47'!transformForward: forward    | lev lev1 ip theta realU imagU realT imagT i |    self permuteData.    1 to: nu do:        [:level |        lev _ 1 bitShift: level.        lev1 _ lev // 2.        1 to: lev1 do:            [:j |            theta _ j-1 * (n // lev).   "pi * (j-1) / lev1 mapped onto 0..n/2"            theta < (n//4)  "Compute U, the complex multiplier for each level"                ifTrue:                    [realU _ sinTable at: sinTable size - theta.                    imagU _ sinTable at: theta + 1]                ifFalse:                    [realU _ (sinTable at: theta - (n//4) + 1) negated.                    imagU _ sinTable at: (n//2) - theta + 1].            forward ifFalse: [imagU _ imagU negated]."            Here is the inner loop...            j to: n by: lev do:                [:i |   hand-transformed to whileTrue..."            i _ j.            [i <= n] whileTrue:                [ip _ i + lev1.                realT _ ((realData at: ip) * realU) - ((imagData at: ip) * imagU).                imagT _ ((realData at: ip) * imagU) + ((imagData at: ip) * realU).                realData at: ip put: (realData at: i) - realT.                imagData at: ip put: (imagData at: i) - imagT.                realData at: i put: (realData at: i) + realT.                imagData at: i put: (imagData at: i) + imagT.                i _ i + lev]]].    forward ifFalse: [self scaleData]  "Reverse transform must scale to be an inverse"! !!FFT methodsFor: 'testing' stamp: 'di 6/17/97 07:47'!plot: samples in: rect    "Throw-away code just to check out a couple of examples"    | min max x dx pen y |    Display fillWhite: rect; border: (rect expandBy: 2) width: 2.    min _ 1.0e30.  max _ -1.0e30.    samples do:        [:v |        min _ min min: v.        max _ max max: v].    pen _ Pen new.  pen up.    x _ rect left.    dx _ rect width asFloat / samples size.    samples do:        [:v |        y _ (max-v) / (max-min) * rect height asFloat.        pen goto: x asInteger @ (rect top + y asInteger).        pen down.        x _ x + dx].    max printString displayOn: Display at: (x+2) @ (rect top-9).    min printString displayOn: Display at: (x+2) @ (rect bottom - 9)! !!FFT methodsFor: 'testing' stamp: 'di 6/17/97 07:47'!test  "Display restoreAfter: [(FFT new nu: 8) test].  --  Test on an array of 256 samples"    "Initialize to pure (co)Sine Wave, plot, transform, plot, invert and plot again"    self realData: ((1 to: n) collect: [:i | (Float pi * (i-1) / (n/8)) cos]).    self plot: realData in: (100@20 extent: 256@60).    self transformForward: true.    self plot: realData in: (100@100 extent: 256@60).    self plot: imagData in: (100@180 extent: 256@60).    self transformForward: false.    self plot: realData in: (100@260 extent: 256@60)! !FileDirectory comment:'I represent a collection of Files. My instances are uniquely identified by the device or server to which they refer. They may also be found in some other dictionary or FileDirectory, though often this is implicit.  FileDirectories carry a path name, and are capable of a number of file creation and access functions, relating to the directory, or volume indicated by their path name.  A FileDirectory can be thought of as a Dictionary whose keys are the local names of files in that directory, and whose values are directory "entries".A directory "entry" is an array of five items:    <name> <creationTime> <modificationTime> <dirFlag> <fileSize>See the comment in lookupEntry:... which provides primitive access to this information.'!!FileDirectory methodsFor: 'file names'!fullNameFor: fileName    pathName isEmpty ifTrue:        [^ self checkName: fileName fixErrors: true].    "Return <explicit or implicit path>,<corrected local name>"    FileDirectory splitName: fileName to:        [:path :localName |        ^ (path isEmpty ifTrue: [pathName] ifFalse: [path]) ,            self pathNameDelimiter asString ,             (self checkName: localName fixErrors: true)]! !!FileDirectory methodsFor: 'file creation' stamp: 'di 9/15/97 11:34'!directoryNamed: fileName    ^ self class newOnPath: (self fullNameFor: fileName)! !!FileDirectory methodsFor: 'dictionary access'!includesKey: aString    "Answer whether the receiver includes an element of the given name."    "Note: aString may designate a file local to this directory, or it may be a full path name. Try both."    ^ (StandardFileStream isAFileNamed: pathName , self pathNameDelimiter asString , aString) or:        [StandardFileStream isAFileNamed: aString]! !!FileDirectory class methodsFor: 'class initialization' stamp: 'di 6/25/97 15:38'!openSources: sourcesName andChanges: changesName forImage: imageName    "Look for the changes file on the image volume, and make the image volume the default directory.  Then look for the sources in the image volume.   Install results in SourceFiles.  .  Look for alias to sources "    | sources changes sourceAlias msg |    msg _ 'Squeak cannot locate &fileRef.Please check that the file is named properly and is in thesame directory as this image.  Further explanation can foundin the startup window, ''How Squeak Finds Source Code''.'.    self setDefaultDirectoryFrom: imageName.    sources _ (DefaultDirectory includesKey: sourcesName)        ifTrue: [DefaultDirectory readOnlyFileNamed: sourcesName]        ifFalse: [nil].    sources == nil ifTrue:        ["Allow an un-renamed alias of the sources file"        sourceAlias _ sourcesName, ' alias'.        sources _ (DefaultDirectory includesKey: sourceAlias)            ifTrue: [DefaultDirectory readOnlyFileNamed: sourceAlias]            ifFalse: [nil]].    sources == nil ifTrue:        [PopUpMenu notify: (msg copyReplaceAll: '&fileRef' with: 'the sources file named ' , sourcesName)].    changes _ (DefaultDirectory includesKey: changesName)        ifTrue: [DefaultDirectory oldFileNamed: changesName]        ifFalse: [nil].    changes == nil ifTrue:        [PopUpMenu notify: (msg copyReplaceAll: '&fileRef' with: 'the changes file named ' , changesName)].    SourceFiles _ Array with: sources with: changes! !!FileDirectory class methodsFor: 'name service'!convertName: fileName to: volAndNameBlock    "Convert the fileName to a directory object and a local fileName.  FileName must be of the form: <path><name> where the optional <path> specifies a known directory and <name> is the file name within that directory."    self splitName: fileName to:        [:path :localName |        path isEmpty        ifTrue:            [^ volAndNameBlock value: DefaultDirectory                                value: localName]        ifFalse:            [^ volAndNameBlock value: (self newOnPath: path)                                value: localName]]! !!FileDirectory class methodsFor: 'primitives'!lookupEntryIn: pathName index: index    "Look up the index-th entry of the directory with the given path (starting from the root of the file hierarchy) and return an array containing:    <name> <creationTime> <modificationTime> <dirFlag> <fileSize>    The empty path enumerates the top-level files or drives. (For example, on Unix, the empty path enumerates '/'. On Macs and PCs, it enumerates the mounted volumes/drives.)    The creation and modification times are in seconds since the start of the Smalltalk time epoch. DirFlag is true if the entry is a directory. FileSize the file size in bytes or zero for directories. The primitive returns nil when index is past the end of the directory. It fails if the given pathName is bad."     <primitive: 162>    self primitiveFailed.! !!FileDirectory class methodsFor: 'primitives'!pathNameDelimiter    ^ self actualPathNameDelimiter! !!FileDirectory class methodsFor: 'primitives'!setMacFileNamed: fileName type: typeString creator: creatorString    "Mac specific; noop on other platforms."! !!FileList methodsFor: 'initialization'!directory: dir    "Set the path of the volume to be displayed."    sortMode == nil ifTrue: [sortMode _ #name].    self okToChange ifFalse: [^ self].    directory _ dir.    volList _ (Array with: '[]'), directory pathParts.    self changed: #relabel.    self changed: #list.    self newListAndPattern: (pattern == nil ifTrue: ['*']                                        ifFalse: [pattern]).! !!FileList methodsFor: 'list access'!toggleFileListIndex: anInteger    "Select the file name in the receiver's list whose index is the argument,     anInteger. If the current selection index is already anInteger, deselect it."    | item name |    listIndex = anInteger    ifTrue:        [listIndex _ 0.        fileName _ nil]    ifFalse:         [listIndex _ anInteger.        item _ list at: anInteger.        item first = $( ifTrue:  "remove size or date"            [item _ item copyFrom: (item indexOf: $)) + 2 to: item size].        (item endsWith: self folderString)            ifTrue:            ["remove [...] folder string and open the folder"            name _ item copyFrom: 1 to: item size - self folderString size.            listIndex _ 0.            ^ self directory: (FileDirectory newOnPath:                (directory fullNameFor: name))]            ifFalse:            ["open the file selected"            self setFileName: item]].    self changed: #fileListIndex! !!FileList methodsFor: 'menu messages'!copyName    | localName |    listIndex = 0 ifTrue: [^ self].    localName _ FileDirectory default localNameFor: self fullName.    localName size = 0 ifTrue: [localName _ self fullName].    ParagraphEditor new clipboardTextPut: localName asText! !!FileList methodsFor: 'private'!defaultContents    list == nil ifTrue: [^ String new].    ^ String streamContents:        [:s | s nextPutAll: 'NO FILE SELECTED'; cr.        s nextPutAll: '  -- Folder Summary --'; cr.        list do: [:item | s nextPutAll: item; cr]]! !!FileList methodsFor: 'private'!readContentsBrief: brevity    "Read the contents of the receiver's selected file."    listIndex = 0        ifTrue: [^self defaultContents]        ifFalse: [^ super readContentsBrief: brevity]! !!FileListController methodsFor: 'menu messages'!openImageInWindow    self controlTerminate.    model openImageInWindow.    self controlInitialize    ! !!FileListController class methodsFor: 'class initialization'!initialize   "FileListController initialize"    "Initialize the file list menu.  6/96 di; modified 7/12/96 sw to add the file-into-new-change-set feature"    FileListYellowButtonMenu _ PopUpMenu labels:'fileInfile into new change setbrowse changesspawn this filecopy name to clipboardopen image in a windowread image into GIFImportssort by namesort by sizesort by daterenamedeleteadd new file' lines: # (5 7 10).    FileListYellowButtonMessages _#(fileInSelection fileIntoNewChangeSet browseChanges editFile copyName openImageInWindow importGIF sortByName sortBySize sortByDate renameFile deleteFile addNewFile)! !!FileModel methodsFor: 'accessing' stamp: 'di 6/28/97 21:25'!fileAllIn    "FileIn all of the contents from the external file"    | f |    f _ FileStream oldFileNamed: self fullName.    (self fileNameSuffix sameAs: 'html') ifTrue: [f _ f asHtml].    f fileIn! !!FileModel methodsFor: 'accessing' stamp: 'di 6/28/97 21:26'!fileIntoNewChangeSet    "FileIn all of the contents from the external file, into a new change set."    | f |    f _ FileStream oldFileNamed: self fullName.    (self fileNameSuffix sameAs: 'html') ifTrue: [f _ f asHtml].    ChangeSorter newChangesFromFileStream: f! !!FileModel methodsFor: 'accessing' stamp: 'di 6/28/97 21:21'!fileNameSuffix    | name i |    name _ self fullName.    i _ name findLast: [:c | c = $.].    i = 0 ifTrue: [^ ''].    ^ name copyFrom: i+1 to: name size! !!FileModel methodsFor: 'accessing' stamp: 'sw 7/18/96'!importGIF    "Import the given GIF file and store the resulting Form in the global dictionary GIFImports, at a key consisting of the short filename up to the first period.  "    | key f gifReader |    (gifReader _ Smalltalk gifReaderClass) == nil ifTrue: [        ^ self inform: 'Sorry, there is no GIF reader available in the current system'].    key _ self fileName sansPeriodSuffix.    f _ gifReader formFromFileNamed: self fullName.    Smalltalk gifImports at: key put: f.! !!FileModel methodsFor: 'accessing'!openImageInWindow    | file fileCode form |    file _ FileStream readOnlyFileNamed: self fullName.    fileCode _ file next asciiValue.    file close.    fileCode = 2        ifTrue: [form _ Form newFromFileNamed: self fullName]        ifFalse: [form _ Smalltalk gifReaderClass formFromFileNamed: self fullName].    FormView open: form named: fileName.! !!FileModel methodsFor: 'accessing'!put: aString     | f |    (aString size >= 5 and:        [#('File ' '16r0 ') includes: (aString copyFrom: 1 to: 5)])        ifTrue: [(self confirm:'Abbreviated and hexadecimal file viewscannot be meaningfully saved at present.Is this REALLY what you want to do?')                ifFalse: [^ self]].    f _ FileStream newFileNamed: self fullName.    Cursor write showWhile: [f nextPutAll: aString; close].! !!FileModel methodsFor: 'accessing' stamp: 'tk 9/21/96'!readContentsBrief: brevityFlag    "retrieve the contents from the external file unless it is too long.      Don't create a file here.  Check if exists."    | f size newContents first1000 last1000 |    f _ FileStream oldFileOrNoneNamed: self fullName.     f == nil ifTrue:        [^ 'For some reason, this file cannot be read'].    (brevityFlag and: [(size _ f size) > 30000]) ifFalse:         [^ f contentsOfEntireFile].    "Don't display long files at first.    Composing the paragraph may take a long time."    first1000 _ f next: 1000.    f position: size - 1000.    last1000 _ f next: 1000.    f close.    ^ 'File ''' , fileName , ''' is ', size printString, ' bytes long.You may use the ''get'' command to read the entire file.Here are the first 1000 characters:--------------------------------' , first1000 , '... and here are the last 1000 characters:--------------------------------------' , last1000! !!FileModel methodsFor: 'accessing' stamp: 'tk 9/21/96'!readContentsHex    "retrieve the contents from the external file unless it is too long.      Don't create a file here.  Check if exists."    | f size data hexData s |    f _ FileStream oldFileOrNoneNamed: self fullName.     f == nil ifTrue:        [^ 'For some reason, this file cannot be read'].    (size _ f size) > 10000        ifTrue: [data _ f next: 10000. f close]        ifFalse: [data _ f contentsOfEntireFile].    s _ WriteStream on: (String new: data size*4).    0 to: data size-1 by: 16 do:        [:loc | s nextPutAll: loc hex; space;            nextPut: $(; print: loc; nextPut: $); space; tab.        loc+1 to: (loc+16 min: data size) do: [:i | s nextPutAll: (data at: i) hex; space].        s cr].    hexData _ s contents.    size > 10000        ifTrue: [^ 'First 10k bytes:------------------' , hexData]        ifFalse: [^ hexData].! !!FileStream methodsFor: 'file modes' stamp: 'tk 6/26/97 12:15'!ascii    "Set the receiver's file to be in text mode.     1/31/96 sw: subclassResponsibility"    self subclassResponsibility! !!FileStream methodsFor: 'file modes' stamp: 'tk 6/26/97 12:15'!text    "Define both text and ascii as meaning not binary.  We need to supply what people will think of.  tk 6/26/97 12:15"    self ascii! !!FileStream methodsFor: 'file status'!close    "Set the receiver's file status to closed."    closed        ifFalse:             [self writing                 ifTrue: [(rwmode bitAnd: Shorten) = Shorten                            ifTrue: [self shorten]                            ifFalse: [self flush]].            closed _ true.            readLimit _ writeLimit _ 0.            self file close].! !!FileStream class methodsFor: 'instance creation'!fileNamed: fileName     ^ self concreteStream fileNamed: (self fullName: fileName)! !!FileStream class methodsFor: 'instance creation'!newFileNamed: fileName     ^ self concreteStream newFileNamed: (self fullName: fileName)! !!FileStream class methodsFor: 'instance creation'!oldFileNamed: fileName     ^ self concreteStream oldFileNamed: (self fullName: fileName)! !!FileStream class methodsFor: 'instance creation' stamp: 'tk 9/21/96'!oldFileOrNoneNamed: fileName    "Only open the file if it exists already.  Don't get an error if not there.  "| myName |myName _ self fullName: fileName.^ (self concreteStream isAFileNamed: myName)     ifTrue: [self concreteStream oldFileNamed: myName]    ifFalse: [nil].! !!FileStream class methodsFor: 'instance creation'!readOnlyFileNamed: fileName     ^ self concreteStream readOnlyFileNamed: (self fullName: fileName)! !!FileStream class methodsFor: 'concrete classes' stamp: 'tk 9/21/96'!concreteStream    "Who should we really direct class queries to?  "    ^ StandardFileStream! !!FlasherMorph methodsFor: 'all'!color: aColor    super color: aColor.    onColor _ aColor.! !!FlasherMorph methodsFor: 'all'!fullPrintOn: aStream    color _ onColor.    super fullPrintOn: aStream.! !!FlasherMorph methodsFor: 'all'!initialize    super initialize.    self color: Color red.    self extent: 25@25.    self borderWidth: 2.! !!FlasherMorph methodsFor: 'all'!step    color = onColor        ifTrue: [super color: (onColor mixed: 0.5 with: Color black)]        ifFalse: [super color: onColor].! !!FlasherMorph methodsFor: 'all'!stepTime    "Answer the desired time between steps in milliseconds."    ^ 500! !!Float methodsFor: 'arithmetic'!* aNumber     "Primitive. Answer the result of multiplying the receiver by aNumber.    Fail if the argument is not a Float. Essential. See Object documentation    whatIsAPrimitive."    <primitive: 49>    ^ (aNumber adaptFloat: self) * aNumber adaptToFloat! !!Float methodsFor: 'arithmetic'!+ aNumber     "Primitive. Answer the sum of the receiver and aNumber. Essential.    Fail if the argument is not a Float. See Object documentation    whatIsAPrimitive."    <primitive: 41>    ^ (aNumber adaptFloat: self) + aNumber adaptToFloat! !!Float methodsFor: 'arithmetic'!- aNumber     "Primitive. Answer the difference between the receiver and aNumber.    Fail if the argument is not a Float. Essential. See Object documentation    whatIsAPrimitive."    <primitive: 42>    ^ (aNumber adaptFloat: self) - aNumber adaptToFloat! !!Float methodsFor: 'arithmetic'!/ aNumber     "Primitive. Answer the result of dividing receiver by aNumber.    Fail if the argument is not a Float. Essential. See Object documentation    whatIsAPrimitive."    <primitive: 50>    aNumber = 0        ifTrue: [self error: 'attempt to divide by zero']        ifFalse: [^ (aNumber adaptFloat: self) / aNumber adaptToFloat]! !!Float methodsFor: 'arithmetic'!abs    "This is faster than using Number abs."    self < 0.0        ifTrue: [^ 0.0 - self]        ifFalse: [^ self]! !!Float methodsFor: 'arithmetic'!reciprocal    ^ 1.0 / self! !!Float methodsFor: 'mathematical functions'!arcCos    "Answer the angle in radians."    ^ Halfpi - self arcSin! !!Float methodsFor: 'mathematical functions'!arcSin    "Answer the angle in radians."    ((self < -1.0) or: [self > 1.0]) ifTrue: [self error: 'Value out of range'].    ((self = -1.0) or: [self = 1.0])        ifTrue: [^ Halfpi]        ifFalse: [^ (self / (1.0 - (self * self)) sqrt) arcTan]! !!Float methodsFor: 'mathematical functions'!arcTan    "Answer the angle in radians.     Optional. See Object documentation whatIsAPrimitive."    | theta eps step sinTheta cosTheta |    <primitive: 57>    "Newton-Raphson"    self < 0.0 ifTrue: [ ^ 0.0 - (0.0 - self) arcTan ].    "first guess"    theta _ (self * Halfpi) / (self + 1.0).    "iterate"    eps _ Halfpi * Epsilon.    step _ theta.    [(step * step) > eps] whileTrue: [        sinTheta _ theta sin.        cosTheta _ theta cos.        step _ (sinTheta * cosTheta) - (self * cosTheta * cosTheta).        theta _ theta - step].    ^ theta! !!Float methodsFor: 'mathematical functions'!cos    "Answer the cosine of the receiver taken as an angle in radians."    ^ (self + Halfpi) sin! !!Float methodsFor: 'mathematical functions'!degreeCos    "Answer the cosine of the receiver taken as an angle in degrees."    ^ self degreesToRadians cos! !!Float methodsFor: 'mathematical functions'!degreeSin    "Answer the sine of the receiver taken as an angle in degrees."    ^ self degreesToRadians sin! !!Float methodsFor: 'mathematical functions'!exp    "Answer E raised to the receiver power.     Optional. See Object documentation whatIsAPrimitive."     | base fract correction delta div |    <primitive: 59>    "Taylor series"    "check the special cases"    self < 0.0 ifTrue: [^ (self negated exp) reciprocal].    self = 0.0 ifTrue: [^ 1].    self abs > MaxValLn ifTrue: [self error: 'exp overflow'].    "get first approximation by raising e to integer power"    base _ E raisedToInteger: (self truncated).    "now compute the correction with a short Taylor series"    "fract will be 0..1, so correction will be 1..E"    "in the worst case, convergance time is logarithmic with 1/Epsilon"    fract _ self fractionPart.    fract = 0.0 ifTrue: [ ^ base ].  "no correction required"    correction _ 1.0 + fract.    delta _ fract * fract / 2.0.    div _ 2.0.    [delta > Epsilon] whileTrue: [        correction _ correction + delta.        div _ div + 1.0.        delta _ delta * fract / div].    correction _ correction + delta.    ^ base * correction! !!Float methodsFor: 'mathematical functions'!floorLog: radix     "Quick computation of (self log: radix) floor."    | x rsq |    self < radix ifTrue: [^0].     "self assumed positive"    self < (rsq _ radix * radix) ifTrue: [^1].    x _ 2 * (self floorLog: rsq).    "binary recursion like ipow"    ^x + (self / (radix raisedTo: x) floorLog: radix)! !!Float methodsFor: 'mathematical functions'!ln    "Answer the natural logarithm of the receiver.     Optional. See Object documentation whatIsAPrimitive."    | expt n mant x div pow delta sum eps |    <primitive: 58>    "Taylor series"    self <= 0.0 ifTrue: [self error: 'ln is only defined for x > 0.0'].    "get a rough estimate from binary exponent"    expt _ self exponent.    n _ Ln2 * expt.    mant _ self timesTwoPower: 0 - expt.    "compute fine correction from mantinssa in Taylor series"    "mant is in the range [0..2]"    "we unroll the loop to avoid use of abs"    x _ mant - 1.0.    div _ 1.0.    pow _ delta _ sum _ x.    x _ x negated.  "x <= 0"    eps _ Epsilon * (n abs + 1.0).    [delta > eps] whileTrue: [        "pass one: delta is positive"        div _ div + 1.0.        pow _ pow * x.        delta _ pow / div.        sum _ sum + delta.        "pass two: delta is negative"        div _ div + 1.0.        pow _ pow * x.        delta _ pow / div.        sum _ sum + delta].    ^ n + sum    "2.718284 ln 1.0"! !!Float methodsFor: 'mathematical functions'!log    "Answer the base 10 logarithm of the receiver."    ^ self ln / Ln10! !!Float methodsFor: 'mathematical functions'!raisedTo: power    ^ (self ln * power asFloat) exp! !!Float methodsFor: 'mathematical functions'!sin    "Answer the sine of the receiver taken as an angle in radians.     Optional. See Object documentation whatIsAPrimitive."    | sum delta self2 i |    <primitive: 56>    "Taylor series"    "normalize to the range [0..Pi/2]"    self < 0.0 ifTrue: [^ (0.0 - ((0.0 - self) sin))].    self > Twopi ifTrue: [^ (self \\ Twopi) sin].    self > Pi ifTrue: [^ (0.0 - (self - Pi) sin)].    self > Halfpi ifTrue: [^ (Pi - self) sin].    "unroll loop to avoid use of abs"    sum _ delta _ self.    self2 _ 0.0 - (self * self).    i _ 2.0.    [delta > Epsilon] whileTrue: [        "once"        delta _ (delta * self2) / (i * (i + 1.0)).        i _ i + 2.0.        sum _ sum + delta.        "twice"        delta _ (delta * self2) / (i * (i + 1.0)).        i _ i + 2.0.        sum _ sum + delta].    ^ sum! !!Float methodsFor: 'mathematical functions'!sqrt    "Answer the square root of the receiver.     Optional. See Object documentation whatIsAPrimitive."    | exp guess eps delta |    <primitive: 55>    "Newton-Raphson"    self <= 0.0 ifTrue: [        self = 0.0            ifTrue: [^ 0.0]            ifFalse: [^ self error: 'sqrt is invalid for x < 0']].    "first guess is half the exponent"    exp _ self exponent // 2.    guess _ self timesTwoPower: (0 - exp).    "get eps value"    eps _ guess * Epsilon.    eps _ eps * eps.    delta _ (self - (guess * guess)) / (guess * 2.0).    [(delta * delta) > eps] whileTrue: [        guess _ guess + delta.        delta _ (self - (guess * guess)) / (guess * 2.0)].    ^ guess! !!Float methodsFor: 'mathematical functions'!tan    "Answer the tangent of the receiver taken as an angle in radians."    ^ self sin / self cos! !!Float methodsFor: 'comparing'!< aNumber     "Primitive. Compare the receiver with the argument and return true    if the receiver is less than the argument. Otherwise return false.    Fail if the argument is not a Float. Essential. See Object documentation    whatIsAPrimitive."    <primitive: 43>    ^ (aNumber adaptFloat: self) < aNumber adaptToFloat! !!Float methodsFor: 'comparing'!<= aNumber     "Primitive. Compare the receiver with the argument and return true    if the receiver is less than or equal to the argument. Otherwise return    false. Fail if the argument is not a Float. Optional. See Object    documentation whatIsAPrimitive."    <primitive: 45>    ^ (aNumber adaptFloat: self) <= aNumber adaptToFloat! !!Float methodsFor: 'comparing'!= aNumber     "Primitive. Compare the receiver with the argument and return true    if the receiver is equal to the argument. Otherwise return false.    Fail if the argument is not a Float. Essential. See Object documentation    whatIsAPrimitive."    <primitive: 47>    aNumber isNumber ifFalse: [^ false].    ^ (aNumber adaptFloat: self) = aNumber adaptToFloat! !!Float methodsFor: 'comparing'!> aNumber     "Primitive. Compare the receiver with the argument and return true    if the receiver is greater than the argument. Otherwise return false.    Fail if the argument is not a Float. Essential. See Object documentation    whatIsAPrimitive."    <primitive: 44>    ^ (aNumber adaptFloat: self) > aNumber adaptToFloat! !!Float methodsFor: 'comparing'!>= aNumber     "Primitive. Compare the receiver with the argument and return true    if the receiver is greater than or equal to the argument. Otherwise return    false. Fail if the argument is not a Float. Optional. See Object documentation     whatIsAPrimitive. "    <primitive: 46>    ^ (aNumber adaptFloat: self) >= aNumber adaptToFloat! !!Float methodsFor: 'comparing'!hash    "Hash is reimplemented because = is implemented.     Both words of the double float are used; 8 bits are     removed from each end to clear most of the exponent     regardless of the byte ordering. (Three bitAnd:s are     utilized to assure the intermediate results do not     become a large integer.) Slower than the original     version in the ratios 12:5 to 2:1 depending on values.     Answers the same result on Big Endian and Small Endian     IEEE machines.(DNS, 11 May, 1997) "    ^ (        (            ((self basicAt: 1) bitAnd: 16r00FFFF00) +            ((self basicAt: 2) bitAnd: 16r00FFFF00)        ) bitAnd: 16r00FFFF00      ) >> 8! !!Float methodsFor: 'truncation and round off'!fractionPart    "Primitive. Answer a Float whose value is the difference between the     receiver and the receiver's asInteger value. Optional. See Object     documentation whatIsAPrimitive."    <primitive: 52>    ^self - self truncated asFloat! !!Float methodsFor: 'truncation and round off'!truncated    "Answer with a SmallInteger equal to the value of the receiver without     its fractional part. The primitive fails if the truncated value cannot be     represented as a SmallInteger. In that case, the code below will compute     a LargeInteger truncated value. Essential. See Object documentation     whatIsAPrimitive. "    <primitive: 51>    ^ (self quo: 16383.0) * 16383 + (self rem: 16383.0) truncated! !!Float methodsFor: 'converting'!adaptFraction: aFraction    "If I am involved in arithmetic with a Fraction, convert the Fraction."    ^ aFraction asFloat! !!Float methodsFor: 'converting'!adaptInteger: anInteger    "If I am involved in arithmetic with an Integer, convert the Integer."    ^ anInteger asFloat! !!Float methodsFor: 'converting'!adaptToFraction    "If I am involved in arithmetic with a Fraction, do not convert me."    ^ self! !!Float methodsFor: 'converting'!adaptToInteger    "If I am involved in arithmetic with an Integer, do not convert me."    ^ self! !!Float methodsFor: 'converting'!asApproximateFraction    "Answer a Fraction approximating the receiver. This conversion uses the     continued fraction method to approximate a floating point number."    | num1 denom1 num2 denom2 int frac newD temp |    num1 _ self asInteger.    "The first of two alternating numerators"    denom1 _ 1.        "The first of two alternating denominators"    num2 _ 1.        "The second numerator"    denom2 _ 0.        "The second denominator--will update"    int _ num1.        "The integer part of self"    frac _ self fractionPart.        "The fractional part of self"    [frac = 0]        whileFalse:             ["repeat while the fractional part is not zero"            newD _ 1.0 / frac.            "Take reciprocal of the fractional part"            int _ newD asInteger.        "get the integer part of this"            frac _ newD fractionPart.    "and save the fractional part for next time"            temp _ num2.                "Get old numerator and save it"            num2 _ num1.                "Set second numerator to first"            num1 _ num1 * int + temp.    "Update first numerator"            temp _ denom2.                "Get old denominator and save it"            denom2 _ denom1.            "Set second denominator to first"            denom1 _ int * denom1 + temp.        "Update first denominator"            10000000000.0 < denom1                ifTrue:                     ["Is ratio past float precision?  If so, pick which                     of the two ratios to use"                    num2 = 0.0                         ifTrue: ["Is second denominator 0?"                                ^ Fraction numerator: num1 denominator: denom1].                    ^ Fraction numerator: num2 denominator: denom2]].    "If fractional part is zero, return the first ratio"    denom1 = 1        ifTrue: ["Am I really an Integer?"                ^ num1 "Yes, return Integer result"]        ifFalse: ["Otherwise return Fraction result"                ^ Fraction numerator: num1 denominator: denom1]! !!Float methodsFor: 'converting'!asFraction    ^ self asApproximateFraction ! !!Float methodsFor: 'converting'!asTrueFraction    " Answer a fraction that EXACTLY represents self,      a double precision IEEE floating point number.      (It tears an IEEE float into its components; it      assumes 'correct' byte ordering; runs on PPC.)       Thanks to David N. Smith"    | shifty sign exp fraction |    shifty := ((self at: 1) bitShift: 32) bitOr: (self at: 2).    sign := (shifty bitShift: -63) = 0 ifTrue: [1] ifFalse: [-1].    exp := (shifty >> 52) bitAnd: 16r7FF.    fraction := shifty bitAnd:  16r000FFFFFFFFFFFFF.    (exp = 0) & (fraction = 0) ifTrue: [ ^ 0  ].    fraction := fraction bitOr: 16r0010000000000000.    exp := exp - 16r3FF.    " Validate that the dismemberment was correct "    (sign * fraction / (2 raisedToInteger: 52 - exp)) asFloat = self        ifFalse: [self error: 'asFraction validation failed' ].    ^ sign * fraction / (2 raisedToInteger: 52 - exp)! !!Float methodsFor: 'converting'!isFloat    ^ true! !!Float methodsFor: 'printing'!hex  "If ya really want to know..."    | word nibble |    ^ String streamContents:        [:strm |        1 to: 2 do:            [:i | word _ self at: i.            1 to: 8 do:                 [:s | nibble _ (word bitShift: -8+s*4) bitAnd: 16rF.                strm nextPut: ('0123456789ABCDEF' at: nibble+1)]]]"(-2.0 to: 2.0) collect: [:f | f hex]"! !!Float methodsFor: 'printing'!printOn: aStream base: base    "Estimate significant figures and handle sign."     | digitCount |    digitCount _ 2r1.0e52 floorLog: base asFloat.  "IEEE double -- 52 bits"    self > 0.0        ifTrue: [self absPrintOn: aStream base: base digitCount: digitCount]        ifFalse: [self = 0.0 ifTrue: [^ aStream nextPutAll: '0.0'].                aStream nextPutAll: '-'.                self negated absPrintOn: aStream base: base digitCount: digitCount]! !!Float methodsFor: 'private'!absPrintOn: aStream base: base digitCount: digitCount     "Print me in the given base, using digitCount significant figures."    | fuzz x exp q fBase |    fBase _ base asFloat.    "x is myself normalized to [1.0, fBase), exp is my exponent"    exp _         self < 1.0            ifTrue: [(fBase / self floorLog: fBase) negated]            ifFalse: [self floorLog: fBase].    x _ self / (fBase raisedTo: exp).    fuzz _ fBase raisedTo: 1 - digitCount.    "round the last digit to be printed"    x _ 0.5 * fuzz + x.    x >= fBase        ifTrue:             ["check if rounding has unnormalized x"            x _ x / fBase.            exp _ exp + 1].    (exp < 6 and: [exp > -4])        ifTrue:             ["decimal notation"            q _ 0.            exp < 0 ifTrue: [1 to: 1 - exp do: [:i | aStream nextPut: ('0.0000' at: i)]]]        ifFalse:             ["scientific notation"            q _ exp.            exp _ 0].    [x >= fuzz]        whileTrue:             ["use fuzz to track significance"            i _ x asInteger.            aStream nextPut: (Character digitValue: i).            x _ x - i asFloat * fBase.            fuzz _ fuzz * fBase.            exp _ exp - 1.            exp = -1 ifTrue: [aStream nextPut: $.]].    [exp >= -1]        whileTrue:             [aStream nextPut: $0.            exp _ exp - 1.            exp = -1 ifTrue: [aStream nextPut: $.]].    q ~= 0        ifTrue:             [aStream nextPut: $e.            q printOn: aStream]! !!Float methodsFor: 'private'!timesTwoPower: anInteger     "Primitive. Answer with the receiver multiplied by 2.0 raised    to the power of the argument.    Optional. See Object documentation whatIsAPrimitive."    <primitive: 54>    anInteger < -29 ifTrue: [^ self * (2.0 raisedToInteger: anInteger)].    anInteger < 0 ifTrue: [^ self / (1 bitShift: (0 - anInteger)) asFloat].    anInteger < 30 ifTrue: [^ self * (1 bitShift: anInteger) asFloat].    ^ self * (2.0 raisedToInteger: anInteger)! !!Float class methodsFor: 'class initialization'!initialize        "Float initialize. Float pi"     "Constants from Computer Approximations, pp. 182-183:        Pi = 3.14159265358979323846264338327950288         Pi/2 = 1.57079632679489661923132169163975144         Pi/4 = 0.78539816339744830961566084581987572         Pi*2 = 6.28318530717958647692528676655900576         Pi/180 = 0.01745329251994329576923690768488612         2.0 ln = 0.69314718055994530941723212145817657         2.0 sqrt = 1.41421356237309504880168872420969808"    Pi _ 3.14159265358979323846264338327950288.    Halfpi _ Pi / 2.0.    Fourthpi _ Pi / 4.0.    Twopi _ Pi * 2.0.    RadiansPerDegree _ Pi / 180.0.    Ln2 _ 0.69314718055994530941723212145817657.    Ln10 _ 10.0 ln.    Sqrt2 _ 1.41421356237309504880168872420969808.    E _ 2.718281828459045235360287471353.    Epsilon _ 0.000000000001.  "Defines precision of mathematical functions"    MaxVal _ 1e306.    MinVal _ 1e-306.    MaxValLn _ 704.! !!Float class methodsFor: 'constants'!e    "Answer the constant, E."    ^E! !!FMSound methodsFor: 'accessing'!modulation: mod multiplier: mult    | modInRange multInRange |    modInRange _ mod rounded min: 1023 max: 0.    multInRange _ mult asFloat max: 0.0.    initialModulation _ (modInRange * increment) bitShift: -7.    modulation _ initialModulation.    offsetIncrement _ (increment asFloat * multInRange) rounded.    offsetIndex _ 1.! !!FMSound methodsFor: 'sound generation' stamp: 'jm 9/18/97 17:50'!doControl    super doControl.    modulationDecay ~= 1.0 ifTrue: [        modulation _ (modulationDecay * modulation asFloat) truncated.        modulation > SmallInteger maxVal ifTrue: [modulation _ SmallInteger maxVal]].! !!FMSound methodsFor: 'sound generation' stamp: 'jm 9/18/97 18:34'!mixSampleCount: n into: aSoundBuffer startingAt: startIndex pan: pan    "A simple implementation of Chowning's frequency-modulation synthesis technique. The center frequency is varied as the sound plays by changing the increment by which to step through the wave table."    "FMSound majorScale play"    "(FMSound pitch: 440.0 dur: 1.0 loudness: 200) play"    | lastIndex mySample sample channelIndex |    <primitive: 177>    self var: #aSoundBuffer declareC: 'short int *aSoundBuffer'.    self var: #waveTable declareC: 'short int *waveTable'.    lastIndex _ (startIndex + n) - 1.    startIndex to: lastIndex do: [ :i |        mySample _ (amplitude * (waveTable at: index)) // 1000.        pan > 0 ifTrue: [            channelIndex _ 2 * i.            sample _ (aSoundBuffer at: channelIndex) + ((mySample * pan) // 1000).            sample >  32767 ifTrue: [ sample _  32767 ].  "clipping!!"            sample < -32767 ifTrue: [ sample _ -32767 ].  "clipping!!"            aSoundBuffer at: channelIndex put: sample.        ].        pan < 1000 ifTrue: [            channelIndex _ (2 * i) - 1.            sample _ (aSoundBuffer at: channelIndex) + ((mySample * (1000 - pan)) // 1000).            sample >  32767 ifTrue: [ sample _  32767 ].  "clipping!!"            sample < -32767 ifTrue: [ sample _ -32767 ].  "clipping!!"            aSoundBuffer at: channelIndex put: sample.        ].        index _ index + increment + ((modulation * (waveTable at: offsetIndex)) // 1000000).        index > waveTableSize ifTrue: [            index _ index - waveTableSize.        ].        index < 1 ifTrue: [            index _ index + waveTableSize.        ].        offsetIndex _ offsetIndex + offsetIncrement.        offsetIndex > waveTableSize ifTrue: [            offsetIndex _ offsetIndex - waveTableSize.        ].    ].    count _ count - n.! !!FMSound methodsFor: 'sound generation' stamp: 'jm 9/18/97 17:55'!reset    super reset.    modulation _ initialModulation.! !!FontSet class methodsFor: 'as yet unclassified'!acceptsLoggingOfCompilation    "Dont log sources for my subclasses, so as not to waste time and space    storing printstring versions of the string literals."    ^ self == FontSet! !!FontSet class methodsFor: 'as yet unclassified' stamp: 'di 9/15/97 12:01'!convertFontsNamed: familyName  "FontSet convertFontsNamed: 'Palatino' "    ^ self convertFontsNamed: familyName inDirectoryNamed: ''! !!FontSet class methodsFor: 'as yet unclassified' stamp: 'di 9/15/97 11:48'!convertFontsNamed: familyName inDirectoryNamed: dirName        "FontSet convertFontsNamed: 'Tekton' inDirectoryNamed: 'Tekton Fonts' "    "This utility is for use after you have used BitFont to produce data files     for the fonts you wish to use.  It will read the BitFont files and build    a fontset class from them.  If one already exists, the sizes that can be    found will be overwritten."    "For this utility to work as is, the BitFont data files must be named 'familyNN.BF',    and must reside in the directory named by dirName (use '' for the current directory)."    | f allFontNames className fontSet sizeChars header fontString tempName dir |    "Check first for matching file names and usable FontSet class name."    dir _ dirName isEmpty        ifTrue: [FileDirectory default]        ifFalse: [FileDirectory default directoryNamed: dirName].    allFontNames _ dir fileNamesMatching: familyName , '##.BF'.    allFontNames isEmpty ifTrue: [^ self halt: 'No files found like ' , familyName , 'NN.BF'].    className _ (familyName select: [:c | c isAlphaNumeric]) capitalized asSymbol.    (Smalltalk includesKey: className)        ifTrue: ["Check that this is already a FontSet"                ((fontSet _ Smalltalk at: className) inheritsFrom: self)                    ifFalse: [self halt: 'The name ' , familyName , ' is already in use']]        ifFalse: [fontSet _ self subclass: className                    instanceVariableNames: '' classVariableNames: ''                    poolDictionaries: '' category: self category].    tempName _ 'FontTemp.sf2'.    allFontNames do:        [:fname | Transcript cr; show: fname.        f _ StrikeFont new readFromBitFont: (dir fullNameFor: fname).        f writeAsStrike2named: tempName.        fontString _ (FileStream oldFileNamed: tempName) contentsOfEntireFile.        sizeChars _ (fname copyFrom: familyName size + 1 to: fname size) copyUpTo: $. .        header _ 'sizeNN    ^ self size: NN fromLiteral:' copyReplaceAll: 'NN' with: sizeChars.        fontSet class compile: header , fontString printString            classified: 'font creation' notifying: nil].    FileDirectory default deleteFileNamed: tempName.! !!FontSet class methodsFor: 'as yet unclassified' stamp: 'di 7/2/97 07:42'!fileOut    "FileOut and then change the properties of the file so that it won't be    treated as text by, eg, email attachment facilities"    super fileOut.    (FileStream oldFileNamed: self name , '.st') setFileTypeToObject; close! !!Form methodsFor: 'accessing' stamp: 'tk 3/9/97'!center    "Note that offset is ignored here.  Are we really going to embrace offset?  "    ^ (width @ height) // 2! !!Form methodsFor: 'accessing'!size    "Should no longer be used -- use bitsSize instead.  length of variable part of instance."    ^ super size! !!Form methodsFor: 'copying' stamp: 'tk 7/22/97 15:32'!asColorForm    "Simple conversion of zero pixels to transparent.  Force it to 8 bits."    | f map |    f _ ColorForm extent: self extent depth: 8.    self displayOn: f at: self offset negated.    map _ Color indexedColors copy.    map at: 1 put: Color transparent.    f colors: map.    f offset: self offset.    ^ f! !!Form methodsFor: 'copying'!copy: aRect     "Return a new form which derives from the portion of the original form delineated by aRect."    | newForm |    newForm _ self class extent: aRect extent depth: depth.    ^ newForm copyBits: aRect from: self at: 0@0        clippingBox: newForm boundingBox rule: Form over fillColor: nil! !!Form methodsFor: 'copying'!copy: sourceRectangle from: sourceForm to: destPt rule: rule    ^ self copy: (destPt extent: sourceRectangle extent)        from: sourceRectangle topLeft in: sourceForm rule: rule! !!Form methodsFor: 'displaying' stamp: 'di 7/1/97 14:06'!colormapIfNeededForDepth: destDepth    "Return a colormap for displaying the receiver at the given depth, or nil if no colormap is needed."    depth = destDepth ifTrue: [^ nil].  "not needed if depths are the same"    ^ Color colorMapIfNeededFrom: depth to: destDepth! !!Form methodsFor: 'displaying'!copyBits: sourceRect from: sourceForm at: destOrigin clippingBox: clipRect rule: rule fillColor: aForm map: map    "Make up a BitBlt table and copy the bits.  Use a colorMap."    ((BitBlt         destForm: self        sourceForm: sourceForm        fillColor: aForm        combinationRule: rule        destOrigin: destOrigin        sourceOrigin: sourceRect origin        extent: sourceRect extent        clipRect: clipRect) colorMap: map) copyBits! !!Form methodsFor: 'displaying'!displayOn: aDisplayMedium at: aDisplayPoint clippingBox: clipRectangle rule: rule fillColor: aForm    aDisplayMedium copyBits: self boundingBox        from: self        at: aDisplayPoint + self offset        clippingBox: clipRectangle        rule: rule        fillColor: aForm        map: (self colormapIfNeededForDepth: aDisplayMedium depth).! !!Form methodsFor: 'displaying'!displayOn: aDisplayMedium transformation: displayTransformation clippingBox: clipRectangle align: alignmentPoint with: relativePoint rule: ruleInteger fillColor: aForm     "Graphically, it means nothing to scale a Form by floating point values.      Because scales and other display parameters are kept in floating point to     minimize round off errors, we are forced in this routine to round off to the     nearest integer."    | absolutePoint scale magnifiedForm |    absolutePoint _ displayTransformation applyTo: relativePoint.    absolutePoint _ absolutePoint x asInteger @ absolutePoint y asInteger.    displayTransformation noScale        ifTrue: [magnifiedForm _ self]        ifFalse:             [scale _ displayTransformation scale.            scale _ scale x @ scale y.            (1@1 = scale)                    ifTrue: [scale _ nil. magnifiedForm _ self]                    ifFalse: [magnifiedForm _ self magnify: self boundingBox by: scale]].    magnifiedForm        displayOn: aDisplayMedium        at: absolutePoint - alignmentPoint        clippingBox: clipRectangle        rule: ruleInteger        fillColor: aForm! !!Form methodsFor: 'filling' stamp: 'tk 6/20/96'!colorAt: aPoint    "Return the color in the pixel at the given point.  "    ^ Color         colorFromPixelValue: (self pixelValueAt: aPoint)        depth: depth! !!Form methodsFor: 'filling' stamp: 'tk 6/20/96'!colorAt: aPoint put: aColor    "Store a Color into the pixel at coordinate aPoint.  "    self pixelValueAt: aPoint put: (aColor pixelValueForDepth: depth)."[Sensor anyButtonPressed] whileFalse:    [Display colorAt: Sensor cursorPoint put: Color red]"! !!Form methodsFor: 'filling'!isTransparentAt: aPoint     "Return true if the receiver is transparent at the given point."    depth = 1 ifTrue: [^ false].  "no transparency at depth 1"    ^ (self pixelValueAt: aPoint) = (Color transparent pixelValueForDepth: depth)! !!Form methodsFor: 'filling'!makeBWForm: foregroundColor    "Map this form into a B/W form with 1's in the foreground regions."    | bwForm map |    bwForm _ Form extent: self extent.    map _ self newColorMap.  "All non-foreground go to 0's"    map at: (foregroundColor indexInMap: map) put: 1.    bwForm copyBits: self boundingBox from: self at: 0@0 colorMap: map.    ^ bwForm! !!Form methodsFor: 'filling' stamp: 'tk 7/22/97 16:07'!peripheralColor    "Return most common peripheral color,    as sampled at 4 corners and 3 edges    (this is so that the corners of round rectangles    will win over the edges)"    | perim samples |    perim _ self boundingBox insetBy: (0@0 corner: 1@1).    samples _ #(topLeft topCenter topRight rightCenter bottomRight bottomLeft leftCenter) collect:        [:locName | self pixelValueAt: (perim perform: locName)].    ^ samples asBag sortedCounts first value! !!Form methodsFor: 'filling' stamp: 'tk 6/20/96'!pixelValueAt: aPoint     "Return the raw pixel value at the given point. This pixel value depends on the receiver's depth. Typical clients use colorAt: to get a Color.  "    ^ (BitBlt bitPeekerFromForm: self) pixelAt: aPoint! !!Form methodsFor: 'filling' stamp: 'tk 6/20/96'!pixelValueAt: aPoint put: pixelValue    "Store the given raw pixel value at the given point. Typical clients use colorAt:put: to store a color. "    (BitBlt bitPokerToForm: self) pixelAt: aPoint put: pixelValue.! !!Form methodsFor: 'filling' stamp: 'sw 9/19/96'!shapeFill: aColor interiorPoint: interiorPoint    "Identify the shape (region of identical color) at interiorPoint,    and then fill that shape with the new color, aColor    : modified di's original method such that it returns the bwForm, for potential use by the caller"    | bwForm interiorPixVal map ppd color ind |    depth = 1 ifTrue:        [^ self shapeFill: aColor            seedBlock: [:form | form pixelValueAt: interiorPoint put: 1]].    "First map this form into a B/W form with 0's in the interior region."    interiorPixVal _ self pixelValueAt: interiorPoint.    bwForm _ Form extent: self extent.    map _ Bitmap new: (1 bitShift: (depth min: 12)).  "Not calling newColorMap.  All             non-foreground go to 0.  Length is 2 to 4096."    ppd _ depth.    "256 long color map in depth 8 is not one of the following cases"    3 to: 5 do: [:bitsPerColor |         (2 raisedTo: bitsPerColor*3) = map size             ifTrue: [ppd _ bitsPerColor*3]].    "ready for longer maps than 512"    ppd <= 8        ifTrue: [map at: interiorPixVal+1 put: 1]        ifFalse: [interiorPixVal = 0             ifFalse: [color _ Color colorFromPixelValue: interiorPixVal depth: depth.                ind _ color pixelValueForDepth: ppd.                map at: ind+1 put: 1]            ifTrue: [map at: 1 put: 1]].    bwForm copyBits: self boundingBox from: self at: 0@0 colorMap: map.        "bwForm _ self makeBWForm: interiorColor."    "not work for two whites"    bwForm reverse.  "Make interior region be 0's"    "Now fill the interior region and return that shape"    bwForm _ bwForm findShapeAroundSeedBlock:                    [:form | form pixelValueAt: interiorPoint put: 1].    "Finally use that shape as a mask to flood the region with color"    ((BitBlt destForm: self sourceForm: bwForm         fillColor: nil        combinationRule: Form erase1bitShape    "Cut a hole in the picture with my mask"        destOrigin: bwForm offset         sourceOrigin: 0@0        extent: self extent clipRect: self boundingBox)        colorMap: (Bitmap with: 0 with: 16rFFFFFFFF))        copyBits."    bwForm displayOn: self        at: 0@0        clippingBox: self boundingBox        rule: Form erase1bitShape        fillColor: nil.    "    "(cColor pixelValueForDepth: depth) = 0 ifTrue: [^ bwForm]."    "transparent"    self fillShape: bwForm fillColor: aColor.    ^ bwForm! !!Form methodsFor: 'filling'!shapeFill: aColor seedBlock: seedBlock    depth > 1 ifTrue: [self error: 'This call only meaningful for B/W forms'].    (self findShapeAroundSeedBlock: seedBlock)        displayOn: self at: 0@0 clippingBox: self boundingBox        rule: Form under fillColor: aColor ! !!Form methodsFor: 'bordering'!border: rect width: borderWidth rule: rule fillColor: fillColor        "Paint a border whose rectangular area is defined by rect. Thewidth of the border of each side is borderWidth. Uses fillColor for drawingthe border."        | blt |        blt _ (BitBlt toForm: self) combinationRule: rule; fillColor: fillColor.        blt sourceOrigin: 0@0.        blt destOrigin: rect origin.        blt width: rect width; height: borderWidth; copyBits.        blt destY: rect corner y - borderWidth; copyBits.        blt destY: rect origin y + borderWidth.        blt height: rect height - borderWidth - borderWidth; width:borderWidth; copyBits.        blt destX: rect corner x - borderWidth; copyBits! !!Form methodsFor: 'bordering'!borderFormOfWidth: borderWidth sharpCorners: sharpen    "Smear this form around and then subtract the original to produce    an outline.  If sharpen is true, then cause right angles to be outlined    by right angles (takes an additional diagonal smears ANDed with both    horizontal and vertical smears)."    | smearForm bigForm smearPort all cornerForm cornerPort nbrs |    depth > 1 ifTrue: [self halt]. "Only meaningful for B/W forms."    bigForm _ self deepCopy.    all _ bigForm boundingBox.    smearForm _ Form extent: self extent.    smearPort _ BitBlt toForm: smearForm.    sharpen ifTrue:        [cornerForm _ Form extent: self extent.        cornerPort _ BitBlt toForm: cornerForm].    nbrs _ (0@0) fourNeighbors.    1 to: borderWidth do:        [:i |  "Iterate to get several layers of 'skin'"        nbrs do:            [:d |  "Smear the self in 4 directions to grow each layer of skin"            smearPort copyForm: bigForm to: d rule: Form under].        sharpen ifTrue:            ["Special treatment to smear sharp corners"            nbrs with: ((2 to: 5) collect: [:i2 | nbrs atWrap: i2]) do:                [:d1 :d2 |                "Copy corner points diagonally"                cornerPort copyForm: bigForm to: d1+d2 rule: Form over.                "But only preserve if there were dots on either side"                cornerPort copyForm: bigForm to: d1+d1+d2 rule: Form and.                cornerPort copyForm: bigForm to: d1+d2+d2 rule: Form and.                smearPort copyForm: cornerForm to: 0@0 rule: Form under].            ].        bigForm copy: all from: 0@0 in: smearForm rule: Form over.        ].    "Now erase the original shape to obtain the outline"    bigForm copy: all from: 0@0 in: self rule: Form erase.    ^ bigForm! !!Form methodsFor: 'bordering'!borderWidth: anInteger     "Set the width of the border for the receiver to be anInteger and paint it     using black as the border color."    self border: self boundingBox width: anInteger fillColor: Color black! !!Form methodsFor: 'bordering'!shapeBorder: aColor width: borderWidth interiorPoint: interiorPoint    sharpCorners: sharpen internal: internal    "Identify the shape (region of identical color) at interiorPoint,    and then add an outline of width=borderWidth and color=aColor.    If sharpen is true, then cause right angles to be outlined by    right angles.  If internal is true, then produce a border that lies    within the identified shape.  Thus one can put an internal border    around the whole background, thus effecting a normal border    around every other foreground image."    | shapeForm borderForm interiorColor |    "First identify the shape in question as a B/W form"    interiorColor _ self colorAt: interiorPoint.    shapeForm _ (self makeBWForm: interiorColor) reverse                findShapeAroundSeedBlock:                    [:form | form pixelValueAt: interiorPoint put: 1].    "Reverse the image to grow the outline inward"    internal ifTrue: [shapeForm reverse].    "Now find the border fo that shape"    borderForm _ shapeForm borderFormOfWidth: borderWidth sharpCorners: sharpen.    "Finally use that shape as a mask to paint the border with color"    self fillShape: borderForm fillColor: aColor! !!Form methodsFor: 'scaling, rotation'!flipBy: direction centerAt: aPoint    "Return a copy of the receiver flipped either #vertical or #horizontal."    | newForm quad |    newForm _ Form extent: self extent depth: depth.    quad _ self boundingBox innerCorners.    quad _ (direction = #vertical ifTrue: [#(2 1 4 3)] ifFalse: [#(4 3 2 1)])        collect: [:i | quad at: i].    (WarpBlt toForm: newForm)        sourceForm: self;        colorMap: (self colormapIfNeededForDepth: depth);        combinationRule: 3;        copyQuad: quad toRect: newForm boundingBox.    newForm offset: (self offset flipBy: direction centerAt: aPoint).    ^ newForm"[Sensor anyButtonPressed] whileFalse:    [((Form fromDisplay: (Sensor cursorPoint extent: 130@66))            flipBy: #vertical centerAt: 0@0) display]""Consistency test... | f f2 p | [Sensor anyButtonPressed] whileFalse:    [f _ Form fromDisplay: ((p _ Sensor cursorPoint) extent: 31@41).    Display fillBlack: (p extent: 31@41).    f2 _ f flipBy: #vertical centerAt: 0@0.    (f2 flipBy: #vertical centerAt: 0@0) displayAt: p]"! !!Form methodsFor: 'scaling, rotation'!magnify: aRectangle by: scale     "Answer a Form created as a scaling of the receiver.    Scale may be a Float, and may be greater or less than 1.0."    ^ self magnify: aRectangle by: scale smoothing: 1"Dynamic test...[Sensor anyButtonPressed] whileFalse:    [(Display magnify: (Sensor cursorPoint extent: 31@41) by: 5@3) display]""Scaling test...| f cp | f _ Form fromDisplay: (Rectangle originFromUser: 100@100).Display restoreAfter: [Sensor waitNoButton.[Sensor anyButtonPressed] whileFalse:    [cp _ Sensor cursorPoint.    (f magnify: f boundingBox by: (cp x asFloat@cp y asFloat)/f extent) display]]""Consistency test... | f f2 p | [Sensor anyButtonPressed] whileFalse:    [f _ Form fromDisplay: ((p _ Sensor cursorPoint) extent: 31@41).    Display fillBlack: (p extent: 31@41).    f2 _ f magnify: f boundingBox by: 5@3.    (f2 shrink: f2 boundingBox by: 5@3) displayAt: p]"! !!Form methodsFor: 'scaling, rotation'!magnify: aRectangle by: scale smoothing: cellSize    "Answer a Form created as a scaling of the receiver.    Scale may be a Float, and may be greater or less than 1.0."    | newForm |    newForm _ Form extent: (aRectangle extent * scale) truncated depth: depth.    (WarpBlt toForm: newForm)        sourceForm: self;        colorMap: (self colormapIfNeededForDepth: depth);        cellSize: cellSize;  "installs a new colormap if cellSize > 1"        combinationRule: 3;        copyQuad: aRectangle innerCorners toRect: newForm boundingBox.    ^ newForm"Dynamic test...[Sensor anyButtonPressed] whileFalse:    [(Display magnify: (Sensor cursorPoint extent: 131@81) by: 0.5 smoothing: 2) display]""Scaling test...| f cp | f _ Form fromDisplay: (Rectangle originFromUser: 100@100).Display restoreAfter: [Sensor waitNoButton.[Sensor anyButtonPressed] whileFalse:    [cp _ Sensor cursorPoint.    (f magnify: f boundingBox by: (cp x asFloat@cp y asFloat)/f extent smoothing: 2) display]]"! !!Form methodsFor: 'scaling, rotation'!rotateBy: deg    "Rotate the receiver by the indicated number of degrees."    "rot is the destination form, bit enough for any angle."    ^ self rotateBy: deg smoothing: 1" | a f |  f _ Form fromDisplay: (0@0 extent: 200@200).  a _ 0.[Sensor anyButtonPressed] whileFalse:    [((Form fromDisplay: (Sensor cursorPoint extent: 130@66))        rotateBy: (a _ a+5)) display].f display"! !!Form methodsFor: 'scaling, rotation'!rotateBy: direction centerAt: aPoint    "Return a rotated copy of the receiver.     direction = #right, #left, or #pi"    | newForm quad rot |    newForm _ self class extent: (direction = #pi ifTrue: [width@height]                                            ifFalse: [height@width]) depth: depth.    quad _ self boundingBox innerCorners.    rot _ #(right pi left) indexOf: direction.    (WarpBlt toForm: newForm)        sourceForm: self;        colorMap: (self colormapIfNeededForDepth: depth);        combinationRule: 3;        copyQuad: ((1+rot to: 4+rot) collect: [:i | quad atWrap: i])             toRect: newForm boundingBox.    newForm offset: (self offset rotateBy: direction centerAt: aPoint).    ^ newForm"[Sensor anyButtonPressed] whileFalse:    [((Form fromDisplay: (Sensor cursorPoint extent: 130@66))        rotateBy: #left centerAt: 0@0) display]""Consistency test... | f f2 p | [Sensor anyButtonPressed] whileFalse:    [f _ Form fromDisplay: ((p _ Sensor cursorPoint) extent: 31@41).    Display fillBlack: (p extent: 31@41).    f2 _ f rotateBy: #left centerAt: 0@0.    (f2 rotateBy: #right centerAt: 0@0) displayAt: p]"! !!Form methodsFor: 'scaling, rotation' stamp: 'tk 3/26/97'!rotateBy: deg magnify: scale smoothing: cellSize    "Rotate the receiver by the indicated number of degrees and magnify.  "    "rot is the destination form, big enough for any angle."    | side rot warp r1 pts p bigSide |    side _ 1 + ((width*width) + (height*height)) asFloat sqrt asInteger.    bigSide _ (side * scale) rounded.    rot _ Form extent: bigSide@bigSide depth: self depth.    warp _ (WarpBlt toForm: rot)        sourceForm: self;        colorMap: (self colormapIfNeededForDepth: depth);        cellSize: cellSize;  "installs a new colormap if cellSize > 1"        combinationRule: Form paint.    r1 _ (0@0 extent: side@side) align: (side@side)//2 with: self boundingBox center.    "Rotate the corners of the source rectangle."     pts _ r1 innerCorners collect:        [:pt | p _ pt - r1 center.        (r1 center x asFloat + (p x asFloat*deg degreeCos) + (p y asFloat*deg degreeSin)) @        (r1 center y asFloat - (p x asFloat*deg degreeSin) + (p y asFloat*deg degreeCos))].    warp copyQuad: pts toRect: rot boundingBox.    ^ rot" | a f |  f _ Form fromDisplay: (0@0 extent: 200@200).  a _ 0.[Sensor anyButtonPressed] whileFalse:    [((Form fromDisplay: (Sensor cursorPoint extent: 130@66))        rotateBy: (a _ a+5) magnify: 0.75 smoothing: 2) display].f display"! !!Form methodsFor: 'scaling, rotation' stamp: 'sw 8/9/96'!rotateBy: deg rotationCenter: aPoint    "Rotate the receiver by the indicated number of degrees.  This variant gets a rotation center, but in fact ignores the thing -- awaiting someone's doing the right thing.       Note that rotationCenter should now be easy to include in the offset of the resulting form -- see <Point> rotateBy: angle about: center.  Could be even faster by sharing the sin, cos inside rotateBy:.  This should really be reversed so that this becomes the workhorse, and rotateBy: calls this with rotationCenter: self boundingBox center.  And while we're at it, why not include scaling?   "    ^ self rotateBy: deg smoothing: 1! !!Form methodsFor: 'scaling, rotation'!rotateBy: deg smoothing: cellSize    "Rotate the receiver by the indicated number of degrees."    "rot is the destination form, bit enough for any angle."    | side rot warp r1 pts p center |    side _ 1 + ((width*width) + (height*height)) asFloat sqrt asInteger.    rot _ Form extent: side@side depth: self depth.    center _ rot extent // 2.    "Now compute the sin and cos constants for the rotation angle."     warp _ (WarpBlt toForm: rot)        sourceForm: self;        colorMap: (self colormapIfNeededForDepth: depth);        cellSize: cellSize;  "installs a new colormap if cellSize > 1"        combinationRule: Form over.    r1 _ rot boundingBox align: center with: self boundingBox center.    pts _ r1 innerCorners collect:        [:pt | p _ pt - r1 center.        (r1 center x asFloat + (p x asFloat*deg degreeCos) + (p y asFloat*deg degreeSin)) @        (r1 center y asFloat - (p x asFloat*deg degreeSin) + (p y asFloat*deg degreeCos))].    warp copyQuad: pts toRect: rot boundingBox.    ^ rot" | a f |  f _ Form fromDisplay: (0@0 extent: 200@200).  a _ 0.[Sensor anyButtonPressed] whileFalse:    [((Form fromDisplay: (Sensor cursorPoint extent: 130@66))        rotateBy: (a _ a+5) smoothing: 2) display].f display"! !!Form methodsFor: 'scaling, rotation'!shrink: aRectangle by: scale     | scalePt |    scalePt _ scale asPoint.    ^ self magnify: aRectangle by: (1.0 / scalePt x asFloat) @ (1.0 / scalePt y asFloat)! !!Form methodsFor: 'scaling, rotation'!xmagnify: aRectangle by: scale smoothing: cellSize    "Answer a Form created as a scaling of the receiver.    Scale may be a Float, and may be greater or less than 1.0."    | newForm |    newForm _ Form extent: (aRectangle extent * scale) truncated depth: depth.    (WarpBlt toForm: newForm)        sourceForm: self;        colorMap: (self colormapIfNeededForDepth: depth);        cellSize: cellSize;  "installs a new colormap if cellSize > 1"        combinationRule: 3;        clipRect: (Sensor cursorPoint extent: 20@20);        copyQuad: aRectangle innerCorners toRect: newForm boundingBox.    ^ newForm"Dynamic test...[Sensor anyButtonPressed] whileFalse:    [(Display xmagnify: Display boundingBox by: 0.1 smoothing: 1) display]""Scaling test...| f cp | f _ Form fromDisplay: (Rectangle originFromUser: 100@100).Display restoreAfter: [Sensor waitNoButton.[Sensor anyButtonPressed] whileFalse:    [cp _ Sensor cursorPoint.    (f magnify: f boundingBox by: (cp x asFloat@cp y asFloat)/f extent smoothing: 2) display]]"! !!Form methodsFor: 'fileIn/Out' stamp: 'jm 9/18/97 23:13'!storeOn: aStream base: anInteger     "Store the receiver out as an expression that can be evaluated to recreate a Form with the same contents as the original."    aStream nextPut: $(.    aStream nextPutAll: self species name.    aStream crtab: 1.    aStream nextPutAll: 'extent: '.    self extent printOn: aStream.    aStream crtab: 1.    aStream nextPutAll: 'depth: '.    self depth printOn: aStream.    aStream crtab: 1.    aStream nextPutAll: 'fromArray: #('.    1 to: bits size do: [:index |         anInteger = 10            ifTrue: [aStream space]            ifFalse: [aStream crtab: 2].        (self bits at: index) printOn: aStream base: anInteger].    aStream nextPut: $).    aStream crtab: 1.    aStream nextPutAll: 'offset: '.    self offset printOn: aStream.    aStream nextPut: $).! !!Form methodsFor: 'fileIn/Out' stamp: 'di 9/19/97 14:55'!writeBMPfileNamed: fName  "Display writeBMPfileNamed: 'display'"    | fileName bhSize biSize biClrUsed f biSizeImage bfOffBits rowBytes rgb data |    (#(1 4 8 32) includes: depth) ifFalse: [self halt  "depth must be one of these"].    ((fileName _ fName) asUppercase endsWith: '.BMP')        ifFalse: [fileName _ fName , '.BMP'].    bhSize _ 14.  "# bytes in file header"    biSize _ 40.  "info header size in bytes"     biClrUsed _ depth = 32 ifTrue: [0] ifFalse:[1 << depth].  "No. color table entries"    bfOffBits _ biSize + bhSize + (4*biClrUsed).    rowBytes _ ((depth min: 24) * width + 31 // 32) * 4.    biSizeImage _ height * rowBytes.     f _ (FileStream newFileNamed: fileName) binary.    "Write the file header"    f position: 0.    f nextLitteEndianNumber: 2 put: 19778.  "bfType = BM"     f nextLitteEndianNumber: 4 put: bfOffBits + biSizeImage.  "Entire file size in bytes"    f nextLitteEndianNumber: 4 put: 0.  "bfReserved"     f nextLitteEndianNumber: 4 put: bfOffBits.  "Offset of bitmap data from start of hdr (and file)"    "Write the bitmap info header"    f position: bhSize.    f nextLitteEndianNumber: 4 put: biSize.  "info header size in bytes"     f nextLitteEndianNumber: 4 put: width.  "biWidth"     f nextLitteEndianNumber: 4 put: height.  "biHeight"     f nextLitteEndianNumber: 2 put: 1.  "biPlanes"     f nextLitteEndianNumber: 2 put: (depth min: 24).  "biBitCount"     f nextLitteEndianNumber: 4 put: 0.  "biCompression"     f nextLitteEndianNumber: 4 put: biSizeImage.  "size of image section in bytes"    f nextLitteEndianNumber: 4 put: 2800.  "biXPelsPerMeter"     f nextLitteEndianNumber: 4 put: 2800.  "biYPelsPerMeter"     f nextLitteEndianNumber: 4 put: biClrUsed.    f nextLitteEndianNumber: 4 put: 0.  "biClrImportant"     1 to: biClrUsed do:  "Color map"        [:i | rgb _ (Color indexedColors at: i) pixelValueForDepth: 32.        0 to: 24 by: 8 do: [:j | f nextPut: (rgb >> j bitAnd: 16rFF)]].    'Writing image data' displayProgressAt: Sensor cursorPoint        from: 1 to: height during: [:bar |            1 to: height do:                [:i | bar value: i.                data _ (self copy: (0@(height-i) extent: width@1)) bits.                depth = 32                ifTrue: [1 to: data size do: [:j | f nextLitteEndianNumber: 3 put: (data at: j)].                        1 to: (data size*3)+3//4*4-(data size*3) do: [:j | f nextPut: 0 "pad to 32-bits"]]                ifFalse: ["1 to: data size do: [:j | f nextNumber: 4 put: (data at: j)]"                        f nextPutAll: data]]].    f position = (bfOffBits + biSizeImage) ifFalse: [self halt].    f close.! !!Form methodsFor: 'private' stamp: 'di 9/23/97 14:36'!hackBits: bitThing    "This method provides an initialization so that BitBlt may be used, eg, to     copy ByteArrays and other non-pointer objects efficiently.    The resulting form looks 4 wide, 8 deep, and bitThing-size-in-words high."    width _ 4.    depth _ 8.    bitThing class isBits ifFalse: [self error: 'bitThing must be a non-pointer object'].    bitThing class isBytes        ifTrue: [height _ bitThing size // 4]        ifFalse: [height _ bitThing size].    bits _ bitThing! !!Form methodsFor: 'private'!initFromArray: array    "Fill the bitmap from array.  If the array is shorter,    then cycle around in its contents until the bitmap is filled."    | ax aSize array32 i j word16 |    ax _ 0.    aSize _ array size.    aSize > bits size ifTrue:        ["backward compatibility with old 16-bit bitmaps and their forms"        array32 _ Array new: height * (width + 31 // 32).        i _ j _ 0.        1 to: height do:            [:y | 1 to: width+15//16 do:                [:x16 | word16 _ array at: (i _ i + 1).                x16 odd ifTrue: [array32 at: (j _ j+1) put: (word16 bitShift: 16)]                        ifFalse: [array32 at: j put: ((array32 at: j) bitOr: word16)]]].        ^ self initFromArray: array32].    1 to: bits size do:        [:index |        (ax _ ax + 1) > aSize ifTrue: [ax _ 1].        bits at: index put: (array at: ax)]! !!Form methodsFor: 'private' stamp: '6/9/97 16:10 di'!setExtent: extent depth: bitsPerPixel    "Create a virtual bit map with the given extent and bitsPerPixel."    width _ extent x asInteger.    width < 0 ifTrue: [width _ 0].    height _ extent y asInteger.    height < 0 ifTrue: [height _ 0].    depth _ bitsPerPixel.    bits _ Bitmap new: self bitsSize! !!Form methodsFor: 'other' stamp: 'tk 5/4/97'!newColorMap     "Return an uninitialized color map array appropriate to this depth form.    Default is 4096 long for color.  32k maps are possible later.  "    ^ Bitmap new: (1 bitShift: (depth min: 12))! !!Form methodsFor: 'other' stamp: 'jm 6/30/97 18:47'!removeZeroPixelsFrom16BitForm    | cm |    depth = 16 ifFalse: [self error: 'this method is only for 16-bit forms'].    cm _ Bitmap new: (1 bitShift: 15).    1 to: cm size do: [:i | cm at: i put: i - 1].    cm at: 1 put: 1.    (BitBlt toForm: self)        sourceForm: self;        sourceOrigin: 0@0;        combinationRule: Form paint;        destX: 0 destY: 0 width: width height: height;        colorMap: cm;        copyBits! !!Form methodsFor: 'transitions'!pageImage: otherImage at: topLeft corner: corner    "Produce a page-turning illusion that gradually reveals otherImage    located at topLeft in this form.  Corner specifies which corner, as        1=topLeft, 2=topRight, 3=bottomRight, 4=bottomLeft."    | bb maskForm resultForm delta maskLoc maskRect stepSize cornerSel smallRect |    stepSize _ 10.    bb _ otherImage boundingBox.    resultForm _ self copy: (topLeft extent: bb extent).    maskForm _ Form extent: ((otherImage width min: otherImage height) + stepSize) asPoint.    "maskLoc _ starting loc rel to topLeft"    otherImage width > otherImage height        ifTrue: ["wide image; motion is horizontal."                (corner between: 2 and: 3) not ifTrue:                    ["motion is to the right"                    delta _ 1@0.                    maskLoc _ bb topLeft - (corner = 1                        ifTrue: [maskForm width@0]                        ifFalse: [maskForm width@stepSize])]                    ifFalse:                    ["motion is to the left"                    delta _ -1@0.                    maskLoc _ bb topRight - (corner = 2                        ifTrue: [0@0]                        ifFalse: [0@stepSize])]]        ifFalse: ["tall image; motion is vertical."                corner <= 2 ifTrue:                    ["motion is downward"                    delta _ 0@1.                    maskLoc _ bb topLeft - (corner = 1                        ifTrue: [0@maskForm height]                        ifFalse: [stepSize@maskForm height])]                    ifFalse:                    ["motion is upward"                    delta _ 0@-1.                    maskLoc _ bb bottomLeft - (corner = 3                        ifTrue: [stepSize@0]                        ifFalse: [0@0])]].    "Build a solid triangle in the mask form"    (Pen newOnForm: maskForm) do: [:p |        corner even  "Draw 45-degree line"            ifTrue: [p place: 0@0; turn: 135; go: maskForm width*3//2]            ifFalse: [p place: 0@(maskForm height-1); turn: 45; go: maskForm width*3//2]].    maskForm smear: delta negated distance: maskForm width.    "Copy the mask to full resolution for speed.  Make it be the reversed    so that it can be used for ORing in the page-corner color"    maskForm _ (Form extent: maskForm extent depth: otherImage depth)        copyBits: maskForm boundingBox from: maskForm at: 0@0        colorMap: (Bitmap with: 16rFFFFFFFF with: 0).    "Now move the triangle maskForm across the resultForm selecting the    triangular part of otherImage to display, and across the resultForm,    selecting the part of the original image to erase."    cornerSel _ #(topLeft topRight bottomRight bottomLeft) at: corner.    1 to: (otherImage width + otherImage height // stepSize)+1 do:        [:i |        "Determine the affected square"        maskRect _ (maskLoc extent: maskForm extent) intersect: bb.        ((maskLoc x*delta x) + (maskLoc y*delta y)) < 0 ifTrue:            [smallRect _ 0@0 extent: (maskRect width min: maskRect height) asPoint.            maskRect _ smallRect align: (smallRect perform: cornerSel)                                with: (maskRect perform: cornerSel)].        "AND otherForm with triangle mask, and OR into result"        resultForm copyBits: bb from: otherImage at: 0@0                clippingBox: maskRect rule: Form over fillColor: nil.        resultForm copyBits: maskForm boundingBox from: maskForm at: maskLoc                clippingBox: maskRect rule: Form erase fillColor: nil.        resultForm copyBits: maskForm boundingBox from: maskForm at: maskLoc                clippingBox: maskRect rule: Form under fillColor: Color lightBrown.        "Now update Display in a single BLT."        self copyBits: maskRect from: resultForm at: topLeft + maskRect topLeft                clippingBox: self boundingBox rule: Form over fillColor: nil.        maskLoc _ maskLoc + (delta*stepSize)]"1 to: 4 do: [:corner | Display pageImage:                (Form fromDisplay: (10@10 extent: 200@300)) reverse            at: 10@10 corner: corner]"! !!Form class methodsFor: 'instance creation'!dotOfSize: diameter    "Create a form which contains a round black dot."    | radius form bite |    radius _ diameter//2.    form _ Form extent: diameter@diameter offset: (0@0) - (radius@radius).        diameter <= 9 ifTrue: "special case for speed"        [form fillBlack.        bite _ diameter//3.        form fillWhite: (0@0 extent: bite@1).        form fillWhite: (0@(diameter-1) extent: bite@1).        form fillWhite: (diameter-bite@0 extent: bite@1).        form fillWhite: (diameter-bite@(diameter-1) extent: bite@1).        form fillWhite: (0@0 extent: 1@bite).        form fillWhite: (0@(diameter-bite) extent: 1@bite).        form fillWhite: (diameter-1@0 extent: 1@bite).        form fillWhite: (diameter-1@(diameter-bite) extent: 1@bite).        ^ form].    radius _ diameter-1//2.  "so circle fits entirely"    (Circle new center: radius@radius radius: radius) displayOn: form.    form convexShapeFill: Color black.    "fill the circle with black"    ^ form    "(Form dotOfSize: 8) displayAt: Sensor cursorPoint"! !!Form class methodsFor: 'instance creation' stamp: 'jm 9/18/97 23:13'!extent: extentPoint depth: bitsPerPixel fromArray: anArray offset: offsetPoint     "Answer an instance of me with a pixmap of the given depth initialized from anArray."    ^ (self basicNew setExtent: extentPoint depth: bitsPerPixel)        offset: offsetPoint;        initFromArray: anArray! !!Form class methodsFor: 'instance creation' stamp: 'jm 10/4/97 13:32'!fromBMPFileNamed: fileName    "Read a Form from a Windows bitmap (BMP-format) file with the given name."    "Form fromBMPFileNamed: 'test.bmp'"    | f bfType bfSize bfReserved bfOffBits biSize biWidth biHeight      biPlanes biBitCount biCompression form pixelLine pixIndex rgb rowBytes line |    f _ (FileStream oldFileNamed: fileName) binary.    bfType _ f nextLitteEndianNumber: 2.    bfSize _ f nextLitteEndianNumber: 4.    bfReserved _ f nextLitteEndianNumber: 4.    bfOffBits _ f nextLitteEndianNumber: 4.    biSize _ f nextLitteEndianNumber: 4.    biWidth _ f nextLitteEndianNumber: 4.    biHeight _ f nextLitteEndianNumber: 4.    biPlanes _ f nextLitteEndianNumber: 2.    biBitCount _ f nextLitteEndianNumber: 2.    biCompression _ f nextLitteEndianNumber: 4.    f nextLitteEndianNumber: 4.  "biSizeImage"    f nextLitteEndianNumber: 4.  "biXPelsPerMeter"    f nextLitteEndianNumber: 4.  "biYPelsPerMeter"    f nextLitteEndianNumber: 4.  "biClrUsed"    f nextLitteEndianNumber: 4.  "biClrImportant"    ((bfType = 19778) & (bfReserved = 0) & (biPlanes = 1) &     (biSize = 40) & (bfSize <= f size))        ifFalse: [self error: 'Bad BMP file header'].    biCompression = 0        ifFalse: [self error: 'Can currently only read uncompressed BMP files'].    f position: bfOffBits.  "Skip past any color map to the image data"    form _ Form extent: biWidth@biHeight                depth: (biBitCount = 24 ifTrue: [32] ifFalse: [biBitCount]).    rowBytes _ (biBitCount * biWidth + 31 // 32) * 4.    line _ Form extent: biWidth@1 depth: form depth.    1 to: biHeight do: [:i |        biBitCount = 24        ifTrue: [pixelLine _ f next: rowBytes.                pixIndex _ 1.                1 to: biWidth do: [:j |                    rgb _ (pixelLine at: pixIndex) +                           ((pixelLine at: pixIndex + 1) bitShift: 8) +                           ((pixelLine at: pixIndex + 2) bitShift: 16).                    line bits at: j put: rgb.                    pixIndex _ pixIndex + 3]]        ifFalse: [line bits copyFromByteArray: (f next: rowBytes)].        form copy: line boundingBox from: line to: 0@(biHeight-i) rule: Form over].    f close.    ^ form! !!Form class methodsFor: 'mode constants'!erase1bitShape    "Answer the integer denoting mode erase."    ^ 26! !!Form class methodsFor: 'mode constants'!oldErase1bitShape    "Answer the integer denoting mode erase."    ^ 17! !!Form class methodsFor: 'mode constants'!oldPaint    "Answer the integer denoting the 'paint' combination rule."    ^16! !!Form class methodsFor: 'mode constants'!paint    "Answer the integer denoting the 'paint' combination rule."    ^25! !!Form class methodsFor: 'examples' stamp: 'jm 9/21/97 18:07'!toothpaste: diam        "Display restoreAfter: [Form toothpaste: 30]"    "Draws wormlike lines by laying down images of spheres.    See Ken Knowlton, Computer Graphics, vol. 15 no. 4 p352.    Draw with mouse button down; terminate by option-click."    | facade ball filter point queue port color q colors colr colr2 |    colors _ Display depth = 1        ifTrue: [Array with: Color black]        ifFalse: [Color red wheel: 12].    facade _ Form extent: diam@diam offset: (diam//-2) asPoint.    (Form dotOfSize: diam) displayOn: facade            at: (diam//2) asPoint clippingBox: facade boundingBox            rule: Form under fillColor: Color white.    #(1 2 3) do:        [:x |  "simulate facade by circles of gray"        (Form dotOfSize: x*diam//5) displayOn: facade            at: (diam*2//5) asPoint clippingBox: facade boundingBox            rule: Form under            fillColor: (Color perform:                     (#(black gray lightGray) at: x)).        "facade displayAt: 50*x@50"].    ball _ Form dotOfSize: diam.    color _ 8.    [ true ] whileTrue:        [port _ BitBlt toForm: Display.        "Expand 1-bit forms to any pixel depth"        port colorMap: (Bitmap with: 0 with: 16rFFFFFFFF).        queue _ OrderedCollection new: 32.        16 timesRepeat: [queue addLast: -20@-20].        Sensor waitButton.        Sensor yellowButtonPressed ifTrue: [^ self].        filter _ Sensor cursorPoint.        colr _ colors atWrap: (color _ color + 5).  "choose increment relatively prime to colors size"        colr2 _ colr mixed: 0.3 with: Color white.        [Sensor redButtonPressed or: [queue size > 0]] whileTrue:            [filter _ filter * 4 + Sensor cursorPoint // 5.            point _ Sensor redButtonPressed                ifTrue: [filter] ifFalse: [-20@-20].            port copyForm: ball to: point rule: Form paint fillColor: colr.            (q _ queue removeFirst) == nil ifTrue: [^ self].    "exit"            Display depth = 1                ifTrue: [port copyForm: facade to: q rule: Form erase]                ifFalse: [port copyForm: facade to: q rule: Form paint fillColor: colr2].            Sensor redButtonPressed ifTrue: [queue addLast: point]]].! !!FormCanvas methodsFor: 'accessing'!depth    ^ form depth! !!FormCanvas methodsFor: 'accessing'!extent    ^ form extent! !!FormCanvas methodsFor: 'accessing'!form    ^ form! !!FormCanvas methodsFor: 'drawing'!fillColor: c    "Note: This always fills, even if the color is transparent."    port combinationRule: Form over.    port fillRect: form boundingBox color: (self drawColor: c).! !!FormCanvas methodsFor: 'drawing'!fillOval: r color: c    c isTransparent ifFalse: [        port combinationRule: (self drawRule: Form over).        port fillOval: (r translateBy: origin)            color: (self drawColor: c)            borderWidth: 0            borderColor: nil].! !!FormCanvas methodsFor: 'drawing'!fillOval: r color: c borderWidth: borderWidth borderColor: borderColor    | rect fillC borderC |    rect _ r.    c isTransparent        ifTrue: [fillC _ nil]        ifFalse: [fillC _ self drawColor: c].    borderColor isTransparent        ifTrue: [            fillC == nil ifTrue: [^ self].  "both border and fill are transparent"            borderC _ nil.            rect _ rect insetBy: borderWidth.        ] ifFalse: [borderC _ self drawColor: borderColor].    port combinationRule: (self drawRule: Form over).    port fillOval: (rect translateBy: origin)        color: fillC        borderWidth: borderWidth        borderColor: borderC.! !!FormCanvas methodsFor: 'drawing'!fillRectangle: r color: c    c isTransparent ifFalse: [        port combinationRule: (self drawRule: Form over).        port fillRect: (r translateBy: origin) color: (self drawColor: c)].! !!FormCanvas methodsFor: 'drawing'!frameAndFillRectangle: r fillColor: fillColor borderWidth: borderWidth borderColor: borderColor    | outerRect |    port combinationRule: (self drawRule: Form over).    outerRect _ r translateBy: origin.    borderColor isTransparent ifFalse: [        "draw border of rectangle"        (r area > 10000 or: [fillColor isTransparent]) ifTrue: [            port frameRect: outerRect                borderWidth: borderWidth                borderColor: (self drawColor: borderColor).        ] ifFalse: [            "for small rectangles, it's faster to paint the whole outerRect             than to compute and fill the border rects"            port fillRect: outerRect color: (self drawColor: borderColor)]].    "fill inside of rectangle"    fillColor isTransparent ifFalse: [        port fillRect: (outerRect insetBy: borderWidth)             color: (self drawColor: fillColor)].! !!FormCanvas methodsFor: 'drawing'!frameAndFillRectangle: r fillColor: fillColor borderWidth: borderWidth topLeftColor: topLeftColor bottomRightColor: bottomRightColor    | rect |    "First use quick code for fill and top, left borders"    self frameAndFillRectangle: r        fillColor: fillColor        borderWidth: borderWidth        borderColor: topLeftColor.    "Now use slow code for bevelled bottom, right borders"    borderWidth isInteger        ifTrue: [port width: borderWidth; height: borderWidth]        ifFalse: [port width: borderWidth x; height: borderWidth y].    rect _ r translateBy: origin.    bottomRightColor isTransparent ifFalse: [        port fillColor: (self drawColor: bottomRightColor);            frameRectRight: rect;            frameRectBottom: rect].! !!FormCanvas methodsFor: 'drawing'!frameOval: r width: w color: borderColor    port combinationRule: (self drawRule: Form over).    port fillOval: (r translateBy: origin)        color: nil        borderWidth: w        borderColor: (self drawColor: borderColor).! !!FormCanvas methodsFor: 'drawing'!frameRectangle: r width: w color: c    c isTransparent ifFalse: [        port combinationRule: (self drawRule: Form over).        port frameRect: r            borderWidth: w            borderColor: (self drawColor: c)].! !!FormCanvas methodsFor: 'drawing'!image: aForm at: aPoint    "Draw the given Form, which is assumed to be a Form following the convention that zero is the transparent pixel value."    | bb |    bb _ BitBlt destForm: port destForm        sourceForm: aForm        fillColor: nil        combinationRule: Form paint        destOrigin: aPoint + origin        sourceOrigin: 0@0        extent: aForm extent        clipRect: clipRect truncated.    shadowDrawing ifTrue: [        bb colorMap: (Color maskingMap: aForm depth).        bb fillColor: shadowStipple.    ] ifFalse: [        bb colorMap:            (aForm colormapIfNeededForDepth: bb destForm depth)].    bb copyBits.! !!FormCanvas methodsFor: 'drawing' stamp: '6/9/97 21:06 di'!line: pt1 to: pt2 width: w color: c    port sourceForm: nil;        fillColor: (self drawColor: c);        combinationRule: (self drawRule: Form over);        width: w; height: w;        drawFrom: (pt1 + origin) to: (pt2 + origin)! !!FormCanvas methodsFor: 'drawing'!paragraph: para bounds: bounds color: c    | paraCopy |    paraCopy _ para copy.  "Because displayOn:at: bashes a para's rectangles"    paraCopy        foregroundColor: (shadowDrawing ifTrue: [Color black] ifFalse: [c])        backgroundColor: Color transparent.    paraCopy displayOn: form        at: (bounds topLeft + origin)        clippingBox: (clipRect intersect: (bounds translateBy: origin))        rule: (self drawRule: Form paint)        fillColor: (shadowDrawing                    ifTrue: [self drawColor: c]                    ifFalse: [nil])! !!FormCanvas methodsFor: 'drawing'!point: pt color: c    form colorAt: (pt + origin) put: c.! !!FormCanvas methodsFor: 'drawing'!text: s bounds: boundsRect font: fontOrNil color: c    | scanner |    scanner _ QuickPrint newOn: form                box: ((boundsRect translateBy: origin) intersect: clipRect) truncated                font: fontOrNil                color: (shadowDrawing ifTrue: [Color black] ifFalse: [c]).    shadowDrawing ifTrue: [scanner fillColor: (self drawColor: c)].    scanner drawString: s at: boundsRect topLeft + origin! !!FormCanvas methodsFor: 'other'!showAt: pt    ^ form displayAt: pt! !!FormCanvas methodsFor: 'other'!showAt: pt invalidRects: updateRects    | blt |    blt _ (BitBlt toForm: Display)        sourceForm: form;        combinationRule: Form over.    updateRects do:        [:rect |        blt sourceRect: rect;            destOrigin: rect topLeft + pt;            copyBits]! !!FormCanvas methodsFor: 'private'!drawColor: aColor    ^ shadowDrawing        ifTrue: [shadowStipple]        ifFalse: [aColor]! !!FormCanvas methodsFor: 'private'!drawRule: normalRule    ^ shadowDrawing ifTrue: [Form paint] ifFalse: [normalRule]! !!FormCanvas methodsFor: 'private'!setForm: aForm    | screen blackWord |    self reset.    form _ aForm.    port _ GrafPort toForm: form.    shadowDrawing _ false.    "Build a 50% stipple of black for the given depth."    screen _ Color pixelScreenForDepth: form depth.    blackWord _ Color black pixelWordForDepth: form depth.    shadowStipple _        (screen collect: [:maskWord | maskWord bitAnd: blackWord]).! !!FormCanvas methodsFor: 'private'!setOrigin: aPoint clipRect: aRectangle    super setOrigin: aPoint clipRect: aRectangle.    port clipRect: aRectangle! !!FormCanvas methodsFor: 'copying'!copy    "Make a copy the receiver on the same underlying Form but with its own grafPort."    ^ super copy setForm: form! !!FormCanvas methodsFor: 'copying'!warpFrom: sourceQuad toRect: destRect    ^ (WarpBlt toForm: port destForm)        combinationRule: Form paint;        sourceQuad: sourceQuad destRect: (destRect translateBy: origin);        clipRect: clipRect! !!FormCanvas class methodsFor: 'creation'!extent: aPoint    ^ self extent: aPoint depth: Display depth! !!FormCanvas class methodsFor: 'creation'!extent: extent depth: depth    ^ self new setForm: (Form extent: extent depth: depth)! !!FormCanvas class methodsFor: 'testing'!test    "FormCanvas test"    | canvas |    canvas _ FormCanvas extent: 200@200.    canvas fillColor: (Color white).    canvas line: 10@10 to: 50@30 width: 1 color: (Color black).    canvas frameRectangle: ((20@20) corner: (120@120)) width: 4 color: (Color gray).    canvas point: 90@90 color: (Color black).    canvas text: 'Hello, Roxie' at: 40@40 font: nil color: (Color black).    canvas fillRectangle: ((10@80) corner: (31@121)) color: (Color lightGray).    canvas fillOval: ((10@80) corner: (31@121)) color: (Color black).    canvas fillRectangle: ((130@30) corner: (170@80)) color: (Color lightGray).    canvas showAt: 0@0.! !!FormCanvas class methodsFor: 'testing'!test1    "FormCanvas test1"    | canvas |    canvas _ FormCanvas extent: 200@200.    canvas fillColor: (Color black).    canvas line: 10@10 to: 50@30 width: 1 color: (Color red).    canvas frameRectangle: ((20@20) corner: (120@120)) width: 4 color: (Color green).    canvas point: 90@90 color: (Color black).    canvas text: 'Hello, Roxie' at: 40@40 font: nil color: (Color cyan).    canvas fillRectangle: ((10@80) corner: (31@121)) color: (Color magenta).    canvas fillOval: ((10@80) corner: (31@121)) color: (Color cyan).    canvas fillRectangle: ((130@30) corner: (170@80)) color: (Color lightYellow).    canvas showAt: 0@0.! !!FormCanvas class methodsFor: 'testing'!test2    "FormCanvas test2"    | baseCanvas p canvas |    baseCanvas _ FormCanvas extent: 200@200.    p _ Sensor cursorPoint.    [Sensor anyButtonPressed] whileFalse: [        canvas _ baseCanvas copyOffset: (Sensor cursorPoint - p).        canvas fillColor: (Color white).        canvas line: 10@10 to: 50@30 width: 1 color: (Color black).        canvas frameRectangle: ((20@20) corner: (120@120)) width: 4 color: (Color gray).        canvas point: 90@90 color: (Color black).        canvas text: 'Hello, Roxie' at: 40@40 font: nil color: (Color black).        canvas fillRectangle: ((10@80) corner: (31@121)) color: (Color lightGray).        canvas fillOval: ((10@80) corner: (31@121)) color: (Color black).        canvas fillRectangle: ((130@30) corner: (170@80)) color: (Color lightGray).        canvas showAt: 0@0.    ].! !!FormCanvas class methodsFor: 'testing'!test4    "Time millisecondsToRun: [FormCanvas test4] 1134"    "3762 mSecs -- ParcPlace Smalltalk on Duo 230"    | baseCanvas p canvas |    baseCanvas _ FormCanvas extent: 200@200.    p _ Sensor cursorPoint.    100 timesRepeat: [        canvas _ baseCanvas copyOffset: (Sensor cursorPoint - p).        canvas fillColor: (Color white).        canvas line: 10@10 to: 50@30 width: 1 color: (Color black).        canvas frameRectangle: ((20@20) corner: (120@120)) width: 4 color: (Color gray).        canvas point: 90@90 color: (Color black).        canvas text: 'Hello, Roxie' at: 40@40 font: nil color: (Color black).        canvas fillRectangle: ((10@80) corner: (31@121)) color: (Color lightGray).        canvas fillRectangle: ((130@30) corner: (170@80)) color: (Color black).        canvas showAt: 0@0.    ].! !!FormCanvas class methodsFor: 'testing'!test5    "FormCanvas test5"    | canvas |    canvas _ FormCanvas extent: 200@200.    canvas fillColor: (Color yellow).    canvas _ canvas copyForShadowDrawingOffset: 10@10.    canvas line: 10@10 to: 50@30 width: 1 color: (Color blue).    canvas frameRectangle: ((20@20) corner: (120@120)) width: 4 color: (Color red).    canvas point: 90@90 color: (Color red).    canvas text: 'Hello, Roxie' at: 40@40 font: nil color: (Color red).    canvas fillRectangle: ((10@80) corner: (31@121)) color: (Color red).    canvas fillOval: ((10@80) corner: (31@121)) color: (Color red).    canvas fillRectangle: ((130@30) corner: (170@80)) color: (Color red).    canvas showAt: 0@0.! !!FormEditor methodsFor: 'editing tools'!changeGridding    "Allow the user to change the values of the horizontal and/or vertical     grid modules. Does not change the primary tool."    | response gridInteger gridX gridY |    gridX _ togglegrid x.    gridY _ togglegrid y.    response _         self promptRequest: 'Current horizontal gridding is: '                         , gridX printString                         , '.Type new horizontal gridding.'.    response isEmpty        ifFalse:             [gridInteger _ Integer readFromString: response.            gridX _ ((gridInteger max: 1) min: Display extent x)].    response _         self promptRequest: 'Current vertical gridding is: '                         , gridY printString                         , '.Type new vertical gridding.'.    response isEmpty        ifFalse:             [gridInteger _ Integer readFromString: response.            gridY _ ((gridInteger max: 1) min: Display extent y)].    xgridOn ifTrue: [grid _ gridX @ grid y].    ygridOn ifTrue: [grid _ grid x @ gridY].    togglegrid _ gridX @ gridY.    tool _ previousTool! !!FormEditor methodsFor: 'editing tools'!colorGray    "Set the color to gray. Leaves the tool set in its previous state."    self setColor: Color gray.! !!FormEditor methodsFor: 'editing tools'!colorWhite    "Set the color to white. Leaves the tool set in its previous state."    self setColor: Color white! !!FormEditor methodsFor: 'editing tools' stamp: '6/9/97 10:15 di'!curve    "Conic-section specified by three points designated by: first point--press     red button second point--release red button third point--click red button.     The resultant curve on the display is displayed according to the current     form and mode."    | firstPoint secondPoint thirdPoint curve |    "sensor noButtonPressed ifTrue: [^self]."    firstPoint _ self cursorPoint.    form        displayOn: Display        at: firstPoint        clippingBox: view insetDisplayBox        rule: (Display depth > 1 ifTrue: [Form paint]                                        ifFalse: [mode])        fillColor: color.    secondPoint _ self trackFormUntil: [sensor noButtonPressed].    form        displayOn: Display        at: secondPoint        clippingBox: view insetDisplayBox        rule: Form reverse        fillColor: color.    thirdPoint _ self trackFormUntil: [sensor redButtonPressed]..    form        displayOn: Display        at: thirdPoint        clippingBox: view insetDisplayBox        rule: (Display depth > 1 ifTrue: [Form paint]                                        ifFalse: [mode])        fillColor: color.    form        displayOn: Display        at: secondPoint        clippingBox: view insetDisplayBox        rule: Form reverse        fillColor: color.    curve _ CurveFitter new.    curve firstPoint: firstPoint.    curve secondPoint: secondPoint.    curve thirdPoint: thirdPoint.    curve form: form.    curve        displayOn: Display        at: 0 @ 0        clippingBox: view insetDisplayBox        rule: (Display depth > 1 ifTrue: [Form paint]                                        ifFalse: [mode])        fillColor: color.    sensor waitNoButton! !!FormEditor methodsFor: 'editing tools'!fileInForm    "Ask the user for a file name and then recalls the Form in that file as     the current source Form (form). Does not change the tool."    | fileName file |    fileName _ self promptRequest: 'type a name for recalling a source Form . . . '.    file _ FileStream oldFileNamed: fileName.    file binary.    form _ Form new readFrom: file.    file close.    tool _ previousTool.! !!FormEditor methodsFor: 'editing tools'!fileOutForm    "Ask the user for a file name and then save the current source form     (form) under that name. Does not change the tool."    | fileName file |    fileName _ self promptRequest: 'type a name for saving the source Form . . . '.    file _ FileStream newFileNamed: fileName.    file binary.    form writeOn: file.    file close.    tool _ previousTool.! !!FormEditor methodsFor: 'editing tools'!newSourceForm    "Allow the user to define a new source form for the FormEditor. Copying     the source form onto the display is the primary graphical operation.     Resets the tool to be repeatCopy."    | dForm interiorPoint interiorColor |    dForm _ Form fromUser: grid.    "sourceForm must be only 1 bit deep"    interiorPoint _ dForm extent // 2.    interiorColor _ dForm colorAt: interiorPoint.    form _ (dForm makeBWForm: interiorColor) reverse                findShapeAroundSeedBlock:                    [:f | f pixelValueAt: interiorPoint put: 1].    form _ form trimToPixelValue: 1 orNot: false.    tool _ previousTool! !!FormEditor methodsFor: 'editing tools'!repeatCopy    "As long as the red button is pressed, copy the source form onto the     display screen."    [sensor redButtonPressed]        whileTrue:         [(BitBlt destForm: Display sourceForm: form halftoneForm: color            combinationRule: (Display depth > 1 ifTrue: [Form paint]                                        ifFalse: [mode])            destOrigin: self cursorPoint sourceOrigin: 0@0 extent: form extent            clipRect: view insetDisplayBox)            colorMap: (Bitmap with: 0 with: 16rFFFFFFFF);            copyBits]! !!FormEditor methodsFor: 'editing tools'!togglexGridding    "Turn x (horizontal) gridding off, if it is on, and turns it on, if it is off.     Does not change the primary tool."    xgridOn        ifTrue:             [grid _ 1 @ grid y.            xgridOn _ false]        ifFalse:             [grid _ togglegrid x @ grid y.            xgridOn _ true].    tool _ previousTool! !!FormEditor methodsFor: 'editing tools'!toggleyGridding    "Turn y (vertical) gridding off, if it is on, and turns it on, if it is off.     Does not change the primary tool."    ygridOn        ifTrue:             [grid _ grid x @ 1.            ygridOn _ false]        ifFalse:             [grid _ grid x @ togglegrid y.            ygridOn _ true].    tool _ previousTool! !!FormEditor methodsFor: 'menu messages'!edit    model edit! !!FormEditor methodsFor: 'private'!promptRequest: outputMessage     "Answers with a string typed by the user on the keyboard. keyboard    input is terminated by a line feed character. Typing feedback happens    in a window that is at least 100 bits wide and 50 bits high."    FillInTheBlank        request: outputMessage        displayAt: view insetDisplayBox topCenter + (0@80)        centered: true        action: [:answer]         initialAnswer: ''.    ^answer! !!FormEditor methodsFor: 'private'!rubberBandFrom: startPoint until: aBlock    | endPoint previousEndPoint |    previousEndPoint _ startPoint.    [aBlock value] whileFalse:        [(endPoint _ self cursorPoint) = previousEndPoint             ifFalse:            [(Line from: startPoint to: previousEndPoint withForm: form)                displayOn: Display                at: 0 @ 0                clippingBox: view insetDisplayBox                rule: Form reverse                fillColor: Color black.            (Line from: startPoint to: endPoint withForm: form)                displayOn: Display                at: 0 @ 0                clippingBox: view insetDisplayBox                rule: Form reverse                fillColor: Color black.            previousEndPoint  _ endPoint]].    (Line from: startPoint to: previousEndPoint withForm: form)        displayOn: Display        at: 0 @ 0        clippingBox: view insetDisplayBox        rule: Form reverse        fillColor: Color black.    ^endPoint! !!FormEditor methodsFor: 'private'!setVariables    tool _ #repeatCopy.    previousTool _ tool.    grid _ 1 @ 1.    togglegrid _ 8 @ 8.    xgridOn _ false.    ygridOn _ false.    mode _ Form over.    form _ Form extent: 8 @ 8.    form fillBlack.    unNormalizedColor _ color _ Color black.! !!FormEditor class methodsFor: 'class initialization'!initialize    FlashCursor _ false.    self setKeyboardMap.    YellowButtonMenu _ PopUpMenu labels: 'acceptcanceleditfile out' lines: #(2).    YellowButtonMessages _ #(accept cancel edit fileOut)    "FormEditor initialize"! !!FormEditor class methodsFor: 'private'!createFullScreenForm    "Create a StandardSystemView for a FormEditor on the form whole screen."    | formView formEditor menuView topView extent aForm |    aForm _ Form extent: (Display extent x @ (Display extent y - 112)) depth: Display depth.    formView _ FormHolderView new model: aForm.    formView borderWidthLeft: 0 right: 0 top: 0 bottom: 1.    formEditor _ formView controller.    menuView _ FormMenuView new makeFormEditorMenu model: formEditor.    formEditor model: menuView controller.    topView _ ColorSystemView new.    topView backgroundColor: #veryLightGray.    topView model: aForm.    topView addSubView: formView.    topView         addSubView: menuView        align: menuView viewport topCenter        with: formView viewport bottomCenter + (0@16).    topView window:         (formView viewport             merge: (menuView viewport expandBy: (16 @ 0 corner: 16@16))).    topView label: 'Form Editor'.    extent _ topView viewport extent.    topView minimumSize: extent.    topView maximumSize: extent.    ^topView! !!FormEditor class methodsFor: 'private'!createOnForm: aForm    "Create a StandardSystemView for a FormEditor on the form aForm."    | formView formEditor menuView aView topView extent topViewBorder |    topViewBorder _ 2.    formView _ FormHolderView new model: aForm.    formEditor _ formView controller.    menuView _ FormMenuView new makeFormEditorMenu model: formEditor.    formEditor model: aForm.    aView _ View new.    aView model: aForm.    aView addSubView: formView.    aView         addSubView: menuView        align: menuView viewport topCenter        with: formView viewport bottomCenter + (0@16).    aView window:         ((formView viewport             merge: (menuView viewport expandBy: (16 @ 0 corner: 16@16)))           expandBy: (0@topViewBorder corner: 0@0)).    aView window extent > formView viewport extent        ifTrue: [formView borderWidthLeft: 1 right: 1 top: 0 bottom: 1]        ifFalse: [formView borderWidthLeft: 0 right: 0 top: 0 bottom: 1].    topView _ ColorSystemView new.    topView backgroundColor: #veryLightGray.    topView addSubView: aView.    topView label: 'Form Editor'.    topView borderWidth: topViewBorder.    extent _ topView viewport extent.    topView minimumSize: extent.    topView maximumSize: extent.    ^topView! !FormSetFont comment:'FormSetFonts are designed to capture individual images as character forms for imbedding in normal text.  While most often used to insert an isolated glyph in some text, the code is actually desinged to support an entire user-defined font.  The TextAttribute subclass TextFontReference is specifically designed for such in-line insertion of exceptional fonts in normal text.'!!FormSetFont methodsFor: 'all'!fromFormArray: formArray asciiStart: asciiStart ascent: ascentVal    | height width x badChar |    type _ 2.    name _ 'aFormFont'.    minAscii _ asciiStart.    maxAscii _ minAscii + formArray size - 1.    ascent _ ascentVal.    subscript _ superscript _ emphasis _ 0.    height _ width _ 0.    maxWidth _ 0.    formArray do:        [:f | width _ width + f width.        maxWidth _ maxWidth max: f width.        height _ height max: f height + f offset y].    badChar _ (Form extent: 7@height) borderWidth: 1.    width _ width + badChar width.    descent _ height - ascent.    pointSize _ height.    glyphs _ Form extent: width @ height depth: formArray first depth.    xTable _ Array new: maxAscii + 3 withAll: 0.    x _ 0.    formArray doWithIndex:        [:f :i | f displayOn: glyphs at: x@0.        xTable at: minAscii + i+1 put: (x _ x + f width)].    badChar displayOn: glyphs at: x@0.    xTable at: maxAscii + 3 put: x + badChar width.    self setStopConditions! !!FormSetFont methodsFor: 'all'!reset  "Ignored by FormSetFonts"! !!FormSetFont class methodsFor: 'examples'!copy: charForm toClipBoardAs: char ascent: ascent    ParagraphEditor new clipboardTextPut:        (Text string: char asString            attribute: (TextFontReference toFont:                 (FormSetFont new                    fromFormArray: (Array with: charForm)                    asciiStart: char asciiValue                    ascent: ascent)))"    The S in the Squeak welcome window was installed by doing the following    in a workspace (where the value of, eg, charForm will persist through BitEdit...    f _ TextStyle default fontAt: 4.    oldS _ f characterFormAt: $S.    charForm _ Form extent: oldS extent depth: 8.    oldS displayOn: charForm.    charForm bitEdit.    ...Play around with the BitEditor, then accept and close...    FormSetFont copy: charForm toClipBoardAs: $S ascent: f ascent.    ...Then do a paste into the Welcome window"! !!FormSetFont class methodsFor: 'examples'!example    "FormSetFont example"    "Lets the user select a (small) area of the screen to represent the    character A, then copies 'A' to the clipboard with that as the letter form.    Thereafter, a paste operation will imbed that character in any text."    | charForm |    charForm _ Form fromUser.    self copy: charForm toClipBoardAs: $A ascent: charForm height! !!FormView methodsFor: 'displaying'!displayOn: aPort    model displayOnPort: aPort at: self displayBox origin! !!FormView methodsFor: 'displaying' stamp: 'hmm 7/21/97 20:45'!displayView     "Refer to the comment in View|displayView."    | oldOffset |    super displayView.    insideColor == nil ifFalse: [Display fill: self insetDisplayBox fillColor: insideColor].    oldOffset _ model offset.    model offset: "borderWidth origin" 0@0.    model        displayOn: Display        transformation: self displayTransformation        clippingBox: self insetDisplayBox        rule: self rule        fillColor: self fillColor.    model offset: oldOffset! !!FormView methodsFor: 'displaying'!updateDisplay    "overridden by subclass"! !!FormView class methodsFor: 'examples'!open: aForm named: aString    "FormView open: (GIFReadWriter imageFromFileNamed: 'TylerCrop.GIF')named: 'Squeak' "    "Answer a scheduled view whose model is aForm and whose label isaString. 12/11/96 tk"    | topView aView |    topView _ ColorSystemView new.    topView model: aForm.    topView label: aString.    topView minimumSize: 80@80.    aView _ FormView new.    aView model: aForm.    aView window: (0 @ 0 extent: aForm extent + (4@4)).        "compensate for borders.  Should be window:viewport:"    aView borderWidthLeft: 2 right: 2 top: 2 bottom: 2.    topView addSubView: aView.    topView controller open! !!Fraction methodsFor: 'arithmetic'!* aNumber    "Answer the result of multiplying the receiver by aNumber."    aNumber isFraction        ifTrue: [^ (Fraction numerator: numerator * aNumber numerator                            denominator: denominator * aNumber denominator)                        reduced]        ifFalse: [^ (aNumber adaptFraction: self) * aNumber adaptToFraction]! !!Fraction methodsFor: 'arithmetic'!+ aNumber    "Answer the sum of the receiver and aNumber."    | commonDenominator newNumerator |    aNumber isFraction        ifTrue:             [denominator = aNumber denominator ifTrue: [                ^ (Fraction                     numerator: numerator + aNumber numerator                    denominator: denominator) reduced].            commonDenominator _ denominator lcm: aNumber denominator.            newNumerator _                (numerator * (commonDenominator / denominator)) +                (aNumber numerator * (commonDenominator / aNumber denominator)).            ^ (Fraction                 numerator: newNumerator                 denominator: commonDenominator) reduced]        ifFalse: [^ (aNumber adaptFraction: self) + aNumber adaptToFraction]! !!Fraction methodsFor: 'arithmetic'!- aNumber    "Answer the difference between the receiver and aNumber."    aNumber isFraction        ifTrue: [^ self + aNumber negated]        ifFalse: [^ (aNumber adaptFraction: self) - aNumber adaptToFraction]! !!Fraction methodsFor: 'arithmetic'!/ aNumber    "Answer the result of dividing the receiver by aNumber."    aNumber isFraction        ifTrue: [^self * aNumber reciprocal]        ifFalse: [^ (aNumber adaptFraction: self) / aNumber adaptToFraction]! !!Fraction methodsFor: 'arithmetic'!negated     "Refer to the comment in Number|negated."    ^ Fraction        numerator: numerator negated        denominator: denominator! !!Fraction methodsFor: 'comparing'!< aNumber    aNumber isFraction        ifTrue: [aNumber numerator = 0                ifTrue: [^numerator < 0]                ifFalse: [^self - aNumber < 0]]        ifFalse: [^ (aNumber adaptFraction: self) < aNumber adaptToFraction]! !!Fraction methodsFor: 'comparing'!= aNumber    aNumber isNumber ifFalse: [^ false].    aNumber isFraction        ifTrue: [aNumber numerator = 0                ifTrue: [^numerator = 0]                ifFalse: [^aNumber numerator = numerator                             and: [aNumber denominator = denominator]]]        ifFalse: [^ (aNumber adaptFraction: self) = aNumber adaptToFraction]! !!Fraction methodsFor: 'converting'!adaptFloat: aFloat    "If I am involved in arithmetic with a Float, do not convert the Float."    ^ aFloat! !!Fraction methodsFor: 'converting'!adaptInteger: anInteger    "If I am involved in arithmetic with an Integer, convert the Integer."    ^ anInteger asFraction! !!Fraction methodsFor: 'converting'!adaptToFloat    "If I am involved in arithmetic with a Float, convert me to a Float."    ^ self asFloat! !!Fraction methodsFor: 'converting'!adaptToInteger    "If I am involved in arithmetic with an Integer, do not convert me."    ^ self! !!Fraction methodsFor: 'converting'!isFraction    ^ true! !!Fraction methodsFor: 'printing'!printOn: aStream    aStream nextPut: $(.    numerator printOn: aStream.    aStream nextPut: $/.    denominator printOn: aStream.    aStream nextPut: $).! !!FrameRateMorph methodsFor: 'all'!initialize    super initialize.    lastDisplayTime _ 0.    framesSinceLastDisplay _ 0.! !!FrameRateMorph methodsFor: 'all'!step    | now mSecs mSecsPerFrame framesPerSec |    framesSinceLastDisplay _ framesSinceLastDisplay + 1.    now _ Time millisecondClockValue.    mSecs _ now - lastDisplayTime.    (mSecs > 500 or: [mSecs < 0 "clock wrap-around"]) ifTrue: [        mSecsPerFrame _ mSecs // framesSinceLastDisplay.        framesPerSec _ (framesSinceLastDisplay * 1000) // mSecs.        self contents: mSecsPerFrame printString, ' mSecs (', framesPerSec printString, ' frames/sec)'.        lastDisplayTime _ now.        framesSinceLastDisplay _ 0]! !!FrameRateMorph methodsFor: 'all'!stepTime    "Answer the desired time between steps in milliseconds."    ^ 1! !GIFReadWriter comment:'Copyright (c) Kazuki Yasumatsu, 1995. All rights reserved.Modified for use by Squeak.Note that writing out GIF files is not implemented yet.'!!GIFReadWriter methodsFor: 'accessing' stamp: 'tk 6/24/97 20:33'!nextImage    "Read in the next GIF image from the stream."    | f |    self readHeader.    f _ self readBody.    self close.    f == nil ifTrue: [^ self error: 'corrupt GIF file'].    transparentIndex ifNotNil: [        transparentIndex + 1 > colorPalette size ifTrue: [            colorPalette _ colorPalette forceTo: transparentIndex + 1 paddingWith: Color white].        colorPalette at: transparentIndex + 1 put: Color transparent].    f colors: colorPalette.    ^ f! !!GIFReadWriter methodsFor: 'accessing'!nextPutImage: anImage    | bits |    anImage bitsPerPixel > 8 ifTrue: [        self error: 'GIF does not support Forms deeper than 8-bits'].    width _ anImage width.    height _ anImage height.    bitsPerPixel _ anImage bitsPerPixel.    colorPalette _ anImage palette.    bits _ anImage bits.    bitsPerPixel < 8 ifTrue:        [bits _ self unpackBits: bits            depthTo8From: bitsPerPixel            with: anImage width            height: anImage height            pad: 32].    interlace _ false.    self writeHeader.    self writeBitData: bits.    self close.    ^ anImage! !!GIFReadWriter methodsFor: 'accessing' stamp: '6/18/97 13:18 '!setStream: aStream    "Feed it in from an existing source"    stream _ aStream! !!GIFReadWriter methodsFor: 'private-encoding'!flushCode    self flushBits! !!GIFReadWriter methodsFor: 'private-encoding'!readPixelFrom: bits    | pixel |    ypos >= height ifTrue: [^nil].    pixel _ bits at: (ypos * rowByteSize + xpos + 1).    self updatePixelPosition.    ^pixel! !!GIFReadWriter methodsFor: 'private-encoding'!writeBitData: bits    "using modified Lempel-Ziv Welch algorithm."    | maxBits maxMaxCode tSize initCodeSize ent tShift fCode pixel index disp nomatch |    pass _ 0.    xpos _ 0.    ypos _ 0.    rowByteSize _ width * 8 + 31 // 32 * 4.    remainBitCount _ 0.    bufByte _ 0.    bufStream _ WriteStream on: (ByteArray new: 256).    maxBits _ 12.    maxMaxCode _ 1 bitShift: maxBits.    tSize _ 5003.    prefixTable _ Array new: tSize.    suffixTable _ Array new: tSize.    initCodeSize _ bitsPerPixel <= 1 ifTrue: [2] ifFalse: [bitsPerPixel].    self nextPut: initCodeSize.    self setParameters: initCodeSize.    tShift _ 0.    fCode _ tSize.    [fCode < 65536] whileTrue:        [tShift _ tShift + 1.        fCode _ fCode * 2].    tShift _ 8 - tShift.    1 to: tSize do: [:i | suffixTable at: i put: -1].    self writeCodeAndCheckCodeSize: clearCode.    ent _ self readPixelFrom: bits.    [(pixel _ self readPixelFrom: bits) == nil] whileFalse:        [        fCode _ (pixel bitShift: maxBits) + ent.        index _ ((pixel bitShift: tShift) bitXor: ent) + 1.        (suffixTable at: index) = fCode            ifTrue: [ent _ prefixTable at: index]            ifFalse:                [nomatch _ true.                (suffixTable at: index) >= 0                    ifTrue:                        [disp _ tSize - index + 1.                        index = 1 ifTrue: [disp _ 1].                        "probe"                        [(index _ index - disp) < 1 ifTrue: [index _ index + tSize].                        (suffixTable at: index) = fCode                            ifTrue:                                [ent _ prefixTable at: index.                                nomatch _ false.                                "continue whileFalse:"].                        nomatch and: [(suffixTable at: index) > 0]]                            whileTrue: ["probe"]].                "nomatch"                nomatch ifTrue:                    [self writeCodeAndCheckCodeSize: ent.                    ent _ pixel.                    freeCode < maxMaxCode                        ifTrue:                            [prefixTable at: index put: freeCode.                            suffixTable at: index put: fCode.                            freeCode _ freeCode + 1]                        ifFalse:                            [self writeCodeAndCheckCodeSize: clearCode.                            1 to: tSize do: [:i | suffixTable at: i put: -1].                            self setParameters: initCodeSize]]]].    prefixTable _ suffixTable _ nil.    self writeCodeAndCheckCodeSize: ent.    self writeCodeAndCheckCodeSize: eoiCode.    self flushCode.    self nextPut: 0.    "zero-length packet"    self nextPut: Terminator.! !!GIFReadWriter methodsFor: 'private-encoding'!writeCode: aCode    self nextBitsPut: aCode! !!GIFReadWriter methodsFor: 'private-encoding'!writeCodeAndCheckCodeSize: aCode    self writeCode: aCode.    self checkCodeSize! !!GIFReadWriter methodsFor: 'private-encoding'!writeHeader    | byte |    self nextPutAll: 'GIF87a' asByteArray.    self writeWord: width.        "Screen Width"    self writeWord: height.    "Screen Height"    byte _ 16r80.            "has color map"    byte _ byte bitOr: ((bitsPerPixel - 1) bitShift: 5).    "color resolution"    byte _ byte bitOr: bitsPerPixel - 1.    "bits per pixel"    self nextPut: byte.    self nextPut: 0.        "background color."    self nextPut: 0.        "null (future expansion)"    colorPalette do: [:c |        self nextPut: ((c red * 255.0) asInteger bitAnd: 255);            nextPut: ((c green * 255.0) asInteger bitAnd: 255);            nextPut: ((c blue * 255.0) asInteger bitAnd: 255)].    colorPalette size + 1 to: (1 bitShift: bitsPerPixel) do: [:i |        self nextPut: 0; nextPut: 0; nextPut: 0].    self nextPut: ImageSeparator.    self writeWord: 0.        "Image Left"    self writeWord: 0.        "Image Top"    self writeWord: width.        "Image Width"    self writeWord: height.    "Image Height"    byte _ interlace ifTrue: [16r40] ifFalse: [0].    self nextPut: byte! !!GIFReadWriter methodsFor: 'private-encoding'!writeWord: aWord    self nextPut: (aWord bitAnd: 255).    self nextPut: ((aWord bitShift: -8) bitAnd: 255).    ^aWord! !!GIFReadWriter methodsFor: 'private-decoding' stamp: 'tk 6/24/97 20:16'!readBitData    "using modified Lempel-Ziv Welch algorithm."    | outCodes outCount bitMask initCodeSize code curCode oldCode inCode finChar i bytes f |    self readWord.    "skip Image Left"    self readWord.    "skip Image Top"    width _ self readWord.    height _ self readWord.    interlace _ (self next bitAnd: 16r40) ~= 0.    "I ignore the possible existence of a local color map."    pass _ 0.    xpos _ 0.    ypos _ 0.    rowByteSize _ ((width + 3) // 4) * 4.    remainBitCount _ 0.    bufByte _ 0.    bufStream _ ReadStream on: ByteArray new.    outCodes _ ByteArray new: 1025.    outCount _ 0.    bitMask _ (1 bitShift: bitsPerPixel) - 1.    prefixTable _ Array new: 4096.    suffixTable _ Array new: 4096.    initCodeSize _ self next.    self setParameters: initCodeSize.    bitsPerPixel > 8 ifTrue: [^self error: 'never heard of a GIF that deep'].    bytes _ ByteArray new: rowByteSize * height.    [(code _ self readCode) = eoiCode] whileFalse:        [code = clearCode            ifTrue:                [self setParameters: initCodeSize.                curCode _ oldCode _ code _ self readCode.                finChar _ curCode bitAnd: bitMask.                "Horrible hack to avoid running off the end of the bitmap.  Seems to cure problem reading some gifs!!? tk 6/24/97 20:16"                xpos = 0 ifTrue: [                        ypos < height ifTrue: [                            bytes at: (ypos * rowByteSize) + xpos + 1 put: finChar]]                    ifFalse: [bytes at: (ypos * rowByteSize) + xpos + 1 put: finChar].                self updatePixelPosition]            ifFalse:                [curCode _ inCode _ code.                curCode >= freeCode ifTrue:                    [curCode _ oldCode.                    outCodes at: (outCount _ outCount + 1) put: finChar].                [curCode > bitMask] whileTrue:                    [outCount > 1024                        ifTrue: [^self error: 'corrupt GIF file (OutCount)'].                    outCodes at: (outCount _ outCount + 1)                        put: (suffixTable at: curCode + 1).                    curCode _ prefixTable at: curCode + 1].                finChar _ curCode bitAnd: bitMask.                outCodes at: (outCount _ outCount + 1) put: finChar.                i _ outCount.                [i > 0] whileTrue:                    ["self writePixel: (outCodes at: i) to: bits"                    bytes at: (ypos * rowByteSize) + xpos + 1 put: (outCodes at: i).                    self updatePixelPosition.                    i _ i - 1].                outCount _ 0.                prefixTable at: freeCode + 1 put: oldCode.                suffixTable at: freeCode + 1 put: finChar.                oldCode _ inCode.                freeCode _ freeCode + 1.                self checkCodeSize]].    prefixTable _ suffixTable _ nil.    f _ ColorForm extent: width@height depth: 8.    (Form new hackBits: bytes) displayOn: (Form new hackBits: f bits).    ^ f! !!GIFReadWriter methodsFor: 'private-decoding' stamp: 'tk 8/7/96'!readBody    "Read the GIF blocks. Modified to return a form.  "    | form extype block blocksize |    form _ nil.    [stream atEnd] whileFalse: [        block _ self next.        block = Terminator ifTrue: [^ form].        block = ImageSeparator ifTrue: [            form isNil                ifTrue: [form _ self readBitData]                ifFalse: [self skipBitData].        ] ifFalse: [            block = Extension                ifFalse: [^ form "^ self error: 'Unknown block type'"].            "Extension block"            extype _ self next.    "extension type"            extype = 16rF9 ifTrue: [  "graphics control"                self next = 4 ifFalse: [^ form "^ self error: 'corrupt GIF file'"].                self next; next; next.                transparentIndex _ self next.                self next = 0 ifFalse: [^ form "^ self error: 'corrupt GIF file'"].            ] ifFalse: [  "Skip blocks"                [(blocksize _ self next) > 0]                    whileTrue: [self next: blocksize]]]].! !!GIFReadWriter methodsFor: 'private-decoding'!readCode    ^self nextBits! !!GIFReadWriter methodsFor: 'private-decoding'!readHeader    | is89 byte hasColorMap array r g b |    (self hasMagicNumber: 'GIF87a' asByteArray)        ifTrue: [is89 _ false]        ifFalse: [(self hasMagicNumber: 'GIF89a' asByteArray)            ifTrue: [is89 _ true]            ifFalse: [^ self error: 'This does not appear to be a GIF file']].    self readWord.    "skip Screen Width"    self readWord.    "skip Screen Height"    byte _ self next.    hasColorMap _ (byte bitAnd: 16r80) ~= 0.    bitsPerPixel _ (byte bitAnd: 7) + 1.    byte _ self next.    "skip background color."    self next ~= 0        ifTrue: [is89            ifFalse: [^self error: 'corrupt GIF file (screen descriptor)']].    hasColorMap        ifTrue:            [array _ Array new: (1 bitShift: bitsPerPixel).            1 to: array size do: [:i |                r _ self next.  g _ self next.  b _ self next.                array at: i put: (Color r: r g: g b: b range: 255)                  "depth 32"].            colorPalette _ array]        ifFalse:            ["Transcript cr; show: 'GIF file does not have a color map.'."            colorPalette _ nil "Palette monochromeDefault"].! !!GIFReadWriter methodsFor: 'private-decoding'!readWord    ^self next + (self next bitShift: 8)! !!GIFReadWriter methodsFor: 'private-decoding'!skipBitData    | misc blocksize |    self readWord.  "skip Image Left"    self readWord.  "skip Image Top"    self readWord.  "width"    self readWord.  "height"    misc _ self next.    (misc bitAnd: 16r80) = 0 ifFalse: [ "skip colormap"        1 to: (1 bitShift: (misc bitAnd: 7) + 1) do: [:i |            self next; next; next]].    self next.  "minimum code size"    [(blocksize _ self next) > 0]        whileTrue: [self next: blocksize]! !!GIFReadWriter methodsFor: 'private-bits access'!flushBits    remainBitCount = 0 ifFalse:        [self nextBytePut: bufByte.        remainBitCount _ 0].    self flushBuffer! !!GIFReadWriter methodsFor: 'private-bits access'!nextBits    | integer readBitCount shiftCount byte |    integer _ 0.    remainBitCount = 0        ifTrue:            [readBitCount _ 8.            shiftCount _ 0]        ifFalse:            [readBitCount _ remainBitCount.            shiftCount _ remainBitCount - 8].    [readBitCount < codeSize]        whileTrue:            [byte _ self nextByte.            byte == nil ifTrue: [^eoiCode].            integer _ integer + (byte bitShift: shiftCount).            shiftCount _ shiftCount + 8.            readBitCount _ readBitCount + 8].    (remainBitCount _ readBitCount - codeSize) = 0        ifTrue:    [byte _ self nextByte]        ifFalse:    [byte _ self peekByte].    byte == nil ifTrue: [^eoiCode].    ^(integer + (byte bitShift: shiftCount)) bitAnd: maxCode! !!GIFReadWriter methodsFor: 'private-bits access'!nextBitsPut: anInteger    | integer writeBitCount shiftCount |    shiftCount _ 0.    remainBitCount = 0        ifTrue:            [writeBitCount _ 8.            integer _ anInteger]        ifFalse:            [writeBitCount _ remainBitCount.            integer _ bufByte + (anInteger bitShift: 8 - remainBitCount)].    [writeBitCount < codeSize]        whileTrue:            [self nextBytePut: ((integer bitShift: shiftCount) bitAnd: 255).            shiftCount _ shiftCount - 8.            writeBitCount _ writeBitCount + 8].    (remainBitCount _ writeBitCount - codeSize) = 0        ifTrue: [self nextBytePut: (integer bitShift: shiftCount)]        ifFalse: [bufByte _ integer bitShift: shiftCount].    ^anInteger! !!GIFReadWriter methodsFor: 'private-packing'!fillBuffer    | packSize |    packSize _ self next.    bufStream _ ReadStream on: (self next: packSize)! !!GIFReadWriter methodsFor: 'private-packing'!flushBuffer    bufStream isEmpty ifTrue: [^self].    self nextPut: bufStream size.    self nextPutAll: bufStream contents.    bufStream _ WriteStream on: (ByteArray new: 256)! !!GIFReadWriter methodsFor: 'private-packing'!nextByte    bufStream atEnd        ifTrue:            [self atEnd ifTrue: [^nil].            self fillBuffer].    ^bufStream next! !!GIFReadWriter methodsFor: 'private-packing'!nextBytePut: aByte    bufStream nextPut: aByte.    bufStream size >= 254 ifTrue: [self flushBuffer]! !!GIFReadWriter methodsFor: 'private-packing'!peekByte    bufStream atEnd        ifTrue:            [self atEnd ifTrue: [^nil].            self fillBuffer].    ^bufStream peek! !!GIFReadWriter methodsFor: 'private'!checkCodeSize    (freeCode > maxCode and: [codeSize < 12])        ifTrue:            [codeSize _ codeSize + 1.            maxCode _ (1 bitShift: codeSize) - 1]! !!GIFReadWriter methodsFor: 'private'!setParameters: initCodeSize    clearCode _ 1 bitShift: initCodeSize.    eoiCode _ clearCode + 1.    freeCode _ clearCode + 2.    codeSize _ initCodeSize + 1.    maxCode _ (1 bitShift: codeSize) - 1! !!GIFReadWriter methodsFor: 'private'!updatePixelPosition    (xpos _ xpos + 1) >= width ifFalse: [^self].    xpos _ 0.    interlace        ifFalse: [ypos _ ypos + 1. ^self].    pass = 0 ifTrue:        [(ypos _ ypos + 8) >= height            ifTrue:                [pass _ pass + 1.                ypos _ 4].        ^self].    pass = 1 ifTrue:        [(ypos _ ypos + 8) >= height            ifTrue:                [pass _ pass + 1.                ypos _ 2].        ^self].    pass = 2 ifTrue:        [(ypos _ ypos + 4) >= height            ifTrue:                [pass _ pass + 1.                ypos _ 1].        ^self].    pass = 3 ifTrue:        [ypos _ ypos + 2.        ^self].    ^self error: 'can''t happen'! !!GIFReadWriter class methodsFor: 'class initialization'!initialize    "GIFReadWriter initialize"    ImageSeparator _ $, asInteger.    Extension _ $!! asInteger.    Terminator _ $; asInteger.! !!GrafPort methodsFor: 'all'!fillOval: rect color: fillColor borderWidth: borderWidth borderColor: borderColor    "Tends to leave 1-pixel nipples at left and right edges. Can probably fix by treating dy = 0 same as dy = 1."    | wp fillTone w borderTone centerX centerY centerYBias centerXBias radiusSquared xOverY maxy dxs dx prevLeft left |    rect area <= 0 ifTrue: [^ self].    wp _ borderWidth asPoint.    sourceForm _ nil.     height _ 1.    fillColor == nil        ifTrue: [fillTone _ nil]        ifFalse: [self fillColor: fillColor.  fillTone _ halftoneForm].    (((w _ wp x) * wp y) = 0 or: [borderColor == nil])        ifTrue: [borderTone _ nil]        ifFalse: [self fillColor: borderColor.  borderTone _ halftoneForm].    centerX _ rect center x.    centerY _ rect center y.    centerYBias _ rect height odd ifTrue: [0] ifFalse: [1].    centerXBias _ rect width odd ifTrue: [0] ifFalse: [1].    radiusSquared _ (rect height asFloat / 2.0) squared - 0.01.    xOverY _ rect width asFloat / rect height asFloat.    maxy _ rect height - 1 // 2.    dxs _ Array new: maxy + 1.    "First do the inner fill, and collect x values"    0 to: maxy do:        [:dy |        dx _ ((radiusSquared - (dy * dy) asFloat) sqrt * xOverY) truncated.        dxs at: dy+1 put: dx.        fillTone == nil ifFalse:            [halftoneForm _ fillTone.            height _ 1.            width _ dx + dx + centerXBias + 1.            destX _ centerX - centerXBias - dx.            destY _ centerY - centerYBias - dy.            self copyBits.            destY _ centerY + dy.            self copyBits]].    "Now do the border, using the same x values"    borderTone ifNil: [^ self].    prevLeft _ centerX.    maxy to: 0 by: -1 do: [:dy |        dx _ dxs at: dy+1.        halftoneForm _ borderTone.        height _ wp y.        left _ centerX - centerXBias - dx.        width _ prevLeft - left + w.        destX _ left.        destY _ centerY - centerYBias - dy.        self copyBits.        destX _ centerX + dx + 1 - width.        self copyBits.        destY _ centerY + dy - height + 1.        self copyBits.        destX _ left.        self copyBits.        prevLeft _ left].! !!GrafPort methodsFor: 'all'!fillRect: rect color: fillColor    self copy: rect        from: 0@0        in: nil        fillColor: fillColor        rule: combinationRule.! !!GrafPort methodsFor: 'all'!fillRect: rect color: fillColor borderWidth: borderWidth borderColor: borderColor    self copy: rect        from: 0@0        in: nil        fillColor: fillColor        rule: combinationRule.! !!GrafPort methodsFor: 'all'!frameRect: rect borderWidth: borderWidth borderColor: borderColor    sourceForm _ nil.    self fillColor: borderColor.    (rect areasOutside: (rect insetBy: borderWidth)) do:        [:edgeStrip | self destRect: edgeStrip; copyBits].! !!GrafPort methodsFor: 'all'!frameRectBottom: rect    | w h |    w _ width.    h _ height.    sourceForm _ nil.    destX _ rect left + 1.    destY _ rect bottom - 1.    width _ rect width - 2.    height _ 1.    1 to: h do: [:i |        self copyBits.        destX _ destX + 1.        destY _ destY - 1.        width _ width - 2].    width _ w.    height _ h.! !!GrafPort methodsFor: 'all'!frameRectRight: rect    | w h |    w _ width.    h _ height.    sourceForm _ nil.    width _ 1.    height _ rect height - 1.    destX _ rect right - 1.    destY _ rect top + 1.    1 to: w do: [:i |        self copyBits.        destX _ destX - 1.        destY _ destY + 1.        height _ height - 2].    width _ w.    height _ h.! !!GraphMorph methodsFor: 'initialization'!initialize    super initialize.    self color: (Color r: 0.8 g: 0.8 b: 0.6).    self extent: 365@80.    self borderWidth: 2.    dataColor _ Color darkGray.    cursor _ 1.0.  "may be fractional"    cursorColor _ Color red.    startIndex _ 1.    self data:        ((0 to: 360 - 1) collect:            [:x | (10000.0 * ((4.0 * x) degreesToRadians sin)) asInteger]).! !!GraphMorph methodsFor: 'accessing'!color: aColor    super color: aColor.    self flushCachedForm.! !!GraphMorph methodsFor: 'accessing'!cursor    ^ cursor! !!GraphMorph methodsFor: 'accessing'!cursor: aNumber    | truncP |    cursor ~= aNumber ifTrue:  [        cursor _ aNumber.        truncP _ aNumber truncated.        truncP > data size ifTrue: [cursor _ data size].        truncP < 0 ifTrue: [cursor _ 1].        self keepIndexInView: truncP.        self changed].! !!GraphMorph methodsFor: 'accessing'!cursorAtEnd    ^ cursor truncated >= data size! !!GraphMorph methodsFor: 'accessing'!cursorColor    ^ cursorColor! !!GraphMorph methodsFor: 'accessing'!cursorColor: aColor    cursorColor _ aColor.    self flushCachedForm.! !!GraphMorph methodsFor: 'accessing'!data    ^ data! !!GraphMorph methodsFor: 'accessing'!data: aCollection    data _ aCollection.    maxVal _ minVal _ 0.    data do: [:x |        x < minVal ifTrue: [minVal _ x].        x > maxVal ifTrue: [maxVal _ x]].    self flushCachedForm.! !!GraphMorph methodsFor: 'accessing'!dataColor    ^ dataColor! !!GraphMorph methodsFor: 'accessing'!dataColor: aColor    dataColor _ aColor.    self flushCachedForm.! !!GraphMorph methodsFor: 'accessing'!parts    "Return an array of part names for use in e-toys."    ^ #(position startIndex cursor valueAtCursor)! !!GraphMorph methodsFor: 'accessing'!startIndex    ^ startIndex! !!GraphMorph methodsFor: 'accessing'!startIndex: aNumber    startIndex ~= aNumber ifTrue:  [        startIndex _ aNumber asInteger.        self flushCachedForm].! !!GraphMorph methodsFor: 'accessing'!valueAtCursor    data isEmpty ifTrue: [^ 0].    ^ data at: ((cursor truncated max: 1) min: data size)! !!GraphMorph methodsFor: 'accessing'!valueAtCursor: aPointOrNumber    data isEmpty ifTrue: [^ 0].    data        at: ((cursor truncated max: 1) min: data size)        put: (self asNumber: aPointOrNumber).    self flushCachedForm.! !!GraphMorph methodsFor: 'drawing'!drawOn: aCanvas    | c |    cachedForm = nil ifTrue:  [        c _ FormCanvas extent: bounds extent.        self drawDataOn: (c copyOffset: bounds origin negated).        cachedForm _ c form].    aCanvas image: cachedForm at: bounds origin.    self drawPointerOn: aCanvas.! !!GraphMorph methodsFor: 'change reporting'!layoutChanged    super layoutChanged.    cachedForm _ nil.! !!GraphMorph methodsFor: 'events'!handlesMouseDown: evt    evt shiftPressed        ifTrue: [^ true]        ifFalse: [^ super handlesMouseDown: evt].! !!GraphMorph methodsFor: 'events'!mouseMove: evt    self cursor: startIndex + evt cursorPoint x - (bounds left + borderWidth).! !!GraphMorph methodsFor: 'commands'!appendValue: aPointOrNumber    | newVal |    (data isKindOf: OrderedCollection) ifFalse: [data _ data asOrderedCollection].    newVal _ self asNumber: aPointOrNumber.    data addLast: newVal.    newVal < minVal ifTrue: [minVal _ newVal].    newVal > maxVal ifTrue: [maxVal _ newVal].    self cursor: data size.    self flushCachedForm.! !!GraphMorph methodsFor: 'commands'!clear    self startIndex: 1.    self cursor: 1.    self data: OrderedCollection new.! !!GraphMorph methodsFor: 'commands'!commandsWithDefaultArgs    "Return a list of (command arg1 arg2 ...) arrays where each command is followed by the default values for is parameters."    | r |    r _ OrderedCollection new.    r add: #(appendValue: 1000).    r add: #(processSamples).    r add: #(play).    r add: #(playOnce).    r add: #(playBach).    r add: #(clear).    r add: #(reverse).    ^ r! !!GraphMorph methodsFor: 'commands'!loadCoffeeCupClink    SampledSound useCoffeeCupClink.    self data: SampledSound defaultSampleTable.! !!GraphMorph methodsFor: 'commands'!play    | count |    count _ ((2 * SoundPlayer samplingRate) // data size) max: 1.    SampledSound defaultSamples: data repeated: count.    SampledSound nominalSamplePitch: 250.    Smalltalk garbageCollect.    (SampledSound pitch: 440.0 dur: 1.5 loudness: 500) play.! !!GraphMorph methodsFor: 'commands'!playBach    Smalltalk garbageCollect.    SampledSound bachFugue play.! !!GraphMorph methodsFor: 'commands'!playOnce    SampledSound defaultSamples: data repeated: 1.    SampledSound nominalSamplePitch: 250.    Smalltalk garbageCollect.    (SampledSound pitch: 440.0 dur: 1.5 loudness: 500) play.! !!GraphMorph methodsFor: 'commands'!processSamples    | w sel |    w _ self world.    self nameInModel ifNil: [^ self].    sel _ self processSamplesSelector.    (w model respondsTo: sel) ifFalse: [^ self].    self cursor: 1.    [self cursorAtEnd] whileFalse: [        w model perform: sel.        w runStepMethods.        w displayWorld].    w model perform: sel.  "final sample"! !!GraphMorph methodsFor: 'commands'!reverse    data _ data reversed.    self flushCachedForm.! !!GraphMorph methodsFor: 'commands'!stopPlaying    SoundPlayer stopPlayerProcess.! !!GraphMorph methodsFor: 'script support'!acceptScript: aScriptEditorMorph for: ignored    lastAcceptedScript _ aScriptEditorMorph.    self world model class        compile: lastAcceptedScript methodString        classified: 'scripts'        notifying: nil.! !!GraphMorph methodsFor: 'script support' stamp: 'jm 9/28/97 14:35'!addCustomMenuItems: aCustomMenu hand: aHandMorph    super addCustomMenuItems: aCustomMenu hand: aHandMorph.    aCustomMenu add: 'read file' action: #readDataFromFile.! !!GraphMorph methodsFor: 'script support'!copy    ^ super copy initScripts! !!GraphMorph methodsFor: 'script support'!hasScript    "Return true if there is already a script for this morph."    ^ lastAcceptedScript ~~ nil! !!GraphMorph methodsFor: 'script support'!initScripts    "Used to remove the scripts from a newly made copy of myself."    lastAcceptedScript _ lastScriptEditor _ nil.! !!GraphMorph methodsFor: 'script support'!processSamplesSelector    ^ (self nameInModel, 'ProcessSamples') asSymbol! !!GraphMorph methodsFor: 'script support'!readDataFromFile    | fileName |    fileName _ FillInTheBlank        request: 'File name?'        initialAnswer: ''.    fileName isEmpty ifTrue: [^ self].    (StandardFileStream isAFileNamed: fileName) ifFalse: [        ^ self inform: 'Sorry, I cannot find that file'].    data _ (SampledSound readTrimmedSamplesFromAIFF: fileName).    self flushCachedForm.! !!GraphMorph methodsFor: 'private'!drawDataOn: aCanvas    | yScale baseLine x start end value left top bottom right |    super drawOn: aCanvas.    data isEmpty ifTrue: [^ self].    maxVal = minVal ifTrue: [        yScale _ 1.    ] ifFalse: [        yScale _ (bounds height - (2 * borderWidth)) asFloat / (maxVal - minVal)].    baseLine _ bounds bottom - borderWidth + (minVal * yScale) truncated.    left _ top _ 0. right _ 10. bottom _ 0.    x _ bounds left + borderWidth.    start _ (startIndex asInteger max: 1) min: data size.    end _ (start + bounds width) min: data size.    start to: end do: [:i |        left _ x truncated. right _ x + 1.        right > (bounds right - borderWidth) ifTrue: [^ self].        value _ (data at: i) asFloat.        value >= 0.0 ifTrue: [            top _ baseLine - (yScale * value) truncated.            bottom _ baseLine.        ] ifFalse: [            top _ baseLine.            bottom _ baseLine - (yScale * value) truncated].        aCanvas fillRectangle: (left@top corner: right@bottom) color: dataColor.        x _ x + 1].! !!GraphMorph methodsFor: 'private'!drawPointerOn: aCanvas    | ptr x r |    ptr _ (cursor asInteger max: 1) min: data size.    r _ self innerBounds.    x _ r left + ptr - startIndex.    ((x >= r left) and: [x <= r right]) ifTrue: [        aCanvas fillRectangle: (x@r top corner: x+1@r bottom) color: cursorColor].! !!GraphMorph methodsFor: 'private'!flushCachedForm    cachedForm _ nil.    self changed.! !!GraphMorph methodsFor: 'private'!keepIndexInView: index    | newStart |    index < startIndex ifTrue: [        newStart _ index - (bounds width - (2 * borderWidth)) + 1.        ^ self startIndex: (newStart max: 1)].    index > (startIndex + bounds width - (2 * borderWidth)) ifTrue: [        ^ self startIndex: (index min: data size)].! !!GraphMorph methodsFor: 'private'!registerWaveform    "Store my data as the default sample table for SampledSound."    SampledSound defaultSampleTable: (data collect: [:x | x asInteger]).    SampledSound nominalSamplePitch: 153.! !!HandMorph methodsFor: 'initialization'!initForEvents    eventSubscribers _ Set new.    mouseDownMorph _ nil.    lastEvent _ MorphicEvent new.    eventTransform _ MorphicTransform identity.    self resetClickState.! !!HandMorph methodsFor: 'initialization' stamp: 'jm 9/24/97 13:40'!initialize    super initialize.    self initForEvents.    keyboardFocus _ nil.    mouseOverMorphs _ OrderedCollection new.    bounds _ 0@0 extent: Cursor normal extent.    userInitials _ ''.    damageRecorder _ DamageRecorder new.    grid _ 4@4.    gridOn _ false.    remoteConnections _ OrderedCollection new.    lastEventTransmitted _ MorphicEvent new.! !!HandMorph methodsFor: 'classification'!isHandMorph    ^ true! !!HandMorph methodsFor: 'accessing'!colorForInsets    "Morphs being dragged by the hand use the world's color"    ^ owner color! !!HandMorph methodsFor: 'accessing'!setArgument: aMorph    argument _ aMorph! !!HandMorph methodsFor: 'accessing' stamp: 'jm 6/11/97 17:26'!showTemporaryCursor: cursorOrNil    "Set the temporary cursor to the given Form. If the argument is nil, revert to the normal cursor."    self showTemporaryCursor: cursorOrNil hotSpotOffset: 0@0.! !!HandMorph methodsFor: 'accessing'!showTemporaryCursor: cursorOrNil hotSpotOffset: aPoint    "Set the temporary cursor to the given Form. If the argument is nil, revert to the normal cursor."    self changed.    cursorOrNil == nil ifTrue: [        temporaryCursor _ nil.        bounds _ self position extent: NormalCursor extent.    ] ifFalse: [        temporaryCursor _ ColorForm transparentFrom: cursorOrNil.        bounds _ self position extent: temporaryCursor extent].    self layoutChanged.    self changed.    UseHardwareCursor ifTrue: [        (cursorOrNil isMemberOf: Cursor)            ifTrue: [cursorOrNil show]            ifFalse: [Cursor normal show]].! !!HandMorph methodsFor: 'accessing'!targetOffset    "Return the offset of the last mouseDown location relative to the origin of the recipient morph. During menu interactions, this is the absolute location of the mouse down event that invoked the menu."    ^ targetOffset! !!HandMorph methodsFor: 'accessing'!userInitials    ^ userInitials! !!HandMorph methodsFor: 'accessing'!userInitials: aString    userInitials _ aString.    bounds _ bounds merge: (bounds right@4 extent: (userInitials asParagraph extent)).! !!HandMorph methodsFor: 'geometry'!changed    "Needs to be overridden to call superclass's invalidRect:."    super invalidRect: self fullBounds.! !!HandMorph methodsFor: 'geometry'!fullBounds    "Extend my bounds by the shadow offset when carrying morphs."    | bnds |    bnds _ super fullBounds.    submorphs isEmpty        ifTrue: [^ bnds ]        ifFalse: [^ bnds topLeft corner: bnds  bottomRight + self shadowOffset].! !!HandMorph methodsFor: 'geometry'!invalidRect: damageRect    "Extend damage to cover drop-shadow when carrying morphs."    | r |    fullBounds == nil        ifTrue: [damageRecorder recordInvalidRect: damageRect]        ifFalse: [damageRecorder recordInvalidRect: (damageRect translateBy: fullBounds origin negated)].    submorphs isEmpty        ifTrue: [r _ damageRect]        ifFalse: [r _ damageRect topLeft extent: damageRect extent + self shadowOffset].    super invalidRect: r.! !!HandMorph methodsFor: 'geometry'!moveBy: delta    "Overridden to align submorph origins on the grid of it is on"    gridOn ifFalse: [^ super moveBy: delta].    (delta x = 0 and: [delta y = 0]) ifTrue: [^ self].  "Null change"    self changed.    submorphs size > 0        ifTrue: [submorphs do: [:m | m moveBy: (m position + delta grid: grid) - m position]].    self privateMoveBy: (self position + delta grid: grid) - self position.    self changed! !!HandMorph methodsFor: 'drawing'!drawOn: aCanvas    "Draw the hand itself (i.e., the cursor)."    UseHardwareCursor ifFalse: [        temporaryCursor == nil            ifTrue: [aCanvas image: NormalCursor at: self position]            ifFalse: [aCanvas image: temporaryCursor at: self position]].    userInitials size > 0 ifTrue:        [aCanvas text: userInitials at: (self position + (16@4)) font: nil color: color].! !!HandMorph methodsFor: 'drawing' stamp: '6/10/97 09:31 di'!fullDrawOn: aCanvas    "A HandMorph has unusual drawing requirements:        1. the hand itself (i.e., the cursor) appears in front of its submorphs        2. morphs being held by the hand cast a shadow on the world/morphs below    The illusion is that the hand plucks up morphs and carries them above the world."    "Note: This version caches an image of the morphs being held by the hand for     better performance. This cache is invalidated if one of those morphs changes."    | myBnds shadowCanvas |    submorphs isEmpty ifTrue: [        cacheCanvas _ nil.        ^ self drawOn: aCanvas].  "just draw the hand itself"    myBnds _ super fullBounds.  "my full bounds without my shadow"    self updateCacheCanvasDepth: aCanvas depth.    "draw the shadow"    shadowCanvas _ aCanvas copyForShadowDrawingOffset: self shadowOffset.    "Note: it's 3x faster to fill a rectangle rather than draw the shadow of a Form"    cachedCanvasHasHoles        ifTrue: [shadowCanvas image: cacheCanvas form at: myBnds origin]        ifFalse: [shadowCanvas fillRectangle: myBnds color: color].    "draw morphs in front of the shadow using the cached Form"    aCanvas image: cacheCanvas form at: myBnds origin.    self drawOn: aCanvas.  "draw the hand itself in front of morphs"! !!HandMorph methodsFor: 'drawing'!nonCachingFullDrawOn: aCanvas    "A HandMorph has unusual drawing requirements:        1. the hand itself (i.e., the cursor) appears in front of its submorphs        2. morphs being held by the hand cast a shadow on the world/morphs below    The illusion is that the hand plucks up morphs and carries them above the world."    "Note: This version does not cache an image of the morphs being held by the hand.     Thus, it is slower for complex morphs, but consumes less space."    | shadowCanvas |    submorphs isEmpty ifTrue: [^ self drawOn: aCanvas].  "just draw the hand itself"    shadowCanvas _ aCanvas copyForShadowDrawingOffset: self shadowOffset.    submorphs reverseDo: [:m | m fullDrawOn: shadowCanvas].  "draw shadows"    submorphs reverseDo: [:m | m fullDrawOn: aCanvas].  "draw morphs in front of shadows"    self drawOn: aCanvas.  "draw the hand itself in front of morphs"! !!HandMorph methodsFor: 'drawing'!shadowOffset    ^ 6@8! !!HandMorph methodsFor: 'drawing' stamp: '6/9/97 16:13 di'!updateCacheCanvasDepth: depth    "Update the cached image of the morphs being held by this hand."    | myBnds rectList c |    myBnds _ super fullBounds.  "my full bounds without my shadow"    (cacheCanvas == nil or: [cacheCanvas extent ~= myBnds extent]) ifTrue: [        cacheCanvas _ FormCanvas extent: myBnds extent depth: depth.        c _ cacheCanvas copyOffset: myBnds origin negated.        submorphs reverseDo: [:m | m fullDrawOn: c].        cachedCanvasHasHoles _ (cacheCanvas form tallyPixelValues at: 1) > 0.        ^ self].    "incrementally update the cache canvas"    rectList _ damageRecorder invalidRectsFullBounds: (0@0 extent: myBnds extent).    rectList do: [:r |        c _ cacheCanvas copyOrigin: myBnds origin negated clipRect: r.        c fillColor: Color transparent.  "clear to transparent"        submorphs reverseDo: [:m | m fullDrawOn: c].    ].    damageRecorder reset.! !!HandMorph methodsFor: 'event dispatching'!handleEvent: evt    self position ~= evt cursorPoint        ifTrue: [self position: evt cursorPoint].    eventSubscribers do: [:m | m handleEvent: evt].    evt isMouse ifTrue: [        evt isMouseMove ifTrue: [^ self handleMouseMove: evt].        evt isMouseDown ifTrue: [^ self handleMouseDown: evt].        evt isMouseUp ifTrue: [^ self handleMouseUp: evt]].    evt isKeystroke ifTrue: [        keyboardFocus ifNotNil: [keyboardFocus keyStroke: evt].        ^ self].! !!HandMorph methodsFor: 'event dispatching' stamp: 'jm 6/21/97 18:43'!handleMouseDown: evt    "Dispatch a mouseDown event."    | m localEvt rootForGrab |    "if carrying morphs, just drop them"    self hasSubmorphs ifTrue: [^ self dropMorphsEvent: evt].    clickState ~~ #idle ifTrue: [^ self checkForDoubleClick: evt].    m _ self recipientForMouseDown: evt.    m ifNotNil: [        (m handlesMouseDown: evt) ifTrue: [            "start a mouse transaction on m"            mouseDownMorph _ m.            eventTransform _ m transformFrom: self.            localEvt _ self transformEvent: evt.            targetOffset _ localEvt cursorPoint - m position.            m mouseDown: localEvt.            "ensure that at least one mouseMove: is reported             for each mouse transaction:"            m mouseMove: (localEvt copy setType: #mouseMove).        ] ifFalse: [            "grab m by the appropriate root"            rootForGrab _ m rootForGrabOf: m.            rootForGrab ifNotNil: [self grabMorph: rootForGrab]]].! !!HandMorph methodsFor: 'event dispatching' stamp: 'jm 6/25/97 17:20'!handleMouseMove: evt    "Dispatch a mouseMove event."    clickState ~~ #idle ifTrue: [self checkForDoubleClick: evt].    mouseDownMorph ~~ nil ifTrue: [        mouseDownMorph mouseMove: (self transformEvent: evt).        ^ self].    self handleMouseOver: evt.! !!HandMorph methodsFor: 'event dispatching' stamp: 'di 6/29/97 09:55'!handleMouseOver: evt    | p roots mList allMouseOvers leftMorphs enteredMorphs |    owner ifNil: [^ self].  "this hand is not in a world"    p _ evt cursorPoint.    roots _ owner rootMorphsAt: p.  "root morphs in world"    roots size > 0        ifTrue: [mList _ roots first morphsAt: p]        ifFalse: [mList _ EmptyArray].    "Make a list of all potential mouse-overs..."    allMouseOvers _ mList select: [:m | m handlesMouseOver: evt].    "Notify and remove any mouse-overs that have just been left..."    leftMorphs _ mouseOverMorphs select: [:m | (allMouseOvers includes: m) not].    leftMorphs do: [:m |        m mouseLeave: (evt transformedBy: (m transformFrom: self)).        mouseOverMorphs remove: m].    "Notify and add any mouse-overs that have just been entered..."    enteredMorphs _ allMouseOvers select: [:m | (mouseOverMorphs includes: m) not].    enteredMorphs do: [:m |        m mouseEnter: (evt transformedBy: (m transformFrom: self)).        mouseOverMorphs add: m].! !!HandMorph methodsFor: 'event dispatching' stamp: 'di 9/24/97 10:44'!handleMouseUp: evt    "Dispatch a mouseUp event."    | oldFocus |    clickState ~~ #idle ifTrue: [self checkForDoubleClick: evt].    "drop morphs being carried, if any"    mouseDownMorph = nil ifTrue: [^ self dropMorphsEvent: evt].    "ensure that at least one mouseMove: is reported for each mouse focus transaction:"    mouseDownMorph mouseMove: (self transformEvent: (evt copy setType: #mouseMove)).    oldFocus := mouseDownMorph.    "make sure that focus becomes nil."    mouseDownMorph _ nil.  "mouse focus transaction ends when mouse goes up"    oldFocus mouseUp: (self transformEvent: evt).! !!HandMorph methodsFor: 'event dispatching' stamp: 'di 9/29/97 14:24'!keyboardFocus     ^ keyboardFocus! !!HandMorph methodsFor: 'event dispatching' stamp: 'di 9/25/97 20:03'!mouseDownRecipient: aMorph    "Install a new recipient for mousedown events, namely stillDown and up,    and, in the process, unsubscribe any prior recipient"    mouseDownMorph _ aMorph! !!HandMorph methodsFor: 'event dispatching' stamp: 'di 9/29/97 13:03'!newKeyboardFocus: aMorphOrNil    "Make the given morph the new keyboard focus, canceling the previous keyboard focus if any. If the argument is nil, the current keyboard focus is cancelled."    | oldFocus |    oldFocus _ keyboardFocus.    keyboardFocus _ aMorphOrNil.    oldFocus ifNotNil: [oldFocus == aMorphOrNil ifFalse: [oldFocus keyboardFocusChange: false]].    aMorphOrNil ifNotNil: [aMorphOrNil keyboardFocusChange: true].! !!HandMorph methodsFor: 'event dispatching' stamp: 'di 9/24/97 11:37'!newMouseFocus: aMorphOrNil    "Old protocol for compatibility with HMM's MorphicMenu"    mouseDownMorph _ aMorphOrNil! !!HandMorph methodsFor: 'event dispatching' stamp: 'jm 9/25/97 10:36'!processEvents    "Process user input events from the local input devices."    | griddedPoint evt currentExtent |    griddedPoint _ Sensor cursorPoint - owner viewBox topLeft.    gridOn ifTrue: [griddedPoint _ griddedPoint grid: grid].    evt _ MorphicEvent new        setMousePoint: griddedPoint        buttons: Sensor primMouseButtons        lastEvent: lastEvent        hand: self.    remoteConnections size > 0 ifTrue: [        currentExtent _ self worldBounds extent.        lastWorldExtent ~= currentExtent ifTrue: [            self transmitEvent: (MorphicEvent newWorldExtent: currentExtent).            lastWorldExtent _ currentExtent].        self transmitEvent: evt].    (evt yellowButtonPressed and:     [lastEvent yellowButtonPressed not]) ifTrue: [        lastEvent _ evt.        ^ self invokeMetaMenu: evt].    (evt blueButtonPressed and:     [lastEvent blueButtonPressed not]) ifTrue: [        lastEvent _ evt.        ^ self specialGesture: evt].    lastEvent _ evt.    self handleEvent: evt.    Sensor keyboardPressed ifTrue: [        evt _ MorphicEvent new            setKeyValue: Sensor keyboard asciiValue            mousePoint: griddedPoint            buttons: Sensor primMouseButtons            hand: self.        lastEvent _ evt.        self handleEvent: evt.        remoteConnections size > 0 ifTrue: [self transmitEvent: evt]].! !!HandMorph methodsFor: 'event dispatching'!recipientForMouseDown: evt    "Return the morph that should handle the given mouseDown: event."    "Details: To get mouse events, a morph must        a. contain the point at which the mouse went down, and        b. respond true to handlesMouseDown:, and        c. be in front of all other submorphs that respond true to handlesMouseDown:If no morph handles the mouse down, the front-most submorph is grabbed. The complexity in this description arises from the need to negotiate between nested submorphs that all want to handle mouse events."    "Note: The current scheme does not allow a morph to intercept mouse events before its submorphs. If the ability to do that is required in the future, the message #preemptsMouseDown: could be added (defaulting to false in class Morph) and the following code could be added before the current search for a mouse handler:    coreSample reverseDo:        [:subM | (subM preemptsMouseDown: evt) ifTrue: [^ subM]]."    | p roots coreSample |    owner ifNil: [^ nil].  "this hand is not in a world"    p _ evt cursorPoint.    roots _ owner rootMorphsAt: p.  "root morphs in world"    roots size = 0 ifTrue: [        "no morphs at the given point, so world gets it"        ^ owner].    "coreSample is submorphs of the front-most root morph in front-to-back order"    coreSample _ roots first morphsAt: p.    "first look for the inner-most submorph that handles events, if any"    coreSample do: [:subM |        (subM handlesMouseDown: evt) ifTrue: [^ subM]].    "no enclosing morph handles mouseDown:; return front-most submorph"    ^ coreSample first! !!HandMorph methodsFor: 'event dispatching'!transformEvent: evt    "Transform the given event by the transform recorded when the mouse went down."    ^ evt transformedBy: eventTransform! !!HandMorph methodsFor: 'double click support'!checkForDoubleClick: evt    "Process the given mouse event to detect a click, double-click, or drag."    | t |    t _ Time millisecondClockValue - firstClickTime.    clickState = #firstClickDown ifTrue: [        (t > DoubleClickTime or:         [(evt cursorPoint - firstClickEvent cursorPoint) r > 15]) ifTrue: [            "consider it a drag if hand moves or timeout expires"            clickClient drag: firstClickEvent.            ^ self resetClickState].        evt isMouseUp ifTrue: [            clickState _ #firstClickUp.            ^ self]].    clickState = #firstClickUp ifTrue: [        evt isMouseDown ifTrue: [            clickClient doubleClick: firstClickEvent.            ^ self resetClickState].        t > DoubleClickTime ifTrue: [            clickClient click: firstClickEvent.            ^ self resetClickState]].! !!HandMorph methodsFor: 'double click support'!resetClickState    "Reset the double-click detection state to normal (i.e., not waiting for a double-click)."    clickClient _ nil.    clickState _ #idle.    firstClickEvent _ nil.    firstClickTime _ nil.! !!HandMorph methodsFor: 'double click support'!waitForClicksOrDrag: aMorph event: evt    "Wait until the difference between click, double-click, or drag gesture is known, then inform the given morph what transpired. This message is sent when the given morph first receives a mouse-down event. If the mouse button goes up, then down again within DoubleClickTime, then 'doubleClick: evt' is sent to the morph. If the mouse button goes up but not down again within DoubleClickTime, then the message 'singleClick: evt' is sent to the morph. Finally, if the button does not go up within DoubleClickTime, then 'drag: evt' is sent to the morph. In all cases, the event supplied is the original mouseDown event that initiated the gesture. mouseMove: and mouseUp: events are not sent to the morph until it becomes the mouse focus, which is typically done by the client in its singleClick:, doubleClick:, or drag: methods."     clickClient _ aMorph.    clickState _ #firstClickDown.    firstClickEvent _ evt.    firstClickTime _ Time millisecondClockValue.! !!HandMorph methodsFor: 'grabbing/dropping'!attachMorph: m    "Position the center of the given morph under this hand, then grab it. This method is used to grab far away or newly created morphs."    m position: self position - (m fullBounds extent // 2).    self grabMorph: m.! !!HandMorph methodsFor: 'grabbing/dropping'!dropMorphsEvent: evt    "Drop all the morphs this hand is currently holding in response to the given event."    "Details: All submorphs of the front-most composite morph under the hand are given an opportunity to accept the dropping morph. If none of these accepts it, or if there is no morph under the hand, then the morph drop drops into the world."    | targetM |    owner ifNil: [^ self].  "there is no world to drop the morphs into"    self changed.    self submorphsReverseDo: [:m |        "drop in reverse order to maintain back-to-front ordering"        targetM _ self dropTargetFor: m event: evt.        targetM acceptDroppingMorph: m event: evt.        m justDroppedInto: targetM event: evt.        m owner = self ifTrue: [self world addMorphFront: m]].    self layoutChanged.! !!HandMorph methodsFor: 'grabbing/dropping'!dropTargetFor: aMorph event: evt    "Return the morph that the given morph is to be dropped onto. Return the world, if no other morph wants the dropping morph."    | root |    "find front-most composite morph"    root _ nil.    owner submorphsReverseDo: [:m |        (m fullContainsPoint: evt cursorPoint) ifTrue: [root _ m]].    root == nil ifTrue: [^ self world].    (root morphsAt: evt cursorPoint) do: [:m |        (m wantsDroppedMorph: aMorph event: evt) ifTrue: [^ m]].    ^ self world! !!HandMorph methodsFor: 'grabbing/dropping'!grabMorph: m    "Grab the given morph (i.e., add it to this hand and remove it from its current owner) without changing its position. This is used to pick up a morph under the hand's current position, versus attachMorph: which is used to pick up a morph that may not be near this hand."    self addMorphBack: m.    mouseDownMorph _ nil.        "so it will be put down again"! !!HandMorph methodsFor: 'event reporting'!startReportingEventsTo: subscriber    "Start reporting events to the given object. All input events are reported to every event subscriber, in addition to being sent to the current mouse/keyboard focus morph. This allows one to build things like macro recorders, eyes that follow the mouse, etc."    (eventSubscribers includes: subscriber) ifFalse: [eventSubscribers add: subscriber].! !!HandMorph methodsFor: 'event reporting'!stopReportingEventsTo: subscriber    "Stop reporting events to the given object."    eventSubscribers remove: subscriber ifAbsent: [].! !!HandMorph methodsFor: 'meta menu'!argumentOrNil    "Answer the root of the front-most morph under the cursor. If the cursor is not over any morph, answer nil."    owner submorphsDo:        [:m | (m fullContainsPoint: targetOffset) ifTrue: [^ m]].    ^ nil! !!HandMorph methodsFor: 'meta menu'!beThisWorldsModel    self world setModel: argument.    argument model: nil slotName: nil.    "A world's model cannot have another model"! !!HandMorph methodsFor: 'meta menu'!browseMorphClass    | mClass newBrowser view |    mClass _ argument class.    "Use following to get a simple browser:    Browser newOnClass: mClass."    newBrowser _ HierarchyBrowser new        initHierarchyForClass: mClass        meta: false.    view _ BrowserView systemCategoryBrowser: newBrowser editString: nil.    Browser postOpenSuggestion: (Array with: mClass with: nil).    BrowserView openBrowserView: view        label: mClass name, ' hierarchy'! !!HandMorph methodsFor: 'meta menu' stamp: 'jm 9/29/97 10:33'!buildMorphHandleMenuFor: argMorph    "Build the morph menu for the given morph's menu handle. This menu has two sections. The first section contains commands that are interpreted by the hand; the second contains commands provided by the target morph."    | menu |    argument _ argMorph.    menu _ MenuMorph new defaultTarget: self.    menu addStayUpItem.    menu add: 'delete' action: #dismissMorph.    menu add: 'go behind' action: #goBehind.    (argMorph isKindOf: SketchMorph) ifFalse: [        menu add: 'fill color' action: #changeColor].    menu addLine.    menu add: 'inspect' action: #inspectMorph.    menu add: 'browse' action: #browseMorphClass.    menu add: 'make own subclass' action: #subclassMorph.    menu addLine.    menu add: 'sensitize' action: #sensitizeMorph.    menu add: 'name me' action: #nameMorph.    menu add: 'save morph in file' action: #saveMorphInFile.    menu addLine.    menu defaultTarget: argMorph.    argMorph addCustomMenuItems: menu hand: self.    ^ menu! !!HandMorph methodsFor: 'meta menu' stamp: 'jm 9/29/97 10:33'!buildMorphMenuFor: argMorph    "Build the morph menu. This menu has two sections. The first section contains commands that are interpreted by the hand; the second contains commands provided by the target morph. The variable lastMetaMenuItem determines the boundary between the sections."    | menu |    argument _ argMorph.    menu _ MenuMorph new defaultTarget: self.    menu addStayUpItem.    menu add: 'grab' action: #grabMorph.    menu add: 'delete' action: #dismissMorph.    menu add: 'go behind' action: #goBehind.    menu add: 'duplicate' action: #duplicateMorph.    ((self world rootMorphsAt: targetOffset) size > 1)        ifTrue: [menu add: 'embed' action: #embedMorph].    (argMorph isKindOf: SketchMorph)  ifFalse: [        menu add: 'resize' action: #resizeMorph.        menu add: 'fill color' action: #changeColor].    (argMorph morphsAt: targetOffset) size > 1 ifTrue: [        menu add: 'submorphs...'            target: self            selector: #selectSubmorphToOperateOn:sending:event:            argumentList: (Array with: argMorph with: #operateOnSubmorph:event:)].    menu addLine.    menu add: 'inspect' action: #inspectMorph.    menu add: 'browse' action: #browseMorphClass.    menu add: 'make own subclass' action: #subclassMorph.    menu addLine.    menu add: 'sensitize' action: #sensitizeMorph.    menu add: 'name me' action: #nameMorph.    (argMorph isKindOf: MorphicModel) ifTrue: [        menu add: 'save morph as prototype' action: #saveAsPrototype.        (argMorph ~~ self world modelOrNil) ifTrue: [             menu add: 'become this world''s model' action: #beThisWorldsModel]].    menu add: 'save morph in file' action: #saveMorphInFile.    menu addLine.    lastMetaMenuItem _ menu items size.    menu defaultTarget: argMorph.    argMorph addCustomMenuItems: menu hand: self.    ^ menu! !!HandMorph methodsFor: 'meta menu' stamp: 'jm 9/29/97 08:40'!buildWorldMenu    "Build the meta menu for the world."    | menu |    menu _ MenuMorph new defaultTarget: self.    menu addStayUpItem.    Project current isTopProject ifFalse:        [menu add: 'exit this world' action: #exitWorld.        menu addLine].    menu add: 'new morph' action: #newMorph.    menu add: 'new drawing' action: #makeNewDrawing.    menu add: 'read morph(s) from file' action: #readMorphFile.    menu addLine.    menu add: 'change background color' action: #changeBackgroundColor.    menu add: 'inspect world' action: #inspectWorld.    menu addLine.        menu add: 'save world in file' action: #saveWorldInFile.    menu addLine.    menu add: 'add slot to model' action: #newVariable.    menu add: 'write init method for model' action: #writeInitMethodForModel.    menu add: 'grab model for this world' action: #grabModel.    gridOn        ifTrue: [menu add: 'turn gridding off' action: #setGridding]        ifFalse: [menu add: 'turn gridding on' action: #setGridding].    menu addLine.    menu add: 'local host address' action: #reportLocalAddress.    menu add: 'connect remote user' action: #connectRemoteUser.    menu add: 'disconnect remote user' action: #disconnectRemoteUser.    menu add: 'disconnect all remote users' action: #disconnectAllRemoteUsers.    ^ menu! !!HandMorph methodsFor: 'meta menu' stamp: 'jm 9/27/97 06:59'!changeBackgroundColor    | colorPicker |    colorPicker _ self changeColorTarget: self world selector: #color:.    colorPicker updateContinuously: false.! !!HandMorph methodsFor: 'meta menu' stamp: 'jm 9/25/97 16:55'!changeColor    self changeColorTarget: argument selector: #color:.! !!HandMorph methodsFor: 'meta menu' stamp: 'jm 9/27/97 06:59'!changeColorTarget: aMorph selector: aSymbol    | m points b |    m _ ColorPickerMorph new        sourceHand: self;        target: aMorph;        selector: aSymbol.    points _ #(topCenter rightCenter bottomCenter leftCenter).  "possible anchors"    1 to: 4 do: [:i |  "Try the four obvious anchor points"        b _ m bounds                align: (m bounds perform: (points at: i))                with: (aMorph bounds perform: (points atWrap: i + 2)).        (self worldBounds containsRect: b) ifTrue: [  "Yes, it fits"            m position: b topLeft.            self world addMorphFront: m.            m changed.            ^ self]].    "when all else fails..."    m position: 20@20.    self world addMorphFront: m.    m changed.    ^ m! !!HandMorph methodsFor: 'meta menu'!chooseColor    "Displays a color palette using abstract colors, then waits for a mouse click."    "Copied from Color fromUser, then shrunk. 4/16/97 tk"    | loc d chartExtent transp save pt c feedbackColor |    loc _ Sensor cursorPoint.    d _ Display depth.    chartExtent _ 216@56.    ((ColorChart == nil) or: [ColorChart depth ~= Display depth])         ifTrue: [ColorChart _ Color colorPaletteForDepth: d extent: chartExtent].    transp _ Rectangle origin: chartExtent - (50@19) + loc extent: 50@19.    save _ Form fromDisplay: (loc extent: ColorChart extent).    ColorChart displayAt: loc.    Cursor normal showWhile: [        [Sensor anyButtonPressed] whileFalse: [            pt _ Sensor cursorPoint.            c _ feedbackColor _ Display colorAt: pt.            (transp containsPoint: pt) ifTrue: [                c _ Color transparent.                feedbackColor _ Color white].            Display fill: (loc + (0@37) extent: 73@19) fillColor: feedbackColor].        save displayAt: loc.        Sensor waitNoButton].    ^ c! !!HandMorph methodsFor: 'meta menu'!chooseTargetSubmorphOf: root    | possibleTargets menu |    possibleTargets _ root morphsAt: targetOffset.    possibleTargets size = 1 ifTrue: [^ possibleTargets first].    menu _ CustomMenu new.    possibleTargets do: [:m | menu add: (self submorphNameFor: m) action: m].    ^ menu startUp! !!HandMorph methodsFor: 'meta menu'!dismissMorph    argument delete.! !!HandMorph methodsFor: 'meta menu' stamp: 'di 6/29/97 09:36'!drawingClass    ^ SketchMorph! !!HandMorph methodsFor: 'meta menu'!duplicateMorph    | new oldModel |    new _ argument fullCopy.    (oldModel _ argument findA: MorphicModel) ifNotNil: [        oldModel model duplicate: (new findA: MorphicModel) from: oldModel].    self grabMorph: new.! !!HandMorph methodsFor: 'meta menu'!embedMorph    | rootMorphs morphToEmbed targetRoot targetMorph worldPosition |    rootMorphs _ self world rootMorphsAt: targetOffset.    rootMorphs size < 2 ifTrue: [^ self].    morphToEmbed _ rootMorphs at: 1.    worldPosition _ morphToEmbed position.    targetRoot _ rootMorphs at: 2.    targetMorph _ self chooseTargetSubmorphOf: targetRoot.    targetMorph ifNotNil: [        targetMorph addMorphBack: morphToEmbed.        targetMorph changed.        morphToEmbed position: (targetMorph transformFromWorld transform: worldPosition)].! !!HandMorph methodsFor: 'meta menu'!exitWorld    owner exit! !!HandMorph methodsFor: 'meta menu'!goBehind    argument owner addMorphBack: argument.! !!HandMorph methodsFor: 'meta menu'!grabModel    "Attach the root of the world's model to the hand. The user will typically attach some composite morph to this model and then save it as a finished component."    self attachMorph: self world model root.! !!HandMorph methodsFor: 'meta menu'!grabMorph    self position: targetOffset.    self grabMorph: argument.! !!HandMorph methodsFor: 'meta menu'!inspectMorph    argument inspect.! !!HandMorph methodsFor: 'meta menu'!inspectWorld    owner inspect.! !!HandMorph methodsFor: 'meta menu' stamp: 'jm 9/29/97 07:50'!invokeMenu: aMenu event: evt    "Invoke the given menu."    aMenu popUpAt: evt cursorPoint event: evt.! !!HandMorph methodsFor: 'meta menu' stamp: 'jm 9/28/97 19:25'!invokeMetaMenu: evt    "Invoke the meta menu. If the hand is over the background, the world menu is presented. If it is over a morph, a menu of operations for that morph is presented. Each menu entry contains a string to be presented in the menu and a selector. If the selector takes an argument, the mouse-down event that invoked the menu is passed as an argument. This lets the command know which hand invoked it in  order to do things like attaching the result of the command to that hand."    "Shortcut: If the shift key is pressed, the user is given a chance to select a submorph on which to operate."    | menu |    "if carrying morphs, just drop them"    self hasSubmorphs ifTrue: [^ self dropMorphsEvent: evt].    targetOffset _ self position.    argument _ self argumentOrNil.    argument == nil        ifTrue: [            menu _ self buildWorldMenu.            menu addTitle: 'World']        ifFalse: [            menu _ self buildMorphMenuFor: argument.            menu addTitle: argument class name].    self invokeMenu: menu event: evt.! !!HandMorph methodsFor: 'meta menu' stamp: 'jm 9/28/97 19:36'!makeNewDrawing    | rect m aPaintWindow |    rect _ self world paintArea.    "Let it tell us"    m _ self drawingClass new form: (Form extent: rect extent depth: self world canvas depth).    m bounds: rect.    aPaintWindow _ SketchEditorMorph new initializeFor: m inWorld: self world.    aPaintWindow afterNewPicDo: [:aForm :aRect |        owner fullRepaintNeeded.        m form: aForm.        m position: aRect origin.        "m rotationDegrees: 0.        is default of form:"        self world addMorphFront: m].    self world addMorphFront: aPaintWindow.    Cursor normal showWhile: [        aPaintWindow deliverPainting:             (aPaintWindow getPaintingStartingWith: nil at: nil)].! !!HandMorph methodsFor: 'meta menu'!nameMorph    argument choosePartName.! !!HandMorph methodsFor: 'meta menu' stamp: 'jm 9/29/97 10:34'!newMorph    | morphClassList menu categories subMenu |    menu _ MenuMorph new.    menu addStayUpItem.    menu addTitle: 'Select Morph Class'.    morphClassList _ Morph withAllSubclasses asSortedCollection:        [:m1 :m2 | m1 class name < m2 class name].    morphClassList remove: WorldMorph;        remove: HandMorph;        remove: MorphicModel;        remove: RemoteHandMorph.    morphClassList _ morphClassList select:        [:c | (c inheritsFrom: MorphicModel) not or:              ["Only include Models that have been saved"               c includesSelector: #initMorph]].    categories _ (morphClassList collect: [:each | each category]) asSet asSortedCollection.    categories do: [:cat |        subMenu _ MenuMorph new.        morphClassList do: [:each |            each category = cat ifTrue: [                subMenu add: each name                    target: self                    selector: #newMorphOfClass:                    argument: each]].        menu add: cat subMenu: subMenu].    menu popUpAt: self position forHand: self.! !!HandMorph methodsFor: 'meta menu'!newMorphOfClass: morphClass    "taken out of the old method #newMorph"    | m |    m _ morphClass new.    m installModelIn: owner.  "A chance to install model pointers"    self attachMorph: m.    owner startSteppingSubmorphsOf: m! !!HandMorph methodsFor: 'meta menu'!newVariable    | partName |    partName _ owner model addPartNameLike: 'part' withValue: nil.    partName ifNil: [^ self].  "user chose bad part name"    owner model class compileAccessorsFor: partName! !!HandMorph methodsFor: 'meta menu' stamp: 'jm 9/28/97 19:30'!operateOnSubmorph: aMorph event: evt    "Invoke the morph menu for the given submorph."    | menu |    menu _ self buildMorphMenuFor: aMorph.    menu addTitle: aMorph class name.    self invokeMenu: menu event: evt.! !!HandMorph methodsFor: 'meta menu' stamp: 'tk 6/26/97 12:07'!readMorphFile    "Retreive a morph or a collection of morphs from a file."    | fileName morphOrList ff |    fileName _ FillInTheBlank request: 'Morph file name?'.    fileName isEmpty ifTrue: [^ self].  "abort"    ff _ FileStream oldFileNamed: fileName, '.morph'.    morphOrList _ ff fileInObjectAndCode.        "code filed in is the Model class"    "the file may contain either a single morph or an array of morphs"    self world addMorphsAndModel: morphOrList.! !!HandMorph methodsFor: 'meta menu' stamp: '6/10/97 17:47 jm'!resizeMorph    | handle |    handle _ ResizeHandle new setTargetMorph: argument.    self attachMorph: handle.    handle startStepping.! !!HandMorph methodsFor: 'meta menu'!saveAsPrototype    | m |    m _ argument.    (SelectionMenu confirm: 'Make this morph the prototype for ', m class printString, '?')        ifFalse: [^ self].    m class prototype: m.! !!HandMorph methodsFor: 'meta menu'!saveMorphInFile    "Save the argument morph in a file."    | fileName refStream copyToSave |    fileName _ FillInTheBlank request: 'File name for this morph?'.    fileName isEmpty ifTrue: [^ self].  "abort"    refStream _ SmartRefStream newFileNamed: fileName, '.morph'.    copyToSave _ argument fullCopy.    (copyToSave isKindOf: MorphicModel) ifTrue: [        "don't save this world's model"        copyToSave model: nil slotName: nil].    copyToSave allMorphsDo: [:m | m prepareToBeSaved].    refStream nextPut: copyToSave.    refStream close.! !!HandMorph methodsFor: 'meta menu' stamp: 'tk 6/26/97 13:32'!saveWorldInFile    "Save the world's submorphs, model, and stepList in a file.  "    | fileName fileStream aClass |    fileName _ FillInTheBlank request: 'File name for this morph?'.    fileName isEmpty ifTrue: [^ self].  "abort"    "Save only model, stepList, submorphs in this world"    self world submorphsDo: [:m |        m allMorphsDo: [:subM | subM prepareToBeSaved]].    "Amen"    fileStream _ FileStream newFileNamed: fileName, '.morph'.    aClass _ self world model ifNil: [nil] ifNotNil: [self world model class].    fileStream fileOutClass: aClass andObject: self world.! !!HandMorph methodsFor: 'meta menu' stamp: 'jm 9/29/97 07:49'!selectSubmorphToOperateOn: rootMorph sending: aSymbol event: evt    "Let the user select a submorph of the given root morph. When selected, the given selector is sent with the selected submorph as an argument."    | possibleTargets menu |    possibleTargets _ rootMorph morphsAt: targetOffset.    possibleTargets size = 1 ifTrue: [^ self perform: aSymbol with: possibleTargets first].    menu _ MenuMorph new.    possibleTargets do: [:m |        menu add: (self submorphNameFor: m)            target: self            selector: aSymbol            argumentList: (Array with: m with: evt)].    menu popUpAt: self position event: evt.! !!HandMorph methodsFor: 'meta menu'!sensitizeMorph    argument sensitize.! !!HandMorph methodsFor: 'meta menu'!setGridding    gridOn ifTrue: [^ gridOn _ false].    FillInTheBlank request: 'Change grid or confirm...'         displayAt: Sensor cursorPoint centered: true        action: [:answer | grid _ Compiler evaluate: answer]         initialAnswer: grid printString.    gridOn _ true! !!HandMorph methodsFor: 'meta menu'!subclassMorph    "Create a new subclass of this morph's class and make this morph be an instance of it."    | m oldClass newClassName newClass newMorph |    m _ argument.    oldClass _ m class.    newClassName _ FillInTheBlank        request: 'Please give this new class a name'        initialAnswer: oldClass name.    newClassName = '' ifTrue: [^ self].    (Smalltalk includesKey: newClassName)        ifTrue: [^ self inform: 'Sorry, there is already a class of that name'].    newClass _ oldClass subclass: newClassName asSymbol        instanceVariableNames: ''        classVariableNames: ''        poolDictionaries: ''        category: oldClass category asString.    newMorph _ m as: newClass.    m become: newMorph.! !!HandMorph methodsFor: 'meta menu'!submorphNameFor: aMorph    | s nameInModel |    s _ aMorph class name asString.    nameInModel _ aMorph specialNameInModel.    nameInModel ifNotNil: [s _ s, ' "', nameInModel, '"'].    ^ s! !!HandMorph methodsFor: 'meta menu'!writeInitMethodForModel    | model |    model _ self world model.    model class chooseNewName.    model fullCopy compileInitMethods.! !!HandMorph methodsFor: 'special gestures' stamp: 'jm 9/28/97 19:14'!specialGesture: evt    "Blue mouse button (cmd-mouse on the Macintosh) gestures that allow a morph to be grabbed or duplicated without recourse to the meta menu."    "Summary:        Cmd-mouse            grab morph (for picking up buttons, etc.)        Cmd-shift-mouse        duplicate morph"    "if carrying morphs, just drop them"    self hasSubmorphs ifTrue: [^ self dropMorphsEvent: evt].    targetOffset _ self position.    (argument _ self argumentOrNil) ifNil: [^ self].    evt shiftPressed        ifTrue: [self duplicateMorph]        ifFalse: [self grabMorph].! !!HandMorph methodsFor: 'remote morphic' stamp: 'jm 9/26/97 15:37'!cleanupDeadConnections    "Clean up any remote connections that have been disconnected or become invalid."    | liveConnections sock |    liveConnections _ OrderedCollection new.    remoteConnections do: [:triple |        sock _ triple first.        sock isUnconnectedOrInvalid            ifTrue: [                (triple at: 2) = #opening                    ifTrue: [Transcript show: 'trying connection again...'; cr.                        sock destroy.                        sock _ Socket new.                        sock connectTo: (triple at: 3) port: 54323.                        triple at: 1 put: sock.                        liveConnections add: triple]  "try again"                    ifFalse: [triple first destroy]]            ifFalse: [liveConnections add: triple]].    remoteConnections _ liveConnections.! !!HandMorph methodsFor: 'remote morphic' stamp: 'jm 9/26/97 15:00'!connectRemoteUser    "Prompt for the initials to be used to identify the cursor of a remote user, then create a cursor for that user and wait for a connection."    | initials addr h |    initials _ FillInTheBlank request: 'Enter initials for remote user''s cursor?'.    initials isEmpty ifTrue: [^ self].  "abort"    addr _ NetNameResolver promptUserForHostAddress.    addr = 0 ifTrue: [^ self].  "abort"    Socket ensureNetworkConnected.    h _ RemoteHandMorph new userInitials: initials.    self world addHand: h.    h changed.    h startListening.    self startTransmittingEventsTo: addr.! !!HandMorph methodsFor: 'remote morphic' stamp: 'jm 9/26/97 14:34'!disconnectAllRemoteUsers    "Disconnect all remote hands and stop transmitting events."    | addr |    self world hands do: [:h |        (h isKindOf: RemoteHandMorph) ifTrue: [            addr _ h remoteHostAddress.            addr = 0 ifFalse: [self stopTransmittingEventsTo: addr].            h withdrawFromWorld]].    remoteConnections do: [:triple | triple first closeAndDestroy: 5].    remoteConnections _ OrderedCollection new.! !!HandMorph methodsFor: 'remote morphic' stamp: 'jm 9/26/97 11:11'!disconnectRemoteUser    "Prompt for the initials of the remote user, then remove the remote hand with those initials, breaking its connection."    "select hand to remove"    | initials handToRemove addr |    initials _ FillInTheBlank request: 'Enter initials for remote user''s cursor?'.    initials isEmpty ifTrue: [^ self].  "abort"    handToRemove _ nil.    self world hands do: [:h |        h userInitials = initials ifTrue: [handToRemove _ h]].    handToRemove ifNil: [^ self].  "no hand with those initials"    addr _ handToRemove remoteHostAddress.    addr = 0 ifFalse: [self stopTransmittingEventsTo: addr].    handToRemove withdrawFromWorld.! !!HandMorph methodsFor: 'remote morphic' stamp: 'jm 9/26/97 07:47'!reportLocalAddress    "Report the local host address of this computer."    | addrString m s |    Socket initializeNetwork.    addrString _ NetNameResolver localAddressString.    m _ RectangleMorph new        color: (Color r: 0.6 g: 0.8 b: 0.6);        extent: 118@36;        borderWidth: 1.    s _ StringMorph contents: 'Local Host Address:'.    s position: m position + (5@4).    m addMorph: s.    s _ StringMorph contents: addrString.    s position: m position + (5@19).    m addMorph: s.    self attachMorph: m.! !!HandMorph methodsFor: 'remote morphic' stamp: 'jm 9/26/97 14:35'!startTransmittingEventsTo: addr    "Attempt to broadcast events from this hand to a remote hand on the host with the given address. This method just creates the new socket and initiates a connection; it does not wait for the other end to answer."    | sock |    remoteConnections do: [:pair |        sock _ pair first.        (sock isConnected and: [sock remoteAddress = addr])            ifTrue: [^ self]].  "don't connect if already connected to the given address"    Transcript        show: 'Connecting to remote WorldMorph at ';        show: (NetNameResolver stringFromAddress: addr), ' ...'; cr.    sock _ SimpleClientSocket new.    sock connectTo: addr port: 54323.    remoteConnections add: (Array with: sock with: #opening with: addr).! !!HandMorph methodsFor: 'remote morphic' stamp: 'jm 9/26/97 14:35'!stopTransmittingEventsTo: addr    "Stop broadcasting events from this world's cursor to a remote cursor on the host with the given address. This method issues a 'close' but does not destroy the socket; it will be destroyed when the other end reads the last data and closes the connection."    | sock |    remoteConnections do: [:triple |        sock _ triple first.        (sock isUnconnectedOrInvalid not and: [sock remoteAddress = addr]) ifTrue: [            sock close.            triple at: 2 put: #closing]].! !!HandMorph methodsFor: 'remote morphic' stamp: 'jm 9/26/97 14:41'!transmitEvent: aMorphicEvent    "Transmit the given event to all remote connections."    | evtString sock status firstEvt |    lastEventTransmitted = aMorphicEvent ifTrue: [^ self].    evtString _ aMorphicEvent storeString, (String with: Character cr).    self cleanupDeadConnections.    remoteConnections do: [:triple |        sock _ triple first.        status _ triple at: 2.        sock isConnected            ifTrue: [                status = #opening ifTrue: [                    "connection established; send worldExtent as first event"                    firstEvt _ MorphicEvent newWorldExtent: self worldBounds extent.                    sock sendData: firstEvt storeString, (String with: Character cr).                    Transcript                        show: 'Connection established with remote WorldMorph at ';                        show: (NetNameResolver stringFromAddress: sock remoteAddress); cr.                    triple at: 2 put: #connected].                sock sendData: evtString]            ifFalse: [                status = #connected ifTrue: [                    "other end has closed; close our end"                    Transcript                        show: 'Closing connection with remote WorldMorph at ';                        show: (NetNameResolver stringFromAddress: sock remoteAddress); cr.                    sock close.                    triple at: 2 put: #closing]]].    lastEventTransmitted _ aMorphicEvent.! !!HandMorph methodsFor: 'remote morphic' stamp: 'jm 9/26/97 10:35'!worldBounds    ^ self world bounds! !!HandMorph class methodsFor: 'all'!doubleClickTime    ^ DoubleClickTime! !!HandMorph class methodsFor: 'all'!doubleClickTime: milliseconds    DoubleClickTime _ milliseconds.! !!HandMorph class methodsFor: 'all'!initialize    "HandMorph initialize"    ColorChart _ nil.    DoubleClickTime _ 280.    NormalCursor _ ColorForm transparentFrom: Cursor normal.    BlankCursor _ ColorForm transparentFrom: Cursor blank.    UseHardwareCursor _ false.! !!HandMorph class methodsFor: 'instance creation' stamp: 'di 6/22/97 09:07'!includeInNewMorphMenu    "Not to be instantiated from the menu"    ^ false! !!HeadingMorph methodsFor: 'initialization'!initialize    super initialize.    self color: (Color r:0.6 g: 1.0 b: 1.0).    degrees _ 90.0.    magnitude _ 1.0.    self borderWidth: 1.    self extent: 160@160.! !!HeadingMorph methodsFor: 'accessing'!degrees    ^ (degrees + 90.0) \\ 360.0! !!HeadingMorph methodsFor: 'accessing'!degrees: aNumber    degrees _ (aNumber asFloat + 270.0) \\ 360.0.! !!HeadingMorph methodsFor: 'accessing'!extent: aPoint    "Contrain extent to be square."    | d |    d _ aPoint x min: aPoint y.    super extent: d@d.! !!HeadingMorph methodsFor: 'accessing'!magnitude    ^ magnitude! !!HeadingMorph methodsFor: 'accessing'!magnitude: aNumber    magnitude _ (aNumber asFloat max: 0.0) min: 1.0.! !!HeadingMorph methodsFor: 'drawing'!drawArrowFrom: p1 to: p2 width: w color: aColor on: aCanvas    | d p |    d _ (p1 - p2) theta radiansToDegrees.    aCanvas line: p1 to: p2 width: w color: aColor.    p _ p2 + (Point r: 5 degrees: d - 50).    aCanvas line: p to: p2 width: w color: aColor.    p _ p2 + (Point r: 5 degrees: d + 50).    aCanvas line: p to: p2 width: w color: aColor.! !!HeadingMorph methodsFor: 'drawing'!drawOn: aCanvas    | x y r center box |    super drawOn: aCanvas.    box _ self innerBounds.    1 to: 9 do: [:i |        x _ box left + ((box width * i) // 10).        aCanvas line: (x@box top) to: (x@(box bottom - 1)) color: Color black.        y _ box top + ((box height * i) // 10).        aCanvas line: (box left@y) to: ((box right - 1)@y) color: Color black].    r _ ((box width asFloat * magnitude asFloat) / 2.0) - 1.0.    center _ box center.    self drawArrowFrom: center - (1@1)        to: center + ((r * degrees degreesToRadians cos)@0) - (1@1)        width: 3        color: (Color red)        on: aCanvas.    self drawArrowFrom: center - (1@1)        to: center + (0@(r * degrees degreesToRadians sin)) - (1@1)        width: 3        color: (Color red)        on: aCanvas.    self drawArrowFrom: center - (1@1)        to: center + (Point r: r degrees: degrees) - (1@1)        width: 3        color: Color black        on: aCanvas.! !!HeadingMorph methodsFor: 'events'!handlesMouseDown: evt    ^ true! !!HeadingMorph methodsFor: 'events'!mouseMove: evt    | v |    self changed.    v _ evt cursorPoint - bounds center.    degrees _ v theta radiansToDegrees.    magnitude _ (v r asFloat / (bounds width asFloat / 2.0)) min: 1.0.! !HierarchicalMenu comment:'Created by Dan Ingalls back in 1985-6, but not currently maintained or used.'!!HierarchicalMenu class methodsFor: 'instance creation'!labelList: labelList lines: lines selections: selections    | topLabels topSelections deeperMenus item |    topLabels _ OrderedCollection new.    topSelections _ OrderedCollection new.    deeperMenus _ OrderedCollection new.    1 to: labelList size do:        [:i | item _ labelList at: i.        (item isMemberOf: Array)            ifTrue: [topLabels addLast: item first.                    deeperMenus addLast:                    (HierarchicalMenu labelList: item allButFirst                                    selections: (selections at: i))]            ifFalse: [topLabels addLast: item.                    deeperMenus addLast: nil].                topSelections addLast: (selections at: i)].    ^ (super labelList: topLabels asArray lines: lines selections: topSelections asArray)        deeperMenus: deeperMenus asArray! !!HierarchyBrowser methodsFor: 'initialization'!classList    ^ classList! !!HierarchyBrowser methodsFor: 'initialization'!classListIndex: newIndex    "Cause system organization to reflect appropriate category"    | newClassName |    newIndex ~= 0 ifTrue:        [newClassName _ (classList at: newIndex) copyWithout: $ .        systemCategoryListIndex _            systemOrganizer numberOfCategoryOfElement: newClassName.        self changed: #systemCategorySelectionChanged].    ^ super classListIndex: newIndex! !!HierarchyBrowser methodsFor: 'initialization'!initAlphabeticListing    | tab stab index |    self systemOrganizer: SystemOrganization.    metaClassIndicated _ false.    classList _ Smalltalk classNames.! !!HierarchyBrowser methodsFor: 'initialization' stamp: 'sw 11/27/96'!initForClassList: classNames    "Initialize the receiver for use with the provided list of class names.   "    self systemOrganizer: SystemOrganization.    metaClassIndicated _ false.    classList _ classNames! !!HierarchyBrowser methodsFor: 'initialization'!initHierarchyForClass: theClass meta: meta    | tab stab index |    self systemOrganizer: SystemOrganization.    metaClassIndicated _ meta.    classList _ OrderedCollection new.    tab _ ''.    theClass allSuperclasses reverseDo:         [:aClass |         classList add: tab , aClass name.        tab _ tab , '  '].    index _ classList size + 1.    theClass allSubclassesWithLevelDo:        [:aClass :level |        stab _ ''.  1 to: level do: [:i | stab _ stab , '  '].        classList add: tab , stab , aClass name]         startingLevel: 0.    self classListIndex: index! !!HierarchyBrowser methodsFor: 'initialization'!selectClass: classNotMeta    | name |    name _ classNotMeta name.    self classListIndex: (self classList findFirst:            [:each | (each endsWith: name)                    and: [each size = name size                            or: [(each at: each size - name size) isSeparator]]])! !!HierarchyBrowser methodsFor: 'initialization' stamp: 'sw 12/4/96'!selectedClassName    "Answer the name of the class currently selected.   di      bug fix for the case where name cannot be found -- return nil rather than halt"    | aName |    aName _ super selectedClassName.    ^ aName == nil        ifTrue:            [aName]        ifFalse:            [(aName copyWithout: $ ) asSymbol]! !!HolderMorph methodsFor: 'initialization'!initialize    super initialize.    self borderWidth: 1.    self extent: 240@160.    color _ Color r: 0.8 g: 1.0 b: 0.6.    cursorColor _ Color black.    cursor _ 1.    padding _ 3.    openToDragNDrop _ true.! !!HolderMorph methodsFor: 'accessing'!cursor        ^ cursor! !!HolderMorph methodsFor: 'accessing'!cursor: aNumber    "Set the cursor to the given number, modulo the number of items I contain. Fractional cursor values are allowed."    | truncP |    cursor ~= aNumber ifTrue:  [        cursor _ self asNumber: aNumber.        truncP _ cursor truncated.        truncP > submorphs size ifTrue: [            submorphs size > 0                ifTrue: [cursor _ cursor \\ submorphs size]                ifFalse: [cursor _ 1]].        truncP < 0 ifTrue: [cursor _ 1].        self changed].! !!HolderMorph methodsFor: 'accessing'!cursorAtEnd    ^ cursor truncated >= submorphs size! !!HolderMorph methodsFor: 'accessing'!cursorColor    ^ cursorColor! !!HolderMorph methodsFor: 'accessing'!cursorColor: aColor    cursorColor _ aColor.! !!HolderMorph methodsFor: 'accessing'!openToDragNDrop    ^ openToDragNDrop! !!HolderMorph methodsFor: 'accessing'!openToDragNDrop: aBoolean    openToDragNDrop _ aBoolean.! !!HolderMorph methodsFor: 'accessing'!parts    "Return an array of part names for use in e-toys."    ^ #(position cursor valueAtCursor)! !!HolderMorph methodsFor: 'accessing'!valueAtCursor    submorphs isEmpty ifTrue: [^ 0].    ^ submorphs at: ((cursor truncated max: 1) min: submorphs size)! !!HolderMorph methodsFor: 'accessing'!valueAtCursor: aValue    "Ignored for now. To implement this, we need a way to turn arbitrary Smalltalk objects into Morphs."! !!HolderMorph methodsFor: 'drawing'!drawOn: aCanvas    "Draw a border around the item pointed to by the pointer."    super drawOn: aCanvas.    submorphs size > 0 ifTrue: [        aCanvas            frameRectangle: self selectedRect            width: 2            color: Color black].! !!HolderMorph methodsFor: 'geometry'!fullBounds    "This is the hook that triggers lazy re-layout. See the comment in LayoutMorph."    fullBounds ifNil: [        self fixLayout.        "compute fullBounds before calling changed to avoid infinite recursion!!"        super fullBounds.  "updates cache"        self changed].    ^ super fullBounds! !!HolderMorph methodsFor: 'dropping/grabbing' stamp: 'jm 6/11/97 17:17'!acceptDroppingMorph: aMorph event: evt    aMorph submorphsDo: [:m | (m isKindOf: MouseOverHandlesMorph) ifTrue: [m delete]].    self privateAddMorph: aMorph atIndex: (self insertionIndexFor: aMorph).    self changed.    self layoutChanged.! !!HolderMorph methodsFor: 'dropping/grabbing'!allowSubmorphExtraction    ^ openToDragNDrop! !!HolderMorph methodsFor: 'dropping/grabbing'!wantsDroppedMorph: aMorph event: evt    ^ openToDragNDrop! !!HolderMorph methodsFor: 'private'!fixLayout    "Pack my submorphs into rows that fit within my width."    | nextY i morphsForThisRow |    nextY _ bounds top + borderWidth.    i _ 1.    [i <= submorphs size] whileTrue: [        morphsForThisRow _ self rowMorphsStartingAt: i.        nextY _ self layoutRow: morphsForThisRow lastRowBase: nextY.        i _ i + morphsForThisRow size].! !!HolderMorph methodsFor: 'private'!insertionIndexFor: aMorph    "Find the right place to put the given dropped morph."    "Not yet finished!!"    | mCenter |    mCenter _ aMorph fullBounds center.    submorphs doWithIndex: [:m :i |        mCenter y < m fullBounds center y ifTrue: [^ i]].    ^ submorphs size + 1! !!HolderMorph methodsFor: 'private'!layoutRow: mList lastRowBase: lastRowBase    | maxH rowBase nextX |    maxH _ 0.    mList do: [:m | maxH _ maxH max: m fullBounds height].    rowBase _ lastRowBase + maxH + padding.    nextX _ bounds left + borderWidth + padding.    mList do: [:m |        m position: nextX @ (rowBase - m fullBounds height).        nextX _ nextX + m fullBounds width + padding].    ^ rowBase! !!HolderMorph methodsFor: 'private'!rowMorphsStartingAt: startIndex    "Return a collection of morphs for a row starting at the given index. Put at least one morph into the row, even if it sticks out."    | mList nextX lastIndex m |    mList _ OrderedCollection new.    nextX _ bounds left + borderWidth + padding.    lastIndex _ submorphs size.    startIndex to: lastIndex do: [:i |        m _ submorphs at: i.        nextX _ nextX + m fullBounds width + padding.        nextX > bounds right ifTrue: [            mList isEmpty ifTrue: [mList add: m].            ^ mList].        mList add: m].    ^ mList! !!HolderMorph methodsFor: 'private'!selectedRect    "Return a rectangle enclosing the morph at the current cursor. Note that the cursor may be a float and may be out of range, so pick the nearest morph. Assume there is at least one submorph."    | p |    p _ cursor asInteger.    p > submorphs size ifTrue: [p _ submorphs size].    p < 1 ifTrue: [p _ 1].    ^ (submorphs at: p) fullBounds expandBy: 2.! !!HtmlFileStream methodsFor: 'all' stamp: 'di 6/28/97 08:35'!copyMethodChunkFrom: aStream    "Overridden to bolden the first line (presumably a method header)"    | terminator code firstLine |    terminator _ $!!.    aStream skipSeparators.    code _ aStream upTo: terminator.    firstLine _ code copyUpTo: Character cr.    firstLine size = code size        ifTrue: [self nextPutAll: code]        ifFalse: [self command: 'b'; nextPutAll: firstLine; command: '/b'.                self nextPutAll: (code copyFrom: firstLine size + 1 to: code size)].    self nextPut: terminator.    [aStream peekFor: terminator] whileTrue:   "case of imbedded (doubled) terminators"            [self nextPut: terminator;                nextPutAll: (aStream upTo: terminator);                nextPut: terminator]! !!HtmlFileStream methodsFor: 'all' stamp: 'di 6/28/97 09:21'!copyPreamble: preamble from: aStream    "Make method category preambles bold at category changes."    prevPreamble = preamble        ifTrue: [super copyPreamble: preamble from: aStream]        ifFalse: [self command: 'H3'.                super copyPreamble: preamble from: aStream.                self command: '/H3'.                prevPreamble _ preamble]! !!HtmlFileStream methodsFor: 'all' stamp: 'di 6/28/97 21:49'!header    "append the HTML header.  Be sure to call trailer after you put out the data.    4/4/96 tk"    | cr |    cr _ String with: Character cr.    self command: 'HTML'; verbatim: cr.    self command: 'HEAD'; verbatim: cr.    self command: 'TITLE'.    self nextPutAll: '"', self name, '"'.    self command: '/TITLE'; verbatim: cr.    self command: '/HEAD'; verbatim: cr.    self command: 'BODY'; verbatim: cr.! !!HtmlFileStream methodsFor: 'all' stamp: 'di 6/28/97 21:43'!nextChunk    "Answer the contents of the receiver, up to the next terminator character (!!).  Imbedded terminators are doubled.  Undo and strip out all Html stuff in the stream and convert the characters back.  4/12/96 tk"    | out char did rest |    self skipSeparators.    "Absorb <...><...> also"    out _ WriteStream on: (String new: 500).    [self atEnd] whileFalse: [        self peek = $< ifTrue: [self unCommand].    "Absorb <...><...>"        (char _ self next) = $&            ifTrue: [                rest _ self upTo: $;.                did _ out position.                rest = 'lt' ifTrue: [out nextPut: $<].                rest = 'gt' ifTrue: [out nextPut: $>].                rest = 'amp' ifTrue: [out nextPut: $&].                did = out position ifTrue: [                    self error: 'new HTML char encoding'.                    "Please add it to this code"]]            ifFalse: [char = $!!    "terminator"                ifTrue: [                    self peek = $!! ifFalse: [^ out contents].                    out nextPut: self next]    "pass on one $!!"                ifFalse: [char asciiValue = 9                            ifTrue: [self next; next; next; next "TabThing"].                        out nextPut: char]]        ].    ^ out contents! !!HtmlFileStream methodsFor: 'all' stamp: 'di 6/28/97 21:59'!nextPut: char    "Put a character on the file, but translate it first. 4/6/96 tk"    char = $< ifTrue: [^ super nextPutAll: '<'].    char = $> ifTrue: [^ super nextPutAll: '>'].    char = $& ifTrue: [^ super nextPutAll: '&'].    char asciiValue = 13 "return" ifTrue: [            self command: 'br'].    char = $    "tab" ifTrue:        [super nextPut: char.  ^ self verbatim: TabThing].    ^ super nextPut: char! !!HtmlFileStream class methodsFor: 'as yet unclassified' stamp: 'di 6/28/97 21:31'!initialize   "HtmlFileStream initialize"    TabThing _ String        with: (Character value: 1)        with: (Character value: 32)        with: (Character value: 1)        with: (Character value: 32)! !HTTPSocket comment:'HTTPSockets support HTTP requests, either directly or via an HTTP proxy server. An HTTPSocket saves the parse of the last ACSII header it saw to avoid having to parse it repeatedly.'!!HTTPSocket methodsFor: 'all' stamp: 'jm 9/15/97 11:35'!contentsLength: header    "extract the data length from the header.  Content-length: 1234<cr><lf>,  User may look in headerTokens afterwards."    | this |    headerTokens _ header findTokens: ParamDelimiters keep: (String with: CR).    1 to: headerTokens size do: [:ii |         this _ headerTokens at: ii.        (this first asLowercase = $c and: [this asLowercase = 'content-length:']) ifTrue: [            ^ (headerTokens at: ii+1) asNumber]].    ^ nil    "not found"! !!HTTPSocket methodsFor: 'all' stamp: 'jm 9/15/97 14:57'!getResponseUpTo: markerString    "Keep reading until the marker is seen.  Return three parts: header, marker, beginningOfData.  Fails if no marker in first 2000 chars."     | buf response bytesRead tester mm |    buf _ String new: 2000.    response _ WriteStream on: buf.    tester _ 1. mm _ 1.    [tester to: response position do: [:tt |        (buf at: tt) = (markerString at: mm) ifTrue: [mm _ mm + 1] ifFalse: [mm _ 1].            "Not totally correct for markers like xx0xx"        mm > markerString size ifTrue: ["got it"            ^ Array with: (buf copyFrom: 1 to: tt+1-mm)                with: markerString                with: (buf copyFrom: tt+1 to: response position)]].     tester _ 1 max: response position.    "OK if mm in the middle"     (response position < buf size) & (self dataAvailable | self isConnected)] whileTrue: [        (self waitForDataUntil: (Socket deadlineSecs: 5)) ifFalse: [            Transcript show: 'data was late'; cr].        bytesRead _ self primSocket: socketHandle receiveDataInto: buf             startingAt: response position + 1 count: buf size - response position.        "response position+1 to: response position+bytesRead do: [:ii |             response nextPut: (buf at: ii)].    totally redundant, but needed to advance position!!"        response instVarAt: 2 "position" put:             (response position + bytesRead)].    "horrible, but fast"    ^ Array with: response contents        with: ''        with: ''        "Marker not found and connection closed"! !!HTTPSocket methodsFor: 'all' stamp: 'jm 9/15/97 14:55'!getRestOfBuffer: beginning totalLength: length    "Reel in a string of a fixed length.  Part of it has already been received.  Close the connection after all chars are received.  We do not strip out linefeed chars.  tk 6/16/97 22:32"     | buf response bytesRead |    length isInteger ifFalse: [self error: 'header parsed wrongly'].    buf _ String new: length.    response _ RWBinaryOrTextStream on: buf.    response nextPutAll: beginning.    [(response position < length) & (self dataAvailable | self isConnected)] whileTrue: [        (self waitForDataUntil: (Socket deadlineSecs: 5)) ifFalse: [            Transcript show: 'data was late'; cr].        bytesRead _ self primSocket: socketHandle receiveDataInto: buf             startingAt: response position + 1 count: buf size - response position.        "bytesRead = 0 ifTrue: [self error: 'why no data?']."        "response position+1 to: response position+bytesRead do: [:ii |             response nextPut: (buf at: ii)].    totally redundant, but needed to advance position!!"        response instVarAt: 2 "position" put:             (response position + bytesRead)].    "horrible, but fast"    Transcript cr; show: 'data byte count: ', response position printString.    Transcript cr; show: ((self isConnected) ifTrue: ['Over length by: ', bytesRead printString]         ifFalse: ['Socket closed']).     "response text.    is already a text stream"    response reset.    "position: 0."    ^ response! !!HTTPSocket methodsFor: 'all' stamp: 'jm 9/26/97 17:27'!redirect    "See if the header has a 'Location: url CrLf' in it.  If so, return the new URL of this page.  tk 6/24/97 18:03"    | this |    1 to: headerTokens size do: [:ii |         this _ headerTokens at: ii.        (this first asLowercase = $l and: [this asLowercase = 'location:']) ifTrue: [            ^ (headerTokens at: ii+1)]].    ^ nil    "not found"! !!HTTPSocket class methodsFor: 'class initialization' stamp: 'jm 9/15/97 11:30'!initialize    "HTTPSocket initialize"    ParamDelimiters _ ' ', CrLf.    HTTPPort _ 80.    HTTPProxy _ nil.    HTTPBlabEmail _ ''.  "    'From: [e-mail]', CrLf    "! !!HTTPSocket class methodsFor: 'examples' stamp: 'jm 9/15/97 12:15'!httpFileIn: url    "Do a regular file-in of a file that is served from a web site.  If the file contains an EToy, then open it.  Might just be code instead.  tk 7/23/97 17:10"    "Notes: To store a file on an HTTP server, use the program 'Fetch'.  After indicating what file to store, choose 'Raw Data' from the popup menu that has MacBinary/Text/etc.  Use any file extension as long as it is not one of the common ones.  The server does not have to know about the .sqo extension in order to send your file.  (We do not need a new MIME type and .sqo does not have to be registered with the server.)"    "    HTTPSocket httpFileIn: 'www.webPage.com/~kaehler2/sample.etoy'     "    "    HTTPSocket httpFileIn: '206.18.68.12/squeak/car.sqo'     "    "    HTTPSocket httpFileIn: 'jumbo/tedk/sample.etoy'     "    | doc eToyHolder |    doc _ self httpGet: url accept: 'application/octet-stream'.    doc reset.    eToyHolder _ doc fileInObjectAndCode.    eToyHolder ifNotNil: [eToyHolder open].    "Later may want to return it, instead of open it"! !!HTTPSocket class methodsFor: 'examples' stamp: 'jm 10/4/97 15:57'!httpGet: url    "Return the exact contents of a web page or other web object. The parsed header is saved.  Use a proxy server if one has been registered.  tk 7/23/97 17:21"    "    HTTPSocket httpShowPage: 'http://www.altavista.digital.com/index.html'     "    "    HTTPSocket httpShowPage: 'www.webPage.com/~kaehler2/ab.html'     "    "    HTTPSocket httpShowPage: 'www.exploratorium.edu/index.html'     "    "    HTTPSocket httpShowPage: 'www.apple.com/default.html'     "    "    HTTPSocket httpShowPage: 'www.altavista.digital.com/'     "    "    HTTPSocket httpShowPage: 'jumbo/tedk/ab.html'     "    ^ self httpGet: url accept: 'application/octet-stream'! !!HTTPSocket class methodsFor: 'examples' stamp: 'jm 9/15/97 12:13'!httpGet: url accept: mimeType    "Return the exact contents of a web object. Asks for the given MIME type. If mimeType is nil, use 'text/html'. The parsed header is saved. Use a proxy server if one has been registered.  tk 7/23/97 17:12"    "Note: To fetch raw data, you can use the MIMI type 'application/octet-stream'."    | serverName serverAddr s header length bare page list firstData aStream newURL |    Socket initializeNetwork.    bare _ (url asLowercase beginsWith: 'http://')         ifTrue: [url copyFrom: 8 to: url size]        ifFalse: [url].    "For now, may not put :80 or other port number in a url.  Use setHTTPPort:"    serverName _ bare copyUpTo: $/.    page _ bare copyFrom: serverName size + 1 to: bare size.    page size = 0 ifTrue: [page _ '/'].    HTTPProxy ifNotNil: [        page _ 'http://', serverName, page.        "put back together"        serverName _ HTTPProxy].        self retry: [serverAddr _ NetNameResolver addressForName: serverName timeout: 20.                serverAddr ~~ nil]         asking: 'Trouble resolving server name.  Keep trying?'        ifGiveUp: ["^ nil"            self error: 'Could not find the address for ', serverName].    s _ HTTPSocket new.    s connectTo: serverAddr port: HTTPPort.  "80 is normal"    s waitForConnectionUntil: self standardDeadline.    Transcript cr; show: serverName; cr.    s sendCommand: 'GET ', page, ' HTTP/1.0', CrLf,         (mimeType ifNotNil: ['ACCEPT: ', mimeType, CrLf] ifNil: ['']),        'ACCEPT: text/html', CrLf,    "Always accept plain text"        HTTPBlabEmail,    "may be empty"        'User-Agent: Squeak 1.19',         CrLf.    "blank line"    list _ s getResponseUpTo: CrLf, CrLf.    "list = header, CrLf, CrLf, beginningOfData"    header _ list at: 1.    Transcript show: page; cr; show: header; cr.    firstData _ list at: 3.    "Find the length"    length _ s contentsLength: header.    "saves the headerTokens"    length ifNil: [        (newURL _ s redirect) ifNotNil: [^ self httpGet: newURL].        Transcript cr; show: 'Some kind of Error'.        s destroy.   ^ header].        aStream _ s getRestOfBuffer: firstData totalLength: length.    s destroy.    "Always OK to destroy!!"    ^ aStream    "String with just the data"! !!HTTPSocket class methodsFor: 'examples' stamp: 'jm 9/15/97 12:19'!httpGif: url    "Fetch the given URL, parse it using the GIF reader, and return the resulting Form."    "    HTTPSocket httpShowGif: 'www.altavista.digital.com/av/pix/default/av-adv.gif'     "    "    HTTPSocket httpShowGif: 'www.webPage.com/~kaehler2/ainslie.gif'     "    | doc ggg |    doc _ self httpGet: url.    doc binary; reset.    (ggg _ Smalltalk gifReaderClass new) setStream: doc.    ^ ggg nextImage.! !!HTTPSocket class methodsFor: 'examples' stamp: 'jm 9/15/97 12:18'!httpShowGif: url    "Display the picture retrieved from the given URL, which is assumed to be a GIF file. See examples in httpGif:."    | nameTokens |    nameTokens _ url findTokens: '/'.    FormView open: (self httpGif: url) named: nameTokens last.! !!HTTPSocket class methodsFor: 'examples' stamp: 'jm 9/15/97 12:18'!httpShowPage: url    "Display the exact contents of the given URL as text. See examples in httpGet:"    | doc |    doc _ (self httpGet: url) contents.    doc size = 0 ifTrue: [^ self error: 'Document could not be fetched'].    StringHolderView        open: (StringHolder new contents: doc)        label: url.! !!HTTPSocket class methodsFor: 'examples' stamp: 'jm 9/15/97 12:06'!proxyTestingComment    "Test Kevin's SmartCache on this machine"    "    HTTPSocket useProxyServerNamed: '127.0.0.1' port: 8080.        HTTPSocket httpShowPage: 'http://www.disneyblast.com/default.html'.        HTTPSocket stopUsingProxyServer.    "    "Test getting to outside world from DOL"    "    HTTPSocket useProxyServerNamed: 'web-proxy.online.disney.com' port: 8080.        HTTPSocket httpShowPage: 'http://www.apple.com/default.html'.        HTTPSocket stopUsingProxyServer.    "    "Test Windows Machine in our cubicle at DOL"    "    HTTPSocket useProxyServerNamed: '206.18.67.150' port: 8080.        HTTPSocket httpShowPage: 'http://kids.online.disney.com/~kevin/squeak/k_t.morph'.        HTTPSocket stopUsingProxyServer.    "    "    HTTPSocket httpShowPage: 'kids.online.disney.com/'    "    "    HTTPSocket httpShowGif: 'kids.online.disney.com/~kevin/images/dlogo.gif'    "! !!HTTPSocket class methodsFor: 'proxy settings' stamp: 'jm 9/15/97 12:06'!stopUsingProxyServer    "Stop directing HTTP request through a proxy server."    HTTPProxy _ nil.    HTTPPort _ 80.! !!HTTPSocket class methodsFor: 'proxy settings'!useProxyServerNamed: proxyServerName port: portNum    "Direct all HTTP requests to the HTTP proxy server with the given name and port number."    "HTTPSocket useProxyServerNamed: 'web-proxy.disney.com' port: 8080"    proxyServerName ifNil: [  "clear proxy settings"        HTTPProxy _ nil.        HTTPPort _ 80.        ^ self].    proxyServerName class == String        ifFalse: [self error: 'Server name must be a String or nil'].    HTTPProxy _ proxyServerName.    HTTPPort _ portNum.    HTTPPort class == String ifTrue: [HTTPPort _ portNum asNumber].    HTTPPort ifNil: [HTTPPort _ 80].! !!HTTPSocket class methodsFor: 'utilities' stamp: 'jm 9/15/97 11:10'!retry: tryBlock asking: troubleString ifGiveUp: abortActionBlock    "Execute the given block. If it evaluates to true, return true. If it evaluates to false, prompt the user with the given string to see if he wants to try again. If not, evaluate the abortActionBlock and return false."    | response |    [tryBlock value] whileFalse: [        response _ (PopUpMenu labels: 'Retry\Give Up' withCRs)            startUpWithCaption: troubleString.        response = 2 ifTrue: [abortActionBlock value. ^ false]].    ^ true! !!IdentityDictionary methodsFor: 'private'!scanFor: anObject    "Scan the key array for the first slot containing either a nil (indicating an empty slot) or an element that matches anObject. Answer the index of that slot or zero if no slot is found. This method will be overridden in various subclasses that have different interpretations for matching elements."    | element start finish |    start _ (anObject identityHash \\ array size) + 1.    finish _ array size.    "Search from (hash mod size) to the end."    start to: finish do:        [:index | ((element _ array at: index) == nil or: [element key == anObject])            ifTrue: [^ index ]].    "Search from 1 to where we started."    1 to: start-1 do:        [:index | ((element _ array at: index) == nil or: [element key == anObject])            ifTrue: [^ index ]].    ^ 0  "No match AND no empty slot"! !!IdentitySet methodsFor: 'private'!scanFor: anObject    "Scan the key array for the first slot containing either a nil (indicating an empty slot) or an element that matches anObject. Answer the index of that slot or zero if no slot is found. This method will be overridden in various subclasses that have different interpretations for matching elements."    | element start finish |    start _ (anObject identityHash \\ array size) + 1.    finish _ array size.    "Search from (hash mod size) to the end."    start to: finish do:        [:index | ((element _ array at: index) == nil or: [element == anObject])            ifTrue: [^ index ]].    "Search from 1 to where we started."    1 to: start-1 do:        [:index | ((element _ array at: index) == nil or: [element == anObject])            ifTrue: [^ index ]].    ^ 0  "No match AND no empty slot"! !!ImageMorph methodsFor: 'all' stamp: 'jm 9/28/97 17:21'!addCustomMenuItems: aCustomMenu hand: aHandMorph    aCustomMenu add: 'read from file' action: #readFromFile.    aCustomMenu add: 'grab from screen' action: #grabFromScreen.! !!ImageMorph methodsFor: 'all'!drawOn: aCanvas    aCanvas image: image at: bounds origin! !!ImageMorph methodsFor: 'all'!extent    ^ image extent! !!ImageMorph methodsFor: 'all'!extent: aPoint    super extent: image extent! !!ImageMorph methodsFor: 'all'!grabFromScreen    self image: Form fromUser! !!ImageMorph methodsFor: 'all'!image: anImage    anImage depth = 1        ifTrue: [image _ ColorForm transparentFrom: anImage]        ifFalse: [image _ anImage].    self extent: anImage extent.! !!ImageMorph methodsFor: 'all'!initialize    | d h p |    super initialize.    self image: (Form extent: 80@40 depth: Display depth).    h _ image height // 2.    0 to: h-1 do:         [:i | p _ (i*2)@i.  d _ i asFloat / h asFloat.        image fill: (p corner: image extent - p) fillColor: (Color r: d g: 0.5 b: 1.0-d)]! !!ImageMorph methodsFor: 'all'!readFromFile    self readFromFileNamed:        (FillInTheBlank request: 'Please enter the image file name'                    initialAnswer: 'fileName')! !!ImageMorph methodsFor: 'all'!readFromFileNamed: fName    | file fileCode form |    file _ FileStream readOnlyFileNamed: fName.    fileCode _ file next asciiValue.    file close.    form _ (fileCode = 2        ifTrue: [Form newFromFileNamed: fName]        ifFalse: [Smalltalk gifReaderClass formFromFileNamed: fName]).    self image: form.! !ImageReadWriter comment:'Copyright (c) Kazuki Yasumatsu, 1995. All rights reserved.I am an abstract class to provide for encoding and/or decoding an image ona stream.Instance Variables:    stream        <ReadStream | WriteStream>    stream for imagestoragesClass Variables:    ImageNotStoredSignal        <Signal>    image not storederror signal    MagicNumberErrorSignal        <Signal>    magic number errorsignalSubclasses must implement the following messages:    accessing        nextImage        nextPutImage:'!!ImageReadWriter methodsFor: 'accessing'!nextImage    "Dencoding an image on stream and answer the image."    ^self subclassResponsibility! !!ImageReadWriter methodsFor: 'accessing'!nextPutImage: anImage    "Encoding anImage on stream."    ^self subclassResponsibility! !!ImageReadWriter methodsFor: 'stream access'!atEnd    ^stream atEnd! !!ImageReadWriter methodsFor: 'stream access'!close    "close if you can"    (stream respondsTo: #close) ifTrue: [            stream closed ifFalse: [stream close]]! !!ImageReadWriter methodsFor: 'stream access'!contents    ^stream contents! !!ImageReadWriter methodsFor: 'stream access'!cr    ^stream nextPut: Character cr asInteger! !!ImageReadWriter methodsFor: 'stream access'!lf    "PPM and PBM are used LF as CR."    ^stream nextPut: Character lf asInteger! !!ImageReadWriter methodsFor: 'stream access'!next    ^stream next! !!ImageReadWriter methodsFor: 'stream access'!next: size    ^stream next: size! !!ImageReadWriter methodsFor: 'stream access'!nextLong    "Read a 32-bit quantity from the input stream."    ^(stream next bitShift: 24) + (stream next bitShift: 16) +        (stream next bitShift: 8) + stream next! !!ImageReadWriter methodsFor: 'stream access'!nextLongPut: a32BitW    "Write out a 32-bit integer as 32 bits."    stream nextPut: ((a32BitW bitShift: -24) bitAnd: 16rFF).    stream nextPut: ((a32BitW bitShift: -16) bitAnd: 16rFF).    stream nextPut: ((a32BitW bitShift: -8) bitAnd: 16rFF).    stream nextPut: (a32BitW bitAnd: 16rFF).    ^a32BitW! !!ImageReadWriter methodsFor: 'stream access'!nextPut: aByte    ^stream nextPut: aByte! !!ImageReadWriter methodsFor: 'stream access'!nextPutAll: aByteArray    ^stream nextPutAll: aByteArray! !!ImageReadWriter methodsFor: 'stream access'!nextWord    "Read a 16-bit quantity from the input stream."    ^(stream next bitShift: 8) + stream next! !!ImageReadWriter methodsFor: 'stream access'!nextWordPut: a16BitW    "Write out a 16-bit integer as 16 bits."    stream nextPut: ((a16BitW bitShift: -8) bitAnd: 16rFF).    stream nextPut: (a16BitW bitAnd: 16rFF).    ^a16BitW! !!ImageReadWriter methodsFor: 'stream access'!position    ^stream position! !!ImageReadWriter methodsFor: 'stream access'!position: anInteger    ^stream position: anInteger! !!ImageReadWriter methodsFor: 'stream access'!size    ^stream size! !!ImageReadWriter methodsFor: 'stream access'!skip: anInteger    ^stream skip: anInteger! !!ImageReadWriter methodsFor: 'stream access'!space    ^stream nextPut: Character space asInteger! !!ImageReadWriter methodsFor: 'stream access'!tab    ^stream nextPut: Character tab asInteger! !!ImageReadWriter methodsFor: 'private'!changePadOfBits: bits width: width height: height depth: depth from: oldPadto: newPad    "Change padding size of bits."    | srcRowByteSize dstRowByteSize newBits srcRowBase rowEndOffset |    (#(8 16 32) includes: oldPad)        ifFalse: [^self error: 'Invalid pad: ', oldPad printString].    (#(8 16 32) includes: newPad)        ifFalse: [^self error: 'Invalid pad: ', newPad printString].    srcRowByteSize _ width * depth + oldPad - 1 // oldPad * (oldPad / 8).    srcRowByteSize * height = bits size        ifFalse: [^self error: 'Incorrect bitmap array size.'].    dstRowByteSize _ width * depth + newPad - 1 // newPad * (newPad / 8).    newBits _ ByteArray new: dstRowByteSize * height.    srcRowBase _ 1.    rowEndOffset _ dstRowByteSize - 1.    1 to: newBits size by: dstRowByteSize do:        [:dstRowBase |        newBits replaceFrom: dstRowBase            to: dstRowBase + rowEndOffset            with: bits            startingAt: srcRowBase.        srcRowBase _ srcRowBase + srcRowByteSize].    ^newBits! !!ImageReadWriter methodsFor: 'private'!hasMagicNumber: aByteArray    | position |    position _ stream position.    ((stream size - position) >= aByteArray size and:    [(stream next: aByteArray size)  = aByteArray])        ifTrue: [^true].    stream position: position.    ^false! !!ImageReadWriter methodsFor: 'private'!on: aStream    "Read it all into memory and use that as a stream to read from.  TK29 May 96"    (aStream respondsTo: #binary) ifTrue: [aStream binary].    stream _ ReadWriteStream with: (aStream contentsOfEntireFile).    stream reset.! !!ImageReadWriter methodsFor: 'private'!unpackBits: bits depthTo8From: depth with: width height: height pad: pad    "Unpack bits of depth 1, 2, or 4 image to it of depth 8 image."    | bitMask pixelInByte bitsWidth upBitsWidth stopWidth     trailingSize upBits bitIndex upBitIndex val |    (#(1 2 4) includes: depth)        ifFalse: [^self error: 'depth must be 1, 2, or 4'].    (#(8 16 32) includes: pad)        ifFalse: [^self error: 'pad must be 8, 16, or 32'].    bitMask _ (1 bitShift: depth) - 1.    pixelInByte _ 8 / depth.    bitsWidth _ width * depth + pad - 1 // pad * (pad / 8).    upBitsWidth _ width * 8 + pad - 1 // pad * (pad / 8).    stopWidth _ width * depth + 7 // 8.    trailingSize _ width - (stopWidth - 1 * pixelInByte).    upBits _ ByteArray new: upBitsWidth * height.    1 to: height do: [:i |        bitIndex _ i - 1 * bitsWidth.        upBitIndex _ i - 1 * upBitsWidth.        1 to: stopWidth - 1 do: [:j |            val _ bits at: (bitIndex _ bitIndex + 1).            upBitIndex _ upBitIndex + pixelInByte.            1 to: pixelInByte do: [:k |                upBits at: (upBitIndex - k + 1) put: (val bitAnd: bitMask).                val _ val bitShift: depth negated]].        val _ (bits at: (bitIndex _ bitIndex + 1))                bitShift: depth negated * (pixelInByte - trailingSize).        upBitIndex _ upBitIndex + trailingSize.        1 to: trailingSize do: [:k |            upBits at: (upBitIndex - k + 1) put: (val bitAnd: bitMask).            val _ val bitShift: depth negated]].    ^ upBits! !!ImageReadWriter class methodsFor: 'instance creation'!on: aStream    "Answer an instance of the receiver for encoding and/or decoding images on the given."    ^ self new on: aStream! !!ImageReadWriter class methodsFor: 'image reading/writing'!formFromFileNamed: fileName    "Answer a ColorForm stored on the file with the given name."    | reader form |    reader _ self on: (FileStream oldFileNamed: fileName).    Cursor read showWhile: [        form _ reader nextImage.        reader close].    ^ form! !!ImageReadWriter class methodsFor: 'image reading/writing'!putForm: aForm onFileNamed: fileName    "Store the given form on a file of the given name."    | writer |    writer _ self on: (FileStream newFileNamed: fileName) binary.    Cursor write showWhile: [writer nextPutImage: aForm].    writer close.! !!InfiniteForm methodsFor: 'displaying' stamp: 'di 6/24/97 11:39'!displayOn: aDisplayMedium at: aDisplayPoint clippingBox: clipRectangle rule: ruleInteger fillColor: aForm    "This is the real display message, but it doesn't get used until the new    display protocol is installed."    | targetBox patternBox bb |    (patternForm isKindOf: Form) ifFalse:        [^ aDisplayMedium fill: clipRectangle rule: ruleInteger fillColor: patternForm].    "Do it iteratively"    targetBox _ aDisplayMedium boundingBox intersect: clipRectangle.    patternBox _ patternForm boundingBox.    bb _ BitBlt destForm: aDisplayMedium sourceForm: patternForm fillColor: aForm        combinationRule: ruleInteger destOrigin: 0@0 sourceOrigin: 0@0        extent: patternBox extent clipRect: clipRectangle.    bb colorMap:        (Color colorMapIfNeededFrom: patternForm depth                                   to: aDisplayMedium depth).    (targetBox left truncateTo: patternBox width)        to: targetBox right - 1 by: patternBox width do:        [:x |        (targetBox top truncateTo: patternBox height)            to: targetBox bottom - 1 by: patternBox height do:            [:y |            bb destOrigin: x@y; copyBits]]! !!InfiniteForm methodsFor: 'displaying' stamp: 'di 6/24/97 11:40'!displayOnPort: aPort at: aDisplayPoint    | targetBox patternBox saveMap |    (patternForm isKindOf: Form) 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.    aPort sourceForm: patternForm;        combinationRule: Form over;        sourceRect: (0@0 extent: patternBox extent).    saveMap _ aPort colorMap.    aPort colorMap:        (Color colorMapIfNeededFrom: patternForm depth                                   to: aPort destForm depth).    (targetBox left truncateTo: patternBox width)        to: targetBox right - 1 by: patternBox width do:        [:x |        (targetBox top truncateTo: patternBox height)            to: targetBox bottom - 1 by: patternBox height do:            [:y |            aPort destOrigin: x@y; copyBits]].    aPort colorMap: saveMap! !!InputSensor methodsFor: 'joystick'!joystickButtons: index    ^ ((self primReadJoystick: index) bitShift: -22) bitAnd: 16r71F    ! !!InputSensor methodsFor: 'joystick'!joystickOn: index    ^ (((self primReadJoystick: index) bitShift: -27) bitAnd: 1) ~= 0    ! !!InputSensor methodsFor: 'joystick'!joystickXY: index    | inputWord x y |    inputWord _ self primReadJoystick: index.    x _ (inputWord bitAnd: 16r7FF) - 16r400.    y _ ((inputWord bitShift: -11) bitAnd: 16r7FF) - 16r400.    ^ x@y    ! !!InputSensor methodsFor: 'user interrupts'!userInterruptWatcher    "Wait for user interrupts and open a notifier on the active process when one occurs."    [true] whileTrue: [        InterruptSemaphore wait.        Smalltalk shutDownSound.        [ScheduledControllers interruptName: 'User Interrupt'] fork.    ].! !!InspectListController methodsFor: 'menu messages' stamp: 'tk 4/14/97'!copyName    "Copy the name of the current variable, so the user can paste it into the window below and work with is.  If collection, do (xxx at: 1). "    | sel aClass |    model selectionUnmodifiable ifTrue: [^ view flash].    (aClass _ model object class) isVariable ifTrue: [^ view flash].    sel _ aClass allInstVarNames at: model selectionIndex - 2.    (model selection isKindOf: Collection) ifTrue: [sel _ '(',sel,' at: 1)'].    ParagraphEditor new clipboardTextPut: sel asText.    "no undo allowed"! !!InspectListController methodsFor: 'menu messages' stamp: 'sw 9/27/96'!objectReferencesToSelection    "Open a list inspector on all the objects that point to the value of the selected instance variable, if any.  "    model selectionIndex == 0 ifTrue: [^ view flash].    self controlTerminate.    Smalltalk        browseAllObjectReferencesTo: model selection        except: (Array with: model object)        ifNone: [:obj | view topView flash].! !!InspectListController class methodsFor: 'class initialization' stamp: 'tk 4/14/97'!initialize    "Initialize the menu associated with the upper-left pane of an Inspector.  1/25/96 sw: added references and browse items     : added object refs     copyName"    InspectListYellowButtonMenu _ PopUpMenu labels: 'inspectmethod refs to this inst varobjects pointing to this valuecopy namebrowse fullbrowse class'    lines: #(1 4).    InspectListYellowButtonMessages _         #(inspectSelection referencesToSelection objectReferencesToSelection copyName browseFull browseClass )    "InspectListController initialize"! !!Inspector methodsFor: 'accessing' stamp: 'sw 5/22/96'!initialExtent    "Answer the desired extent for the receiver when it is first opened on the screen.  "    ^ 250 @ 200! !!Inspector class methodsFor: 'instance creation'!openOn: anObject withEvalPane: withEval     "Create and schedule an instance of me on the model, anInspector. "    ^ self openOn: anObject withEvalPane: withEval withLabel: anObject defaultLabelForInspector! !!Inspector class methodsFor: 'instance creation'!openOn: anObject withEvalPane: withEval withLabel: label    ^ self openOn: anObject withEvalPane: withEval withLabel: label valueViewClass: InspectCodeView! !!Inspector class methodsFor: 'instance creation'!openOn: anObject withEvalPane: withEval withLabel: label valueViewClass: valueViewClass    | topView inspector listView valueView evalView |    inspector _ self inspect: anObject.    topView _ StandardSystemView new model: inspector.    listView _ InspectListView new model: inspector.        (inspector isMemberOf: DictionaryInspector)            ifTrue: [listView controller: DictionaryListController new].        listView window: (0 @ 0 extent: 40 @ 40).        listView borderWidthLeft: 2 right: 0 top: 2 bottom: 2.        topView addSubView: listView.    valueView _ valueViewClass new model: inspector.        valueView window: (0 @ 0 extent: 75 @ 40).        valueView borderWidthLeft: 2 right: 2 top: 2 bottom: 2.        topView addSubView: valueView toRightOf: listView.withEval ifTrue:    [evalView _ StringHolderView new                    model: (InspectorTrash for: inspector object).        evalView window: (0 @ 0 extent: 115 @ 20).        evalView borderWidthLeft: 2 right: 2 top: 0 bottom: 2.        topView addSubView: evalView below: listView].    topView label: label.    topView minimumSize: 180 @ 120.    topView controller open! !!InstructionStream methodsFor: 'testing' stamp: 'sn 8/22/97 21:55'!willReallySend    "Answer whether the next bytecode is a real message-send,    not blockCopy:."    | byte |    byte _ self method at: pc.    byte < 128 ifTrue: [^false].    byte == 200 ifTrue: [^false].    byte >= 176 ifTrue: [^true].    "special send or short send"    ^byte between: 131 and: 134    "long sends"! !!InstructionStream methodsFor: 'scanning'!addSelectorTo: set     "If this instruction is a send, add its selector to set."    | byte literalNumber byte2 |    byte _ self method at: pc.    byte < 128 ifTrue: [^self].    byte >= 176        ifTrue:             ["special byte or short send"            byte >= 208                ifTrue: [set add: (self method literalAt: (byte bitAnd: 15) + 1)]                ifFalse: [set add: (Smalltalk specialSelectorAt: byte - 176 + 1)]]        ifFalse:             [(byte between: 131 and: 134)                ifTrue:                     [byte2 _ self method at: pc + 1.                    byte = 131 ifTrue: [set add: (self method literalAt: byte2 \\ 32 + 1)].                    byte = 132 ifTrue: [byte2 < 64 ifTrue: [set add: (self method literalAt: (self method at: pc + 2) + 1)]].                    byte = 133 ifTrue: [set add: (self method literalAt: byte2 \\ 32 + 1)].                    byte = 134 ifTrue: [set add: (self method literalAt: byte2 \\ 64 + 1)]]]! !!InstructionStream methodsFor: 'scanning'!scanFor: scanBlock     "Answer the index of the first bytecode for which scanBlock answer true     when supplied with that bytecode."    | method end byte type |    method _ self method.    end _ method endPC.    [pc <= end]        whileTrue:             [(scanBlock value: (byte _ method at: pc)) ifTrue: [^true].            type _ byte // 16.            pc _                 type = 8                    ifTrue: ["extensions"                            pc + (#(2 2 2 2 3 2 2 1 1 1 ) at: byte \\ 16 + 1)]                    ifFalse: [type = 10                                ifTrue: [pc + 2"long jumps"]                                ifFalse: [pc + 1]]].    ^false! !!InstructionStream methodsFor: 'scanning'!thirdByte    "Answer the next bytecode."    ^self method at: pc + 2! !!InstructionStream methodsFor: 'private'!interpretExtension: offset in: method for: client    | type offset2 byte2 byte3 |    offset <=6 ifTrue:         ["Extended op codes 128-134"        byte2 _ method at: pc.        pc _ pc + 1.        offset <= 2 ifTrue:            ["128-130:  extended pushes and pops"            type _ byte2 // 64.            offset2 _ byte2 \\ 64.            offset = 0 ifTrue:                 [type = 0 ifTrue: [^ client pushReceiverVariable: offset2].                type = 1 ifTrue: [^ client pushTemporaryVariable: offset2].                type = 2  ifTrue: [^ client pushConstant: (method literalAt: offset2 + 1)].                type = 3 ifTrue: [^ client pushLiteralVariable: (method literalAt: offset2 + 1)]].            offset = 1 ifTrue:                 [type = 0 ifTrue: [^ client storeIntoReceiverVariable: offset2].                type = 1 ifTrue: [^ client storeIntoTemporaryVariable: offset2].                type = 2 ifTrue: [self error: 'illegalStore'].                type = 3 ifTrue: [^ client storeIntoLiteralVariable: (method literalAt: offset2 + 1)]].            offset = 2 ifTrue:                 [type = 0 ifTrue: [^ client popIntoReceiverVariable: offset2].                type = 1 ifTrue: [^ client popIntoTemporaryVariable: offset2].                type = 2 ifTrue: [self error: 'illegalStore'].                type = 3  ifTrue: [^ client popIntoLiteralVariable: (method literalAt: offset2 + 1)]]].        "131-134: extended sends"        offset = 3 ifTrue:  "Single extended send"            [^ client send: (method literalAt: byte2 \\ 32 + 1)                    super: false numArgs: byte2 // 32].        offset = 4 ifTrue:    "Double extended do-anything"            [byte3 _ method at: pc.  pc _ pc + 1.            type _ byte2 // 32.            type = 0 ifTrue: [^ client send: (method literalAt: byte3 + 1)                                    super: false numArgs: byte2 \\ 32].            type = 1 ifTrue: [^ client send: (method literalAt: byte3 + 1)                                    super: true numArgs: byte2 \\ 32].            type = 2 ifTrue: [^ client pushReceiverVariable: byte3].            type = 3 ifTrue: [^ client pushConstant: (method literalAt: byte3 + 1)].            type = 4 ifTrue: [^ client pushLiteralVariable: (method literalAt: byte3 + 1)].            type = 5 ifTrue: [^ client storeIntoReceiverVariable: byte3].            type = 6 ifTrue: [^ client popIntoReceiverVariable: byte3].            type = 7 ifTrue: [^ client storeIntoLiteralVariable: (method literalAt: byte3 + 1)]].        offset = 5 ifTrue:  "Single extended send to super"            [^ client send: (method literalAt: byte2 \\ 32 + 1)                    super: true numArgs: byte2 // 32].        offset = 6 ifTrue:   "Second extended send"            [^ client send: (method literalAt: byte2 \\ 64 + 1)                    super: false numArgs: byte2 // 64]].    offset = 7 ifTrue: [^ client doPop].    offset = 8 ifTrue: [^ client doDup].    offset = 9 ifTrue: [^ client pushActiveContext].    self error: 'unusedBytecode'! !!Integer methodsFor: 'testing'!benchFib  "Handy send-heavy benchmark"    "(result // seconds to run) = approx calls per second"    " | r t | t _ Time millisecondsToRun: [r _ 26 benchFib].            r//t*1000 "    "138000 on a Mac 8100/100"    ^ self < 2        ifTrue: [1]         ifFalse: [(self-1) benchFib + (self-2) benchFib + 1]! !!Integer methodsFor: 'testing'!benchmark  "Handy bytecode-heavy benchmark"    "(500000 // time to run) = approx bytecodes per second"    "5000000 // (Time millisecondsToRun: [10 benchmark]) * 1000"    "3059000 on a Mac 8100/100"    | size flags prime k count |    size _ 8190.    1 to: self do:        [:iter |        count _ 0.        flags _ (Array new: size) atAllPut: true.        1 to: size do:            [:i | (flags at: i) ifTrue:                [prime _ i+1.                k _ i + prime.                [k <= size] whileTrue:                    [flags at: k put: false.                    k _ k + prime].                count _ count + 1]]].    ^ count! !!Integer methodsFor: 'arithmetic'!* aNumber    "Refer to the comment in Number * "     aNumber isInteger        ifTrue: [^ self digitMultiply: aNumber                     neg: self negative ~~ aNumber negative]        ifFalse: [^ (aNumber adaptInteger: self) * aNumber adaptToInteger]! !!Integer methodsFor: 'arithmetic'!+ aNumber    "Refer to the comment in Number + "    aNumber isInteger        ifTrue: [self negative == aNumber negative                    ifTrue: [^(self digitAdd: aNumber) normalize]                    ifFalse: [^self digitSubtract: aNumber]]        ifFalse: [^ (aNumber adaptInteger: self) + aNumber adaptToInteger]! !!Integer methodsFor: 'arithmetic'!- aNumber    "Refer to the comment in Number - "    aNumber isInteger        ifTrue: [self negative == aNumber negative                    ifTrue: [^ self digitSubtract: aNumber]                    ifFalse: [^ (self digitAdd: aNumber) normalize]]        ifFalse: [^ (aNumber adaptInteger: self) - aNumber adaptToInteger]! !!Integer methodsFor: 'arithmetic'!/ aNumber    "Refer to the comment in Number / "    | quoRem |    aNumber isInteger        ifTrue: [quoRem _ self digitDiv: aNumber                                 neg: self negative ~~ aNumber negative.                (quoRem at: 2) = 0                    ifTrue: [^(quoRem at: 1) normalize]                    ifFalse: [^(Fraction numerator: self denominator: aNumber) reduced]]        ifFalse: [^ (aNumber adaptInteger: self) / aNumber adaptToInteger]! !!Integer methodsFor: 'arithmetic'!quo: aNumber     "Refer to the comment in Number quo: "    | ng quo |    aNumber isInteger        ifTrue:             [ng _ self negative == aNumber negative == false.            quo _ (self digitDiv: aNumber neg: ng) at: 1.            ^ quo normalize]        ifFalse: [^ (aNumber adaptInteger: self) quo: aNumber adaptToInteger]! !!Integer methodsFor: 'comparing'!< aNumber    aNumber isInteger        ifTrue: [self negative == aNumber negative                    ifTrue: [self negative                                ifTrue: [^(self digitCompare: aNumber) > 0]                                ifFalse: [^(self digitCompare: aNumber) < 0]]                    ifFalse: [^self negative]]        ifFalse: [^ (aNumber adaptInteger: self) < aNumber adaptToInteger]! !!Integer methodsFor: 'comparing'!= aNumber    aNumber isNumber ifFalse: [^ false].    aNumber isInteger        ifTrue: [aNumber negative == self negative                    ifTrue: [^ (self digitCompare: aNumber) = 0]                    ifFalse: [^ false]]        ifFalse: [^ (aNumber adaptInteger: self) = aNumber adaptToInteger]! !!Integer methodsFor: 'comparing'!> aNumber    aNumber isInteger        ifTrue: [self negative == aNumber negative                    ifTrue: [self negative                                ifTrue: [^(self digitCompare: aNumber) < 0]                                ifFalse: [^(self digitCompare: aNumber) > 0]]                    ifFalse: [^ aNumber negative]]        ifFalse: [^ (aNumber adaptInteger: self) > aNumber adaptToInteger]! !!Integer methodsFor: 'mathematical functions'!degreeCos    "Answer the cosine of the receiver taken as an angle in degrees."    ^ (90 + self) degreeSin! !!Integer methodsFor: 'mathematical functions'!degreeSin    "Answer the sine of the receiver taken as an angle in degrees."    ^ self asFloat degreesToRadians sin! !!Integer methodsFor: 'mathematical functions' stamp: 'di 9/20/97 22:42'!take: kk    "Return the number of combinations of (self) elements taken kk at a time.  For 6 take 3, this is 6*5*4 / (1*2*3).  Zero outside of Pascal's triangle.  Use a trick to go faster."    " 6 take: 3  "    | num denom |    kk < 0 ifTrue: [^ 0].    kk > self ifTrue: [^ 0].    num _ 1.    self to: (kk max: self-kk) + 1 by: -1 do: [:factor | num _ num * factor].    denom _ 1.    1 to: (kk min: self-kk) do: [:factor | denom _ denom * factor].    ^ num // denom! !!Integer methodsFor: 'converting'!adaptFloat: aFloat    "If I am involved in arithmetic with a Float, do not convert the Float."    ^ aFloat! !!Integer methodsFor: 'converting'!adaptFraction: aFraction    "If I am involved in arithmetic with a Fraction, do not convert the Fraction."    ^ aFraction! !!Integer methodsFor: 'converting'!adaptToFloat    "If I am involved in arithmetic with a Float, convert me to a Float."    ^ self asFloat! !!Integer methodsFor: 'converting'!adaptToFraction    "If I am involved in arithmetic with a Fraction, convert me to a Fraction."    ^ self asFraction! !!Integer methodsFor: 'private'!digitDiv: arg neg: ng     "Answer with an array of (quotient, remainder)."    | quo rem ql d div dh dnh dl qhi qlo j l hi lo r3 a t |    l _ self digitLength - arg digitLength + 1.    l <= 0 ifTrue: [^Array with: 0 with: self].    d _ 8 - arg lastDigit highBit.    div _ arg digitLshift: d.  div _ div growto: div digitLength + 1.    "shifts so high order word is >=128"    rem _ self digitLshift: d.    rem digitLength = self digitLength ifTrue:        [rem _ rem growto: self digitLength + 1].    "makes a copy and shifts"    quo _ Integer new: l neg: ng.    dl _ div digitLength - 1.    "Last actual byte of data"    ql _ l.    dh _ div digitAt: dl.    dnh _         dl = 1            ifTrue: [0]            ifFalse: [div digitAt: dl - 1].    1 to: ql do:         [:k |         "maintain quo*arg+rem=self"        "Estimate rem/div by dividing the leading to bytes of rem by dh."        "The estimate is q = qhi*16+qlo, where qhi and qlo are nibbles."        j _ rem digitLength + 1 - k.        "r1 _ rem digitAt: j."        (rem digitAt: j) = dh            ifTrue: [qhi _ qlo _ 15"i.e. q=255"]            ifFalse:                 ["Compute q = (r1,r2)//dh, t = (r1,r2)\\dh.                  Note that r1,r2 are bytes, not nibbles.                  Be careful not to generate intermediate results exceeding 13 bits."                "r2 _ (rem digitAt: j - 1)."                t _ ((rem digitAt: j) bitShift: 4) + ((rem digitAt: j - 1) bitShift: -4).                qhi _ t // dh.                t _ (t \\ dh bitShift: 4) + ((rem digitAt: j - 1) bitAnd: 15).                qlo _ t // dh.                t _ t \\ dh.                "Next compute (hi,lo) _ q*dnh"                hi _ qhi * dnh.                lo _ qlo * dnh + ((hi bitAnd: 15) bitShift: 4).                hi _ (hi bitShift: -4) + (lo bitShift: -8).                lo _ lo bitAnd: 255.                "Correct overestimate of q.                  Max of 2 iterations through loop -- see Knuth vol. 2"                r3 _                     j < 3 ifTrue: [0]                         ifFalse: [rem digitAt: j - 2].                [(t < hi or: [t = hi and: [r3 < lo]]) and:                         ["i.e. (t,r3) < (hi,lo)"                        qlo _ qlo - 1.                        lo _ lo - dnh.                        lo < 0                            ifTrue:                                 [hi _ hi - 1.                                lo _ lo + 256].                        hi >= dh]]                    whileTrue: [hi _ hi - dh].                qlo < 0                    ifTrue:                         [qhi _ qhi - 1.                        qlo _ qlo + 16]].        "Subtract q*div from rem"        l _ j - dl.        a _ 0.        1 to: div digitLength do:             [:i |             hi _ (div digitAt: i) * qhi.            lo _                 a + (rem digitAt: l)                     - ((hi bitAnd: 15) bitShift: 4)                     - ((div digitAt: i) * qlo).            rem digitAt: l put: (lo bitAnd: 255).            a _ (lo bitShift: -8) - (hi bitShift: -4).            l _ l + 1].        a < 0            ifTrue:                 ["Add div back into rem, decrease q by 1"                qlo _ qlo - 1.                l _ j - dl.                a _ 0.                1 to: div digitLength do:                     [:i |                     a _ (a bitShift: -8) + (rem digitAt: l) + (div digitAt: i).                    rem digitAt: l put: (a bitAnd: 255).                    l _ l + 1]].        quo digitAt: quo digitLength + 1 - k put: (qhi bitShift: 4) + qlo].    rem _ rem digitRshift: d bytes: 0 lookfirst: dl.    ^Array with: quo with: rem! !!Integer methodsFor: 'private'!digitLogic: arg op: op length: len    | result neg1 neg2 rneg z1 z2 rz b1 b2 b |    neg1 _ self negative.    neg2 _ arg negative.    rneg _         ((neg1 ifTrue: [-1] ifFalse: [0])            perform: op             with: (neg2                    ifTrue: [-1]                    ifFalse: [0])) < 0.    result _ Integer new: len neg: rneg.    rz _ z1 _ z2 _ true.    1 to: result digitLength do:         [:i |         b1 _ self digitAt: i.        neg1             ifTrue: [b1 _ z1                        ifTrue: [b1 = 0                                    ifTrue: [0]                                    ifFalse:                                         [z1 _ false.                                        256 - b1]]                        ifFalse: [255 - b1]].        b2 _ arg digitAt: i.        neg2             ifTrue: [b2 _ z2                        ifTrue: [b2 = 0                                    ifTrue: [0]                                    ifFalse:                                         [z2 _ false.                                        256 - b2]]                        ifFalse: [255 - b2]].        b _ b1 perform: op with: b2.        b = 0            ifTrue:                 [result digitAt: i put: 0]            ifFalse:                 [result                     digitAt: i                     put: (rneg                            ifTrue: [rz ifTrue:                                             [rz _ false.                                            256 - b]                                        ifFalse: [255 - b]]                        ifFalse: [b])]].    ^ result normalize! !!Integer methodsFor: 'private'!digitMultiply: arg neg: ng    | prod prodLen carry digit k ab |    (arg digitLength = 1 and: [(arg digitAt: 1) = 0]) ifTrue: [^ 0].    prodLen _ self digitLength + arg digitLength.    prod _ Integer new: prodLen neg: ng.    "prod starts out all zero"    1 to: self digitLength do:         [:i |         (digit _ self digitAt: i) ~= 0            ifTrue:                 [k _ i.                carry _ 0.                "Loop invariant: 0<=carry<=0377, k=i+j-1"                1 to: arg digitLength do:                     [:j |                     ab _ ((arg digitAt: j) * digit) + carry                            + (prod digitAt: k).                    carry _ ab bitShift: -8.                    prod digitAt: k put: (ab bitAnd: 255).                    k _ k + 1].                prod digitAt: k put: carry]].    ^ prod normalize! !!Integer methodsFor: 'private'!digitRshift: anInteger bytes: b lookfirst: a      "Shift right 8*b+anInteger bits, 0<=n<8.    Discard all digits beyond a, and all zeroes at or below a."    | n x r f m digit count i |    n _ 0 - anInteger.    x _ 0.    f _ n + 8.    i _ a.    m _ 255 bitShift: 0 - f.    digit _ self digitAt: i.    [((digit bitShift: n) bitOr: x) = 0 and: [i ~= 1]] whileTrue:        [x _ digit bitShift: f "Can't exceed 8 bits".        i _ i - 1.        digit _ self digitAt: i].    i <= b ifTrue: [^Integer new: 0 neg: self negative].  "All bits lost"    r _ Integer new: i - b neg: self negative.    count _ i.    x _ (self digitAt: b + 1) bitShift: n.    b + 1 to: count do:        [:j | digit _ self digitAt: j + 1.        r digitAt: j - b put: (((digit bitAnd: m) bitShift: f) bitOr: x)             "Avoid values > 8 bits".        x _ digit bitShift: n].    ^r! !!InterimSoundMorph methodsFor: 'all' stamp: 'jm 9/18/97 15:25'!addGraphic    graphic _ SketchMorph new form: self speakerGraphic.    graphic position: bounds center - (graphic extent // 2).    self addMorph: graphic.! !!InterimSoundMorph methodsFor: 'all' stamp: 'jm 9/18/97 15:26'!handlesMouseDown: evt    (graphic containsPoint: evt cursorPoint)        ifTrue: [^ true]        ifFalse: [^ super handlesMouseDown: evt].! !!InterimSoundMorph methodsFor: 'all' stamp: 'jm 9/18/97 15:28'!initialize    super initialize.    borderWidth _ 1.    color _ Color r: 0 g: 0.8 b: 0.6.    self extent: 30@30.    self addGraphic.    sound _ BoinkSound pitch: 880.0 dur: 2.0 loudness: 500.! !!InterimSoundMorph methodsFor: 'all' stamp: 'jm 10/4/97 16:35'!mouseDown: evt    (graphic containsPoint: evt cursorPoint)        ifTrue: [sound copy play]        ifFalse: [super mouseDown: evt].! !!InterimSoundMorph methodsFor: 'all' stamp: 'jm 9/18/97 15:02'!sound    ^ sound! !!InterimSoundMorph methodsFor: 'all' stamp: 'jm 9/18/97 15:01'!sound: aSound    sound _ aSound.! !!InterimSoundMorph methodsFor: 'all' stamp: 'jm 9/18/97 15:20'!speakerGraphic    ^ Form        extent: 19@18        depth: 8        fromArray: #(0 0 1493172224 2816 0 0 0 1493172224 11 0 0 138 1493172224 184549376 184549376 0 35509 2315255808 720896 720896 0 9090522 2315255808 2816 720896 0 2327173887 2315255819 2816 720896 138 3051028442 2315255819 2816 2816 1505080590 4294957786 2315255808 184549387 2816 3053453311 4292532917 1493172224 184549387 2816 1505080714 3048584629 1493172224 184549387 2816 9079434 3048584629 1493172224 184549387 2816 138 2327164341 1493172235 2816 2816 0 2324346293 1493172235 2816 720896 0 9079477 1493172224 2816 720896 0 35466 1493172224 720896 720896 0 138 0 184549376 184549376 0 0 0 11 0 0 0 0 2816 0)        offset: 0@0! !Interpreter comment:'This class is a complete implementation of the Smalltalk-80 virtual machine, derived originally from the Blue Book specification.It has been modernized with 32-bit pointers, better management of Contexts, and attention to variable use that allows the CCodeGenerator (qv) to keep, eg, the instruction pointer and stack pointer in registers.In addition to SmallInteger arithmetic and Floats, it supports logic on 32-bit PositiveLargeIntegers, thus allowing it to simulate itself much more effectively than would otherwise be the case.'!!Interpreter methodsFor: 'initialization' stamp: 'jm 9/10/97 19:54'!initializeInterpreter: bytesToShift    "Initialize Interpreter state before starting execution of a new image."    self initializeObjectMemory: bytesToShift.    activeContext    _ nilObj.    theHomeContext    _ nilObj.    method            _ nilObj.    receiver        _ nilObj.    messageSelector    _ nilObj.    newMethod        _ nilObj.    self flushMethodCache.    self loadInitialContext.    interruptCheckCounter _ 0.    nextPollTick _ 0.    nextWakeupTick _ 0.    lastTick _ 0.    interruptKeycode _ 2094.  "cmd-."    interruptPending _ false.    semaphoresToSignalCount _ 0.! !!Interpreter methodsFor: 'initialization'!loadInitialContext    | sched proc |    sched _ self fetchPointer: ValueIndex ofObject: (self splObj: SchedulerAssociation).    proc _ self fetchPointer: ActiveProcessIndex ofObject: sched.    activeContext _ self fetchPointer: SuspendedContextIndex ofObject: proc.    (activeContext < youngStart) ifTrue: [ self beRootIfOld: activeContext ].    self fetchContextRegisters: activeContext.    reclaimableContextCount _ 0.! !!Interpreter methodsFor: 'utilities'!areIntegers: oop1 and: oop2    ^ ((oop1 bitAnd: oop2) bitAnd: 1) ~= 0! !!Interpreter methodsFor: 'utilities'!arrayValueOf: arrayOop    "Return the address of first indexable field of resulting array object, or fail if the instance variable does not contain an indexable bytes or words object."    "Note: May be called by translated primitive code."    self returnTypeC: 'void *'.    ((self isIntegerObject: arrayOop) not and:     [self isWordsOrBytes: arrayOop]) ifTrue: [        ^ self cCode: '(void *) (arrayOop + 4)'    ].    self primitiveFail.! !!Interpreter methodsFor: 'utilities'!assertClassOf: oop is: classOop    "Succeed if the given (non-integer) object is an instance of the given class. Fail if the object is an integer."    | ccIndex cl |    self inline: true.    (self isIntegerObject: oop)        ifTrue: [ successFlag _ false. ^ nil ].    ccIndex _ ((self baseHeader: oop) >> 12) bitAnd: 16r1F.    ccIndex = 0        ifTrue: [ cl _ ((self classHeader: oop) bitAnd: AllButTypeMask) ]        ifFalse: [            "look up compact class"            cl _ (self fetchPointer: (ccIndex - 1)                    ofObject: (self fetchPointer: CompactClasses ofObject: specialObjectsOop))].    self success: cl = classOop.! !!Interpreter methodsFor: 'utilities'!assertFloat: oop1 and: oop2    "Fail unless both arguments are floats."    | floatClass |    ((oop1 bitOr: oop2) bitAnd: 1) ~= 0 ifTrue: [        successFlag _ false.    ] ifFalse: [        floatClass _ self splObj: ClassFloat.        self assertClassOf: oop1 is: floatClass.        self assertClassOf: oop2 is: floatClass.    ].! !!Interpreter methodsFor: 'utilities'!booleanCheat: cond    | bytecode offset |    self inline: true.    bytecode _ self fetchByte.  "assume next bytecode is jumpIfFalse (99%)"    self internalPop: 2.    (bytecode < 160 and: [bytecode > 151]) ifTrue: [  "short jumpIfFalse"        cond            ifTrue: [^ nil]            ifFalse: [^ self jump: bytecode - 151]].    bytecode = 172 ifTrue: [  "long jumpIfFalse"        offset _ self fetchByte.        cond            ifTrue: [^ nil]            ifFalse: [^ self jump: offset]].    "not followed by a jumpIfFalse; undo instruction fetch and push boolean result"    localIP _ localIP - 1.    cond        ifTrue: [self internalPush: trueObj]        ifFalse: [self internalPush: falseObj].! !!Interpreter methodsFor: 'utilities'!booleanValueOf: obj    obj = trueObj ifTrue: [ ^ true ].    obj = falseObj ifTrue: [ ^ false ].    successFlag _ false.    ^ nil! !!Interpreter methodsFor: 'utilities'!checkedIntegerValueOf: intOop    "Note: May be called by translated primitive code."    (self isIntegerObject: intOop)        ifTrue: [ ^ self integerValueOf: intOop ]        ifFalse: [ self primitiveFail. ^ 0 ]! !!Interpreter methodsFor: 'utilities'!externalizeIPandSP    "Copy the local instruction and stack pointer to global variables for use in primitives and other functions outside the interpret loop."    instructionPointer _ self cCoerce: localIP to: 'int'.    stackPointer _ self cCoerce: localSP to: 'int'.! !!Interpreter methodsFor: 'utilities'!fetchArray: fieldIndex ofObject: objectPointer    "Fetch the instance variable at the given index of the given object. Return the address of first indexable field of resulting array object, or fail if the instance variable does not contain an indexable bytes or words object."    "Note: May be called by translated primitive code."    | arrayOop |    self returnTypeC: 'void *'.    arrayOop _ self fetchPointer: fieldIndex ofObject: objectPointer.    ^ self arrayValueOf: arrayOop! !!Interpreter methodsFor: 'utilities'!fetchFloat: fieldIndex ofObject: objectPointer    "Fetch the instance variable at the given index of the given object. Return the C double precision floating point value of that instance variable, or fail if it is not a Float."    "Note: May be called by translated primitive code."    | floatOop |    self returnTypeC: 'double'.    floatOop _ self fetchPointer: fieldIndex ofObject: objectPointer.    ^ self floatValueOf: floatOop! !!Interpreter methodsFor: 'utilities'!fetchInteger: fieldIndex ofObject: objectPointer    "Note: May be called by translated primitive code."    | intOop |    self inline: false.    intOop _ self fetchPointer: fieldIndex ofObject: objectPointer.    (self isIntegerObject: intOop)        ifTrue: [ ^ self integerValueOf: intOop ]        ifFalse: [ self primitiveFail. ^ 0 ]! !!Interpreter methodsFor: 'utilities'!fetchIntegerOrTruncFloat: fieldIndex ofObject: objectPointer    "Return the integer value of the given field of the given object. If the field contains a Float, truncate it and return its integral part. Fail if the given field does not contain a small integer or Float, or if the truncated Float is out of the range of small integers."    "Note: May be called by translated primitive code."    | intOrFloat floatVal frac trunc |    self inline: false.    self var: #floatVal declareC: 'double floatVal'.    self var: #frac declareC: 'double frac'.    self var: #trunc declareC: 'double trunc'.    intOrFloat _ self fetchPointer: fieldIndex ofObject: objectPointer.    (self isIntegerObject: intOrFloat) ifTrue: [^ self integerValueOf: intOrFloat].    self assertClassOf: intOrFloat is: (self splObj: ClassFloat).    successFlag ifTrue: [        self fetchFloatAt: intOrFloat + BaseHeaderSize into: floatVal.        self cCode: 'frac = modf(floatVal, &trunc)'.        "the following range check is for C ints, with range -2^31..2^31-1"        self cCode: 'success((-2147483648.0 <= trunc) && (trunc <= 2147483647.0))'].    successFlag        ifTrue: [^ self cCode: '((int) trunc)']        ifFalse: [^ 0].! !!Interpreter methodsFor: 'utilities'!floatValueOf: oop    "Fetch the instance variable at the given index of the given object. Return the C double precision floating point value of that instance variable, or fail if it is not a Float."    "Note: May be called by translated primitive code."    | result |    self returnTypeC: 'double'.    self var: #result declareC: 'double result'.    self assertClassOf: oop is: (self splObj: ClassFloat).    successFlag        ifTrue: [self fetchFloatAt: oop + BaseHeaderSize into: result]        ifFalse: [result _ 0.0].    ^ result! !!Interpreter methodsFor: 'utilities'!internalizeIPandSP    "Copy the local instruction and stack pointer to local variables for rapid access within the interpret loop."    localIP _ self cCoerce: instructionPointer to: 'char *'.    localSP _ self cCoerce: stackPointer to: 'char *'.! !!Interpreter methodsFor: 'utilities'!makePointwithxValue: xValue yValue: yValue    | pointResult |    pointResult _ self instantiateSmallClass: (self splObj: ClassPoint)                               sizeInBytes: 12                                       fill: nilObj.    self storePointer: XIndex ofObject: pointResult withValue: (self integerObjectOf: xValue).    self storePointer: YIndex ofObject: pointResult withValue: (self integerObjectOf: yValue).    ^ pointResult! !!Interpreter methodsFor: 'utilities'!quickFetchInteger: fieldIndex ofObject: objectPointer    "Return the integer value of the field without verifying that it is an integer value!! For use in time-critical places where the integer-ness of the field can be guaranteed."    ^ self integerValueOf:        (self fetchPointer: fieldIndex ofObject: objectPointer).! !!Interpreter methodsFor: 'utilities'!signExtend16: int16    "Convert a signed 16-bit integer into a signed 32-bit integer value. The integer bit is not added here."    (int16 bitAnd: 16r8000) = 0        ifTrue: [ ^ int16 ]        ifFalse: [ ^ int16 - 16r10000 ].! !!Interpreter methodsFor: 'utilities'!storeInteger: fieldIndex ofObject: objectPointer withValue: integerValue    "Note: May be called by translated primitive code."    (self isIntegerValue: integerValue) ifTrue: [        self storeWord: fieldIndex            ofObject: objectPointer            withValue: (self integerObjectOf: integerValue).    ] ifFalse: [        self primitiveFail    ].! !!Interpreter methodsFor: 'utilities'!transfer: count    fromIndex: firstFrom ofObject: fromOop    toIndex: firstTo ofObject: toOop    "Assume: beRootIfOld: will be called on toOop."    | fromIndex toIndex lastFrom |    self inline: true.    fromIndex _ fromOop + (firstFrom * 4).    toIndex _ toOop + (firstTo * 4).    lastFrom _ fromIndex + (count * 4).    [fromIndex < lastFrom] whileTrue: [        fromIndex _ fromIndex + 4.        toIndex _ toIndex + 4.        self longAt: toIndex put: (self longAt: fromIndex).    ].! !!Interpreter methodsFor: 'object memory support'!mapInterpreterOops    "Map all oops in the interpreter's state to their new values during garbage collection or a become: operation."    "Assume: All traced variables contain valid oops."    | oop |    nilObj                _ self remap: nilObj.    falseObj                _ self remap: falseObj.    trueObj                _ self remap: trueObj.    specialObjectsOop    _ self remap: specialObjectsOop.    stackPointer         _ stackPointer - activeContext.    "*rel to active"    activeContext        _ self remap: activeContext.    stackPointer         _ stackPointer + activeContext.    "*rel to active"    theHomeContext        _ self remap: theHomeContext.    instructionPointer     _ instructionPointer - method.    "*rel to method"    method                _ self remap: method.    instructionPointer     _ instructionPointer + method.    "*rel to method"    receiver                _ self remap: receiver.    messageSelector        _ self remap: messageSelector.    newMethod            _ self remap: newMethod.    1 to: remapBufferCount do: [ :i |        oop _ remapBuffer at: i.        (self isIntegerObject: oop) ifFalse: [            remapBuffer at: i put: (self remap: oop).        ].    ].    "The method cache uses oops as hashes -- toss the whole thing."    self flushMethodCache.! !!Interpreter methodsFor: 'object memory support'!markAndTraceInterpreterOops    "Mark and trace all oops in the interpreter's state."    "Assume: All traced variables contain valid oops."    | oop |    self markAndTrace: specialObjectsOop.        "also covers nilObj, trueObj, falseObj, and compact classes"    self markAndTrace: activeContext.  "traces entire stack"        "also covers theHomeContext, receiver, method"    self markAndTrace: messageSelector.    self markAndTrace: newMethod.    1 to: remapBufferCount do: [ :i |        oop _ remapBuffer at: i.        (self isIntegerObject: oop) ifFalse: [            self markAndTrace: oop.        ].    ].! !!Interpreter methodsFor: 'object memory support'!postGCAction    "Mark the active and home contexts as roots if old. This allows the interpreter to use storePointerUnchecked to store into them."    (activeContext    < youngStart) ifTrue: [ self beRootIfOld: activeContext ].    (theHomeContext < youngStart) ifTrue: [ self beRootIfOld: theHomeContext ].! !!Interpreter methodsFor: 'compiled methods'!argumentCountOf: methodPointer    ^ ((self headerOf: methodPointer) >> 25) bitAnd: 16r1F! !!Interpreter methodsFor: 'compiled methods'!headerOf: methodPointer    ^self fetchPointer: HeaderIndex        ofObject: methodPointer! !!Interpreter methodsFor: 'compiled methods'!literal: offset    ^self literal: offset        ofMethod: method! !!Interpreter methodsFor: 'compiled methods'!literal: offset ofMethod: methodPointer    ^ self fetchPointer: offset + LiteralStart ofObject: methodPointer! !!Interpreter methodsFor: 'compiled methods'!literalCountOf: methodPointer    ^self literalCountOfHeader: (self headerOf: methodPointer)! !!Interpreter methodsFor: 'compiled methods'!literalCountOfHeader: headerPointer    ^ (headerPointer >> 10) bitAnd: 16rFF! !!Interpreter methodsFor: 'compiled methods'!methodClassOf: methodPointer    ^ self fetchPointer: ValueIndex ofObject:        (self literal: (self literalCountOf: methodPointer) - 1            ofMethod: methodPointer)! !!Interpreter methodsFor: 'compiled methods' stamp: 'jm 9/18/97 21:06'!primitiveIndexOf: methodPointer    "Note: We now have 11 bits of primitive index, but they are in two places    for temporary backward compatibility.  The time to unpack is negligible,    since the reconstituted full index is stored in the method cache."    | primBits |    primBits _ ((self headerOf: methodPointer) >> 1) bitAnd: 16r300001FF.    primBits > 16r1FF        ifTrue: [^ (primBits bitAnd: 16r1FF) + (primBits >> 19)]        ifFalse: [^ primBits]! !!Interpreter methodsFor: 'compiled methods'!primitiveNewMethod    | header bytecodeCount class size theMethod literalCount |    header _ self popStack.    bytecodeCount _ self popInteger.    self success: (self isIntegerObject: header).    successFlag ifFalse: [self unPop: 2].    class _ self popStack.    size _ (self literalCountOfHeader: header) + 1 * 4 + bytecodeCount.    theMethod _ self instantiateClass: class indexableSize: size.    self storePointer: HeaderIndex ofObject: theMethod withValue: header.    literalCount _ self literalCountOfHeader: header.    1 to: literalCount do:        [:i | self storePointer: i ofObject: theMethod withValue: nilObj].    self push: theMethod! !!Interpreter methodsFor: 'contexts'!argumentCountOfBlock: blockPointer    | argCount |    argCount _ self fetchPointer: BlockArgumentCountIndex                            ofObject: blockPointer.    (self isIntegerObject: argCount)        ifTrue: [ ^ self integerValueOf: argCount ]        ifFalse: [ self primitiveFail. ^0 ].! !!Interpreter methodsFor: 'contexts'!caller    ^self fetchPointer: CallerIndex        ofObject: activeContext! !!Interpreter methodsFor: 'contexts'!fetchContextRegisters: activeCntx    "Note: internalFetchContextRegisters: should track changes to this method."    | tmp |    self inline: true.    tmp _ self fetchPointer: MethodIndex ofObject: activeCntx.    (self isIntegerObject: tmp) ifTrue: [        "if the MethodIndex field is an integer, activeCntx is a block context"        tmp _ self fetchPointer: HomeIndex ofObject: activeCntx.        (tmp < youngStart) ifTrue: [ self beRootIfOld: tmp ].    ] ifFalse: [        "otherwise, it is a method context and is its own home context"        tmp _ activeCntx.    ].    theHomeContext _ tmp.    receiver _ self fetchPointer: ReceiverIndex ofObject: tmp.    method _ self fetchPointer: MethodIndex ofObject: tmp.    "the instruction pointer is a pointer variable equal to        method oop + ip + BaseHeaderSize          -1 for 0-based addressing of fetchByte          -1 because it gets incremented BEFORE fetching currentByte"    tmp _ self quickFetchInteger: InstructionPointerIndex ofObject: activeCntx.    instructionPointer _ method + tmp + BaseHeaderSize - 2.    "the stack pointer is a pointer variable also..."    tmp _ self quickFetchInteger: StackPointerIndex ofObject: activeCntx.    stackPointer _ activeCntx + BaseHeaderSize + ((TempFrameStart + tmp - 1) * 4).! !!Interpreter methodsFor: 'contexts'!internalFetchContextRegisters: activeCntx    "Inlined into return bytecodes. The only difference between this method and fetchContextRegisters: is that this method sets the local IP and SP."    | tmp |    self inline: true.    tmp _ self fetchPointer: MethodIndex ofObject: activeCntx.    (self isIntegerObject: tmp) ifTrue: [        "if the MethodIndex field is an integer, activeCntx is a block context"        tmp _ self fetchPointer: HomeIndex ofObject: activeCntx.        (tmp < youngStart) ifTrue: [ self beRootIfOld: tmp ].    ] ifFalse: [        "otherwise, it is a method context and is its own home context"        tmp _ activeCntx.    ].    theHomeContext _ tmp.    receiver _ self fetchPointer: ReceiverIndex ofObject: tmp.    method _ self fetchPointer: MethodIndex ofObject: tmp.    "the instruction pointer is a pointer variable equal to        method oop + ip + BaseHeaderSize          -1 for 0-based addressing of fetchByte          -1 because it gets incremented BEFORE fetching currentByte"    tmp _ self quickFetchInteger: InstructionPointerIndex ofObject: activeCntx.    localIP _ self cCoerce: method + tmp + BaseHeaderSize - 2 to: 'char *'.    "the stack pointer is a pointer variable also..."    tmp _ self quickFetchInteger: StackPointerIndex ofObject: activeCntx.    localSP _ self cCoerce: activeCntx + BaseHeaderSize + ((TempFrameStart + tmp - 1) * 4) to: 'char *'.! !!Interpreter methodsFor: 'contexts'!internalPop: nItems    localSP _ localSP - (nItems * 4).! !!Interpreter methodsFor: 'contexts'!internalPop: nItems thenPush: oop    self longAt: (localSP _ localSP - ((nItems - 1) * 4)) put: oop.! !!Interpreter methodsFor: 'contexts'!internalPush: object    self longAt: (localSP _ localSP + 4) put: object.! !!Interpreter methodsFor: 'contexts'!internalStackTop    ^ self longAt: localSP! !!Interpreter methodsFor: 'contexts'!internalStackValue: offset    ^ self longAt: localSP - (offset * 4)! !!Interpreter methodsFor: 'contexts'!newActiveContext: aContext    self storeContextRegisters: activeContext.    (aContext < youngStart) ifTrue: [ self beRootIfOld: aContext ].    activeContext _ aContext.    self fetchContextRegisters: aContext.! !!Interpreter methodsFor: 'contexts'!pop: nItems    "Note: May be called by translated primitive code."    stackPointer _ stackPointer - (nItems*4).! !!Interpreter methodsFor: 'contexts'!pop: nItems thenPush: oop    | sp |    self longAt: (sp _ stackPointer - ((nItems - 1) * 4)) put: oop.    stackPointer _ sp.! !!Interpreter methodsFor: 'contexts'!popInteger    | integerPointer |    integerPointer _ self popStack.    (self isIntegerObject: integerPointer)        ifTrue: [^ self integerValueOf: integerPointer]        ifFalse: [successFlag _ false.                ^ 1  "in case need SOME integer prior to fail"]! !!Interpreter methodsFor: 'contexts'!popPos32BitInteger    "May set successFlag, and return false if not valid"    | top |    top _ self popStack.    ^ self positive32BitValueOf: top! !!Interpreter methodsFor: 'contexts'!popStack    | top |    top _ self longAt: stackPointer.    stackPointer _ stackPointer - 4.    ^ top! !!Interpreter methodsFor: 'contexts'!push: object    | sp |    self longAt: (sp _ stackPointer + 4) put: object.    stackPointer _ sp.! !!Interpreter methodsFor: 'contexts'!pushBool: trueOrFalse    trueOrFalse        ifTrue: [ self push: trueObj ]        ifFalse: [ self push: falseObj ].! !!Interpreter methodsFor: 'contexts'!pushInteger: integerValue    self push: (self integerObjectOf: integerValue).! !!Interpreter methodsFor: 'contexts'!sender    ^ self fetchPointer: SenderIndex ofObject: theHomeContext! !!Interpreter methodsFor: 'contexts'!stackIntegerValue: offset    | integerPointer |    integerPointer _ self longAt: stackPointer - (offset*4).    (self isIntegerObject: integerPointer)        ifTrue: [ ^self integerValueOf: integerPointer ]        ifFalse: [ self primitiveFail. ^0 ]! !!Interpreter methodsFor: 'contexts'!stackPointerIndex    "Return the 0-based index rel to the current context.    (This is what stackPointer used to be before conversion to pointer"    ^ (stackPointer - activeContext - BaseHeaderSize) >> 2! !!Interpreter methodsFor: 'contexts'!stackTop    ^self longAt: stackPointer! !!Interpreter methodsFor: 'contexts'!stackValue: offset    ^ self longAt: stackPointer - (offset*4)! !!Interpreter methodsFor: 'contexts'!storeContextRegisters: activeCntx    "InstructionPointer is a pointer variable equal to    method oop + ip + BaseHeaderSize        -1 for 0-based addressing of fetchByte        -1 because it gets incremented BEFORE fetching currentByte"    self inline: true.    self storeWord: InstructionPointerIndex ofObject: activeCntx        withValue: (self integerObjectOf:             (instructionPointer - method - (BaseHeaderSize - 2))).    self storeWord: StackPointerIndex          ofObject: activeCntx        withValue: (self integerObjectOf:            (self stackPointerIndex - TempFrameStart + 1)).! !!Interpreter methodsFor: 'contexts'!storeInstructionPointerValue: value inContext: contextPointer    "Assume: value is an integerValue"    self storeWord: InstructionPointerIndex        ofObject: contextPointer        withValue: (self integerObjectOf: value).! !!Interpreter methodsFor: 'contexts'!storeStackPointerValue: value inContext: contextPointer    "Assume: value is an integerValue"    self storeWord: StackPointerIndex        ofObject: contextPointer        withValue: (self integerObjectOf: value).! !!Interpreter methodsFor: 'contexts'!temporary: offset    ^ self fetchPointer: offset + TempFrameStart ofObject: theHomeContext! !!Interpreter methodsFor: 'contexts'!unPop: nItems    stackPointer _ stackPointer + (nItems*4)! !!Interpreter methodsFor: 'object format'!fixedFieldsOf: oop format: fmt length: wordLength"    NOTE: This code supports the backward-compatible extension to 8 bits of instSize.    When we revise the image format, it should become...    ^ (classFormat >> 2 bitAnd: 16rFF) - 1"    | class classFormat |    self inline: true.    ((fmt > 3) or: [fmt = 2]) ifTrue: [^ 0].  "indexable fields only"    fmt < 2 ifTrue: [^ wordLength].  "fixed fields only (zero or more)"        "fmt = 3: mixture of fixed and indexable fields, so must look at class format word"    class _ self fetchClassOf: oop.    classFormat _ self formatOfClass: class.    ^ (classFormat >> 11 bitAnd: 16rC0) + (classFormat >> 2 bitAnd: 16r3F) - 1! !!Interpreter methodsFor: 'object format'!formatOfClass: classPointer    "**should be in-lined**"    "Note that, in Smalltalk, the instSpec will be equal to the inst spec    part of the base header of an instance (without hdr type) shifted left 1.    In this way, apart from the smallInt bit, the bits    are just where you want them for the first header word."    "Callers expect low 2 bits (header type) to be zero!!"    ^ (self fetchPointer: InstanceSpecificationIndex ofObject: classPointer) - 1! !!Interpreter methodsFor: 'message sending'!activateNewMethod    | newContext fromIndex toIndex lastIndex methodHeader smallContext initialIP tempCount nilOop |    self inline: false.    self var: #fromIndex declareC: 'char * fromIndex'.    self var: #toIndex declareC: 'char * toIndex'.    self var: #lastIndex declareC: 'char * lastIndex'.    methodHeader _ self headerOf: newMethod.    smallContext _ ((methodHeader >> 18) bitAnd: 1) = 0.    newContext _ self allocateOrRecycleContext: smallContext.    initialIP _        ((LiteralStart + (self literalCountOfHeader: methodHeader)) * 4) + 1.    tempCount _        (methodHeader >> 19) bitAnd: 16r3F.    "Assume: newContext will be recorded as a root if necessary by the     call to newActiveContext: below, so we can use unchecked stores."    self storePointerUnchecked: SenderIndex    ofObject: newContext        withValue: activeContext.    self storeWord: InstructionPointerIndex    ofObject: newContext        withValue: (self integerObjectOf: initialIP).    self storeWord: StackPointerIndex            ofObject: newContext        withValue: (self integerObjectOf: tempCount).    self storePointerUnchecked: MethodIndex ofObject: newContext        withValue: newMethod.    fromIndex _ (self cCoerce: activeContext to: 'char *') + ((self stackPointerIndex - argumentCount) * 4).    toIndex _ (self cCoerce: newContext to: 'char *') + (ReceiverIndex * 4).    lastIndex _ fromIndex + ((argumentCount + 1) * 4).    [fromIndex < lastIndex] whileTrue: [        fromIndex _ fromIndex + 4.        toIndex _ toIndex + 4.        self longAt: toIndex put: (self longAt: fromIndex).    ].    "clear remaining context fields to nil in case it has been recycled"    nilOop _ nilObj.    smallContext        ifTrue: [lastIndex _ (self cCoerce: newContext to: 'char *') + SmallContextSize - BaseHeaderSize]        ifFalse: [lastIndex _ (self cCoerce: newContext to: 'char *') + LargeContextSize - BaseHeaderSize].    [toIndex < lastIndex] whileTrue: [        toIndex _ toIndex + 4.        self longAt: toIndex put: nilOop.    ].    self pop: argumentCount + 1.    reclaimableContextCount _ reclaimableContextCount + 1.    self newActiveContext: newContext.! !!Interpreter methodsFor: 'message sending'!argCount    ^ argumentCount! !!Interpreter methodsFor: 'message sending'!createActualMessage    | argumentArray message |    argumentArray _        self instantiateClass: (self splObj: ClassArray) indexableSize: argumentCount.    "remap argumentArray in case GC happens during allocation"    self pushRemappableOop: argumentArray.    message _ self instantiateClass: (self splObj: ClassMessage) indexableSize: 0.    argumentArray _ self popRemappableOop.    (argumentArray < youngStart) ifTrue: [ self beRootIfOld: argumentArray ].    self storePointer: MessageSelectorIndex        ofObject: message        withValue: messageSelector.    self storePointer: MessageArgumentsIndex        ofObject: message        withValue: argumentArray.    self transfer: argumentCount        fromIndex: self stackPointerIndex - (argumentCount - 1)        ofObject: activeContext        toIndex: 0        ofObject: argumentArray.    self pop: argumentCount.    self push: message.    argumentCount _ 1.! !!Interpreter methodsFor: 'message sending'!executeNewMethod    (primitiveIndex = 0 or: [self primitiveResponse not]) ifTrue: [        "if not primitive, or primitive failed, activate the method"        self activateNewMethod.        "check for possible interrupts at each real send"        self quickCheckForInterrupts.    ].! !!Interpreter methodsFor: 'message sending'!findNewMethodInClass: class    "Find the compiled method to be run when the current messageSelector is sent to the given class, setting the values of 'newMethod' and 'primitiveIndex'."    | ok |    self inline: true.    ok _ self lookupInMethodCacheSel: messageSelector class: class.    ok ifFalse: [        "entry was not found in the cache; look it up the hard way"        self lookupMethodInClass: class.        primitiveIndex _ self primitiveIndexOf: newMethod.        self addToMethodCacheSel: messageSelector            class: class            method: newMethod            primIndex: primitiveIndex.    ].! !!Interpreter methodsFor: 'message sending' stamp: 'di 9/22/97 10:51'!lookupMethodInClass: class    | currentClass dictionary found rclass |    currentClass _ class.    [currentClass ~= nilObj]        whileTrue:        [dictionary _ self fetchPointer: MessageDictionaryIndex ofObject: currentClass.        found _ self lookupMethodInDictionary: dictionary.        found ifTrue: [^ currentClass].        currentClass _ self superclassOf: currentClass].    messageSelector = (self splObj: SelectorDoesNotUnderstand) ifTrue:        [self error: 'Recursive not understood error encountered'].    self pushRemappableOop: class.    self createActualMessage.  "may cause GC!!"    rclass _ self popRemappableOop.    messageSelector _ self splObj: SelectorDoesNotUnderstand.    ^ self lookupMethodInClass: rclass! !!Interpreter methodsFor: 'message sending'!lookupMethodInDictionary: dictionary    "This method lookup tolerates integers as Dictionary keys to support    execution of images in which Symbols have been compacted out"     | length index mask wrapAround nextSelector methodArray |    self inline: true.    length _ self fetchWordLengthOf: dictionary.    mask _ length - SelectorStart - 1.    (self isIntegerObject: messageSelector)        ifTrue:        [index _ (mask bitAnd: (self integerValueOf: messageSelector)) + SelectorStart]        ifFalse:        [index _ (mask bitAnd: (self hashBitsOf: messageSelector)) + SelectorStart].    "It is assumed that there are some nils in this dictionary, and search will    stop when one is encountered.  However, if there are no nils, then wrapAround    will be detected the second time the loop gets to the end of the table."    wrapAround _ false.    [true] whileTrue:        [nextSelector _ self fetchPointer: index                    ofObject: dictionary.        nextSelector=nilObj ifTrue: [^false].        nextSelector=messageSelector            ifTrue: [methodArray _ self fetchPointer: MethodArrayIndex                            ofObject: dictionary.                newMethod _ self fetchPointer:  index - SelectorStart                            ofObject: methodArray.                primitiveIndex _ self primitiveIndexOf: newMethod.                ^true].        index _ index + 1.        index = length            ifTrue: [wrapAround ifTrue: [^false].                wrapAround _ true.                index _ SelectorStart]]! !!Interpreter methodsFor: 'message sending'!normalSend    "Send a message, starting lookup with the receiver's class."    "Assume: messageSelector and argumentCount have been set, and that the receiver and arguments have been pushed onto the stack,"    "Note: This method is inlined into the interpreter dispatch loop."    | rcvrClass |    self inline: true.    self sharedCodeNamed: 'commonSend' inCase: 131.    rcvrClass _ self fetchClassOf: (self internalStackValue: argumentCount).    self externalizeIPandSP.    self sendSelectorToClass: rcvrClass.    self internalizeIPandSP.! !!Interpreter methodsFor: 'message sending'!sendSelectorToClass: classPointer    "Note: Requires that instructionPointer and stackPointer be externalized."    self inline: true.    self findNewMethodInClass: classPointer.    self executeNewMethod.! !!Interpreter methodsFor: 'message sending'!specialSelector: index    ^ self fetchPointer: (index * 2) ofObject: (self splObj: SpecialSelectors)! !!Interpreter methodsFor: 'message sending'!superclassOf: classPointer    ^ self fetchPointer: SuperclassIndex ofObject: classPointer! !!Interpreter methodsFor: 'message sending'!superclassSend    "Send a message to self, starting lookup with the superclass of the class containing the currently executing method."    "Assume: messageSelector and argumentCount have been set, and that the receiver and arguments have been pushed onto the stack,"    "Note: This method is inlined into the interpreter dispatch loop."    | superClass |    self inline: true.    self sharedCodeNamed: 'commonSupersend' inCase: 133.    superClass _ self superclassOf: (self methodClassOf: method).    self externalizeIPandSP.    self sendSelectorToClass: superClass.    self internalizeIPandSP.! !!Interpreter methodsFor: 'method lookup cache'!addToMethodCacheSel: selector class: class method: meth primIndex: primIndex    "Add the given entry to the method cache."    | probe |    self inline: false.    "select one of the CacheProbeMax possible entries for replacement..."    mcProbe _ (mcProbe + 1) \\ CacheProbeMax.  "in range 0..CacheProbeMax-1"    probe _ (((selector bitXor: class) >> (mcProbe + 2)) bitAnd: MethodCacheMask) + 1.    "...and replace the entry at that probe addresses"    methodCache at: probe put: selector.    methodCache at: probe + MethodCacheEntries put: class.    methodCache at: probe + (MethodCacheEntries * 2) put: meth.    methodCache at: probe + (MethodCacheEntries * 3) put: primIndex.! !!Interpreter methodsFor: 'method lookup cache'!flushMethodCache    "Flush the method cache. The method cache is flushed on every programming change and garbage collect."    1 to: MethodCacheSize do: [ :i | methodCache at: i put: 0 ].    mcProbe _ 0.! !!Interpreter methodsFor: 'method lookup cache'!lookupInMethodCacheSel: selector class: class    "This method implements a simple method lookup cache. If an entry for the given selector and class is found in the cache, set the values of 'newMethod' and 'primitiveIndex' and return true. Otherwise, return false."    "About the re-probe scheme: The hash is the low bits of the XOR of two large addresses, minus their useless lowest two bits. If a probe doesn't get a hit, the hash is shifted right one bit to compute the next probe, introducing a new randomish bit. The cache is probed CacheProbeMax times before giving up."    "WARNING: Since the hash computation is based on the object addresses of the class and selector, we must rehash or flush when compacting storage. We've chosen to flush, since that also saves the trouble of updating the addresses of the objects in the cache."    | hash probe |    self inline: true.    hash _ (selector bitXor: class) >> 2.  "shift drops two low-order zeros from addresses"    probe _ (hash bitAnd: MethodCacheMask) + 1.  "initial probe"    1 to: CacheProbeMax do: [ :p |        (((methodCache at: probe) = selector) and:         [(methodCache at: probe + MethodCacheEntries) = class]) ifTrue: [            newMethod _ methodCache at: probe + (MethodCacheEntries * 2).            primitiveIndex _ methodCache at: probe + (MethodCacheEntries * 3).            ^ true    "found entry in cache; done"        ].        probe _ ((hash >> p) bitAnd: MethodCacheMask) + 1    ].    ^ false! !!Interpreter methodsFor: 'interpreter shell'!fetchByte    "This method uses the preIncrement builtin function which has no Smalltalk equivalent. Thus, it must be overridden in the simulator."    ^ self byteAt: localIP preIncrement! !!Interpreter methodsFor: 'interpreter shell'!getCurrentBytecode    "currentBytecode will be private to the main dispatch loop in the generated code. This method allows the currentBytecode to be retrieved from global variables."    ^ self byteAt: instructionPointer! !!Interpreter methodsFor: 'interpreter shell'!interpret    self internalizeIPandSP.    [true] whileTrue: [        currentBytecode _ self fetchByte.        self dispatchOn: currentBytecode in: BytecodeTable.    ].    self externalizeIPandSP.! !!Interpreter methodsFor: 'interpreter shell'!unknownBytecode    "This should never get called; it means that an unimplemented bytecode appears in a CompiledMethod."    self error: 'Unknown bytecode'.! !!Interpreter methodsFor: 'stack bytecodes'!duplicateTopBytecode    self internalPush: self internalStackTop.! !!Interpreter methodsFor: 'stack bytecodes'!experimentalBytecode    "Note: This bytecode is not currently generated by the compiler."    "This range of six bytecodes can replace the pushTemporaryVariable[0..5] bytecode at the beginning of a sequence of either the form:        pushTemp        pushTemp | pushConstantOne | pushLiteralConstant        <=        longJumpIfFalseor the form:        pushTemp        pushTemp | pushConstantOne | pushLiteralConstant        +        popIntoTemp (optional)If two values pushed are not small integers, this bytecode acts like the pushTemp bytecode it replaces. However, if they are small integers, then the given arithmetic or comparison operation is performed. The result of that operation is either pushed onto the stack or, if one of the expected bytecodes follows it, then that bytecode is performed immediately. In such cases, the entire four instruction sequence is performed without doing any stack operations."    | arg1 byte2 byte3 byte4 arg1Val arg2Val result offset |    arg1 _ self temporary: currentBytecode - 138.    byte2 _ self byteAt: localIP + 1.  "fetch ahead"    byte3 _ self byteAt: localIP + 2.  "fetch ahead"    byte4 _ self byteAt: localIP + 3.  "fetch ahead"    "check first arg"    (self isIntegerObject: arg1) ifTrue: [        arg1Val _ self integerValueOf: arg1.    ] ifFalse: [        ^ self internalPush: arg1.  "abort; first arg is not an integer"    ].    "get and check second arg"    byte2 < 32 ifTrue: [        arg2Val _ self temporary: (byte2 bitAnd: 16rF).        (self isIntegerObject: arg2Val) ifTrue: [            arg2Val _ self integerValueOf: arg2Val.        ] ifFalse: [            ^ self internalPush: arg1.  "abort; second arg is not an integer"        ].    ] ifFalse: [        byte2 > 64 ifTrue: [            arg2Val _ 1.        ] ifFalse: [            arg2Val _ self literal: (byte2 bitAnd: 16r1F).            (self isIntegerObject: arg2Val) ifTrue: [                arg2Val _ self integerValueOf: arg2Val.            ] ifFalse: [                ^ self internalPush: arg1.  "abort; second arg is not an integer"            ].        ].    ].    byte3 < 178 ifTrue: [        "do addition, possibly followed by a storeAndPopTemp"        result _ arg1Val + arg2Val.        (self isIntegerValue: result) ifTrue: [            ((byte4 > 103) and: [byte4 < 112]) ifTrue: [                "next instruction is a storeAndPopTemp"                localIP _ localIP + 3.                self storePointerUnchecked: (byte4 bitAnd: 7) + TempFrameStart                    ofObject: theHomeContext                    withValue: (self integerObjectOf: result).            ] ifFalse: [                localIP _ localIP + 2.                self internalPush: (self integerObjectOf: result).            ].        ] ifFalse: [            ^ self internalPush: arg1.  "abort; result is not an integer"        ].    ] ifFalse: [        "do comparison operation, followed by a longJumpIfFalse"        offset _ self byteAt: localIP + 4.        arg1Val <= arg2Val            ifTrue: [localIP _ localIP + 3 + 1]  "jump not taken; skip extra instruction byte"            ifFalse: [localIP _ localIP + 3 + 1 + offset].    ].! !!Interpreter methodsFor: 'stack bytecodes'!extendedPushBytecode    | descriptor variableType variableIndex |    descriptor _ self fetchByte.    variableType _ (descriptor >> 6) bitAnd: 16r3.    variableIndex _ descriptor bitAnd: 16r3F.    variableType=0 ifTrue: [^self pushReceiverVariable: variableIndex].    variableType=1 ifTrue: [^self pushTemporaryVariable: variableIndex].    variableType=2 ifTrue: [^self pushLiteralConstant: variableIndex].    variableType=3 ifTrue: [^self pushLiteralVariable: variableIndex].! !!Interpreter methodsFor: 'stack bytecodes'!extendedStoreAndPopBytecode    self extendedStoreBytecode.    self popStackBytecode.! !!Interpreter methodsFor: 'stack bytecodes'!extendedStoreBytecode    | descriptor variableType variableIndex association |    self inline: true.    descriptor _ self fetchByte.    variableType _ (descriptor >> 6) bitAnd: 16r3.    variableIndex _ descriptor bitAnd: 16r3F.    variableType = 0 ifTrue:        [^self storePointer: variableIndex            ofObject: receiver            withValue: self internalStackTop].    variableType = 1 ifTrue:        [^self storePointerUnchecked: variableIndex + TempFrameStart            ofObject: theHomeContext            withValue: self internalStackTop].    variableType = 2 ifTrue:        [self error: 'illegal store'].    variableType = 3 ifTrue:        [association _ self literal: variableIndex.        ^self storePointer: ValueIndex            ofObject: association            withValue: self internalStackTop].! !!Interpreter methodsFor: 'stack bytecodes'!popStackBytecode    self internalPop: 1.! !!Interpreter methodsFor: 'stack bytecodes'!pushActiveContextBytecode    "Puts reclaimability of this context in question."    reclaimableContextCount _ 0.    self internalPush: activeContext.! !!Interpreter methodsFor: 'stack bytecodes'!pushConstantFalseBytecode    self internalPush: falseObj.! !!Interpreter methodsFor: 'stack bytecodes'!pushConstantMinusOneBytecode    self internalPush: ConstMinusOne.! !!Interpreter methodsFor: 'stack bytecodes'!pushConstantNilBytecode    self internalPush: nilObj.! !!Interpreter methodsFor: 'stack bytecodes'!pushConstantOneBytecode    self internalPush: ConstOne.! !!Interpreter methodsFor: 'stack bytecodes'!pushConstantTrueBytecode    self internalPush: trueObj.! !!Interpreter methodsFor: 'stack bytecodes'!pushConstantTwoBytecode    self internalPush: ConstTwo.! !!Interpreter methodsFor: 'stack bytecodes'!pushConstantZeroBytecode    self internalPush: ConstZero.! !!Interpreter methodsFor: 'stack bytecodes'!pushLiteralConstant: literalIndex    self internalPush: (self literal: literalIndex).! !!Interpreter methodsFor: 'stack bytecodes'!pushLiteralConstantBytecode    self pushLiteralConstant: (currentBytecode bitAnd: 16r1F).! !!Interpreter methodsFor: 'stack bytecodes'!pushLiteralVariable: literalIndex    self internalPush:        (self fetchPointer: ValueIndex ofObject: (self literal: literalIndex)).! !!Interpreter methodsFor: 'stack bytecodes'!pushLiteralVariableBytecode    self pushLiteralVariable: (currentBytecode bitAnd: 16r1F).! !!Interpreter methodsFor: 'stack bytecodes'!pushReceiverBytecode    self internalPush: receiver.! !!Interpreter methodsFor: 'stack bytecodes'!pushReceiverVariable: fieldIndex    self internalPush:        (self fetchPointer: fieldIndex ofObject: receiver).! !!Interpreter methodsFor: 'stack bytecodes'!pushReceiverVariableBytecode    self pushReceiverVariable: (currentBytecode bitAnd: 16rF).! !!Interpreter methodsFor: 'stack bytecodes'!pushTemporaryVariable: temporaryIndex    self internalPush: (self temporary: temporaryIndex).! !!Interpreter methodsFor: 'stack bytecodes'!pushTemporaryVariableBytecode    self pushTemporaryVariable: (currentBytecode bitAnd: 16rF).! !!Interpreter methodsFor: 'stack bytecodes'!storeAndPopReceiverVariableBytecode    "Note: This code uses storePointerUnchecked:ofObject:withValue: and does the store check explicitely in order to help the translator produce better code."    | rcvr top |    rcvr _ receiver.    top _ self internalStackTop.    (rcvr < youngStart) ifTrue: [        self possibleRootStoreInto: rcvr value: top.    ].    self storePointerUnchecked: (currentBytecode bitAnd: 7)        ofObject: rcvr        withValue: top.    self internalPop: 1.! !!Interpreter methodsFor: 'stack bytecodes'!storeAndPopTemporaryVariableBytecode    self storePointerUnchecked: (currentBytecode bitAnd: 7) + TempFrameStart        ofObject: theHomeContext        withValue: self internalStackTop.    self internalPop: 1.! !!Interpreter methodsFor: 'jump bytecodes'!jump: offset    localIP _ localIP + offset.! !!Interpreter methodsFor: 'jump bytecodes'!jumplfFalseBy: offset    | boolean |    boolean _ self internalStackTop.    boolean = falseObj ifTrue: [        self jump: offset.    ] ifFalse: [        boolean = trueObj ifFalse: [            messageSelector _ self splObj: SelectorMustBeBoolean.            argumentCount _ 0.            ^ self normalSend        ].    ].    self internalPop: 1.! !!Interpreter methodsFor: 'jump bytecodes'!jumplfTrueBy: offset    | boolean |    boolean _ self internalStackTop.    boolean = trueObj ifTrue: [        self jump: offset.    ] ifFalse: [        boolean = falseObj ifFalse: [            messageSelector _ self splObj: SelectorMustBeBoolean.            argumentCount _ 0.            ^ self normalSend        ].    ].    self internalPop: 1.! !!Interpreter methodsFor: 'jump bytecodes'!longJumpIfFalse    self jumplfFalseBy:        ((currentBytecode bitAnd: 3) * 256) + self fetchByte.! !!Interpreter methodsFor: 'jump bytecodes'!longJumpIfTrue    self jumplfTrueBy:        ((currentBytecode bitAnd: 3) * 256) + self fetchByte.! !!Interpreter methodsFor: 'jump bytecodes'!longUnconditionalJump    | offset |    offset _ (((currentBytecode bitAnd: 7) - 4) * 256) + self fetchByte.    localIP _ localIP + offset.    offset < 0 ifTrue: [        "backward jump means we're in a loop; check for possible interrupts"        self internalQuickCheckForInterrupts.    ].! !!Interpreter methodsFor: 'jump bytecodes'!shortConditionalJump    self jumplfFalseBy: (currentBytecode bitAnd: 7) + 1.! !!Interpreter methodsFor: 'jump bytecodes'!shortUnconditionalJump    self jump: (currentBytecode bitAnd: 7) + 1.! !!Interpreter methodsFor: 'send bytecodes'!doubleExtendedDoAnythingBytecode    "Replaces the Blue Book double-extended send [132], in which    the first byte was wasted on 8 bits of argument count.    Here we use 3 bits for the operation sub-type (opType),    and the remaining 5 bits for argument count where needed.    The last byte give access to 256 instVars or literals.    See also secondExtendedSendBytecode"    | byte2 byte3 opType top |    byte2 _ self fetchByte.    byte3 _ self fetchByte.    opType _ byte2 >> 5.    opType = 0 ifTrue: [        messageSelector _ self literal: byte3.        argumentCount _ byte2 bitAnd: 16r1F.        ^ self normalSend    ].    opType = 1 ifTrue: [        messageSelector _ self literal: byte3.        argumentCount _ byte2 bitAnd: 16r1F.        ^ self superclassSend    ].    opType = 2 ifTrue: [^ self pushReceiverVariable: byte3].    opType = 3 ifTrue: [^ self pushLiteralConstant: byte3].    opType = 4 ifTrue: [^ self pushLiteralVariable: byte3].    opType = 5 ifTrue: [        top _ self internalStackTop.        ^ self storePointer: byte3 ofObject: receiver withValue: top    ].    opType = 6 ifTrue: [        top _ self internalStackTop.        self internalPop: 1.        ^ self storePointer: byte3 ofObject: receiver withValue: top    ].    opType = 7 ifTrue: [        top _ self internalStackTop.        ^ self storePointer: ValueIndex ofObject: (self literal: byte3) withValue: top    ].! !!Interpreter methodsFor: 'send bytecodes'!secondExtendedSendBytecode    "This replaces the Blue Book double-extended super-send [134],    which is subsumed by the new double-extended do-anything [132].    It offers a 2-byte send of 0-3 args for up to 63 literals, for which     the Blue Book opcode set requires a 3-byte instruction."    | descriptor |    descriptor _ self fetchByte.    messageSelector _ self literal: (descriptor bitAnd: 16r3F).    argumentCount _ descriptor >> 6.    self normalSend.! !!Interpreter methodsFor: 'send bytecodes'!sendLiteralSelectorBytecode    "Can use any of the first 16 literals for the selector and pass up to 2 arguments."    messageSelector _ self literal: (currentBytecode bitAnd: 16rF).    argumentCount _ ((currentBytecode >> 4) bitAnd: 3) - 1.    self normalSend.! !!Interpreter methodsFor: 'send bytecodes'!singleExtendedSendBytecode    "Can use any of the first 32 literals for the selector and pass up to 7 arguments."    | descriptor |    descriptor _ self fetchByte.    messageSelector _ self literal: (descriptor bitAnd: 16r1F).    argumentCount _ descriptor >> 5.    self normalSend.! !!Interpreter methodsFor: 'send bytecodes'!singleExtendedSuperBytecode    "Can use any of the first 32 literals for the selector and pass up to 7 arguments."    | descriptor |    descriptor _ self fetchByte.    messageSelector _ self literal: (descriptor bitAnd: 16r1F).    argumentCount _ descriptor >> 5.    self superclassSend.! !!Interpreter methodsFor: 'return bytecodes'!returnFalse    | cntx val |    cntx _ self sender.    val _ falseObj.    self returnValue: val to: cntx.! !!Interpreter methodsFor: 'return bytecodes'!returnNil    | cntx val |    cntx _ self sender.    val _ nilObj.    self returnValue: val to: cntx.! !!Interpreter methodsFor: 'return bytecodes'!returnReceiver    | cntx val |    cntx _ self sender.    val _ receiver.    self returnValue: val to: cntx.! !!Interpreter methodsFor: 'return bytecodes'!returnTopFromBlock    "Return to the caller of the method containing the block."    | cntx val |    cntx _ self caller.  "Note: caller, not sender!!"    val _ self internalStackTop.    self returnValue: val to: cntx.! !!Interpreter methodsFor: 'return bytecodes'!returnTopFromMethod    | cntx val |    cntx _ self sender.    val _ self internalStackTop.    self returnValue: val to: cntx.! !!Interpreter methodsFor: 'return bytecodes'!returnTrue    | cntx val |    cntx _ self sender.    val _ trueObj.    self returnValue: val to: cntx.! !!Interpreter methodsFor: 'return bytecodes'!returnValue: resultObj to: returnContext    "Note: Assumed to be inlined into the dispatch loop."    | nilOop thisCntx methodContextClass contextOfCaller |    self inline: true.    self sharedCodeNamed: 'commonReturn' inCase: 120.    nilOop _ nilObj. "keep in a register"    thisCntx _ activeContext.    methodContextClass _ self splObj: ClassMethodContext.    "make sure we can return to the given context"    ((returnContext = nilOop) or:     [(self fetchPointer: InstructionPointerIndex ofObject: returnContext) = nilOop]) ifTrue: [        "error: sender's instruction pointer or context is nil; cannot return"        self internalPush: activeContext.        self internalPush: resultObj.        messageSelector _ self splObj: SelectorCannotReturn.        argumentCount _ 1.        ^ self normalSend    ].    [thisCntx = returnContext] whileFalse: [        "climb up stack to returnContext"        contextOfCaller _ self fetchPointer: SenderIndex ofObject: thisCntx.        "zap exited contexts so any future attempted use will be caught"        self storePointerUnchecked: SenderIndex ofObject: thisCntx withValue: nilOop.        self storePointerUnchecked: InstructionPointerIndex ofObject: thisCntx withValue: nilOop.        reclaimableContextCount > 0 ifTrue: [            "try to recycle this context"            reclaimableContextCount _ reclaimableContextCount - 1.            self recycleContextIfPossible: thisCntx methodContextClass: methodContextClass.        ].        thisCntx _ contextOfCaller.    ].    activeContext _ thisCntx.    (thisCntx < youngStart) ifTrue: [ self beRootIfOld: thisCntx ].    self internalFetchContextRegisters: thisCntx.  "updates local IP and SP"    self internalPush: resultObj.    self internalQuickCheckForInterrupts.! !!Interpreter methodsFor: 'common selector sends'!bytecodePrimAdd    | rcvr arg result |    rcvr _ self internalStackValue: 1.    arg _ self internalStackValue: 0.    (self areIntegers: rcvr and: arg) ifTrue: [        result _ (self integerValueOf: rcvr) + (self integerValueOf: arg).        (self isIntegerValue: result) ifTrue: [            self longAt: (localSP _ localSP - 4)                    put: (self integerObjectOf: result).            ^ nil        ].    ].    self externalizeIPandSP.    successFlag _ true.    self primitiveFloatAdd.    successFlag ifFalse: [        successFlag _ true.        self primitiveAdd.    ].    self internalizeIPandSP.! !!Interpreter methodsFor: 'common selector sends'!bytecodePrimAt    | index rcvr result rcvrClass stringy |    index _ self internalStackTop.    rcvr _ self internalStackValue: 1.    successFlag _ self isIntegerObject: index.    successFlag ifTrue: [        rcvrClass _ self fetchClassOf: rcvr.        stringy _ rcvrClass = (self splObj: ClassString).        (stringy or: [self okArrayClass: rcvrClass])            ifFalse: [successFlag _ false]].    successFlag ifTrue: [        index _ self integerValueOf: index.self externalizeIPandSP.        result _ self stObject: rcvr at: index.self internalizeIPandSP.        (stringy and: [successFlag]) ifTrue: [result _ self characterForAscii: result]].    successFlag ifTrue: [        self internalPop: 2 thenPush: result.    ] ifFalse: [        messageSelector _ self specialSelector: 16.        argumentCount _ 1.        self normalSend.    ].! !!Interpreter methodsFor: 'common selector sends' stamp: 'di 6/21/97 08:58'!bytecodePrimAtEnd    messageSelector _ self specialSelector: 21.    argumentCount _ 0.    self normalSend.! !!Interpreter methodsFor: 'common selector sends'!bytecodePrimAtPut    | value valToStore index rcvr rcvrClass stringy |    value _ valToStore _ self internalStackTop.    index _ self internalStackValue: 1.    rcvr _ self internalStackValue: 2.    successFlag _ self isIntegerObject: index.    successFlag ifTrue: [        rcvrClass _ self fetchClassOf: rcvr.        stringy _ rcvrClass = (self splObj: ClassString).        (stringy or: [self okArrayClass: rcvrClass])            ifFalse: [successFlag _ false]].    successFlag ifTrue: [        index _ self integerValueOf: index.        stringy ifTrue: [valToStore _ self asciiOfCharacter: value].        self stObject: rcvr at: index put: valToStore.    ].    successFlag ifTrue: [        self internalPop: 3 thenPush: value.    ] ifFalse: [        messageSelector _ self specialSelector: 17.        argumentCount _ 2.        self normalSend.    ].! !!Interpreter methodsFor: 'common selector sends'!bytecodePrimBitAnd    self externalizeIPandSP.    self primitiveBitAnd.    self internalizeIPandSP.! !!Interpreter methodsFor: 'common selector sends'!bytecodePrimBitOr    self externalizeIPandSP.    self primitiveBitOr.    self internalizeIPandSP.! !!Interpreter methodsFor: 'common selector sends'!bytecodePrimBitShift    self externalizeIPandSP.    self primitiveBitShift.    self internalizeIPandSP.! !!Interpreter methodsFor: 'common selector sends'!bytecodePrimBlockCopy    | rcvrClass |    rcvrClass _ self fetchClassOf: (self internalStackValue: 1).    successFlag _ true.    self success:        ((rcvrClass = (self splObj: ClassBlockContext)) or:         [rcvrClass = (self splObj: ClassMethodContext)]).    successFlag ifTrue: [        self externalizeIPandSP.        self primitiveBlockCopy.        self internalizeIPandSP.    ].    successFlag ifFalse: [        messageSelector _ self specialSelector: 24.        argumentCount _ 1.        ^ self normalSend    ].! !!Interpreter methodsFor: 'common selector sends'!bytecodePrimClass    self externalizeIPandSP.    self primitiveClass.    self internalizeIPandSP.! !!Interpreter methodsFor: 'common selector sends'!bytecodePrimDiv    self externalizeIPandSP.    self primitiveDiv.    self internalizeIPandSP.! !!Interpreter methodsFor: 'common selector sends'!bytecodePrimDivide    | rcvr arg result |    rcvr _ self internalStackValue: 1.    arg _ self internalStackValue: 0.    (self areIntegers: rcvr and: arg) ifTrue: [        rcvr _ self integerValueOf: rcvr.        arg _ self integerValueOf: arg.        ((arg ~= 0) and: [(rcvr \\ arg) = 0]) ifTrue: [            result _ rcvr // arg.  "generates C / operation"            (self isIntegerValue: result) ifTrue: [                self longAt: (localSP _ localSP - 4)                        put: (self integerObjectOf: result).                ^ nil            ].        ].    ].    self externalizeIPandSP.    successFlag _ true.    self primitiveFloatDivide.    successFlag ifFalse: [        successFlag _ true.        self primitiveDivide.    ].    self internalizeIPandSP.! !!Interpreter methodsFor: 'common selector sends'!bytecodePrimDo    messageSelector _ self specialSelector: 27.    argumentCount _ 1.    self normalSend.! !!Interpreter methodsFor: 'common selector sends'!bytecodePrimEqual    | rcvr arg |    rcvr _ self internalStackValue: 1.    arg _ self internalStackValue: 0.    (self areIntegers: rcvr and: arg) ifTrue: [        ^ self booleanCheat: rcvr = arg    ].    self externalizeIPandSP.    successFlag _ true.    self primitiveFloatEqual.    successFlag ifFalse: [        successFlag _ true.        self primitiveEqual.    ].    self internalizeIPandSP.! !!Interpreter methodsFor: 'common selector sends'!bytecodePrimEquivalent    | rcvr arg |    rcvr _ self internalStackValue: 1.    arg _ self internalStackValue: 0.    self booleanCheat: rcvr = arg.! !!Interpreter methodsFor: 'common selector sends'!bytecodePrimGreaterOrEqual    | rcvr arg |    rcvr _ self internalStackValue: 1.    arg _ self internalStackValue: 0.    (self areIntegers: rcvr and: arg) ifTrue: [        ^ self booleanCheat: rcvr >= arg    ].    self externalizeIPandSP.    successFlag _ true.    self primitiveFloatGreaterOrEqual.    successFlag ifFalse: [        successFlag _ true.        self primitiveGreaterOrEqual.    ].    self internalizeIPandSP.! !!Interpreter methodsFor: 'common selector sends'!bytecodePrimGreaterThan    | rcvr arg |    rcvr _ self internalStackValue: 1.    arg _ self internalStackValue: 0.    (self areIntegers: rcvr and: arg) ifTrue: [        ^ self booleanCheat: rcvr > arg    ].    self externalizeIPandSP.    successFlag _ true.    self primitiveFloatGreaterThan.    successFlag ifFalse: [        successFlag _ true.        self primitiveGreaterThan.    ].    self internalizeIPandSP.! !!Interpreter methodsFor: 'common selector sends'!bytecodePrimLessOrEqual    | rcvr arg |    rcvr _ self internalStackValue: 1.    arg _ self internalStackValue: 0.    (self areIntegers: rcvr and: arg) ifTrue: [        ^ self booleanCheat: rcvr <= arg    ].    self externalizeIPandSP.    successFlag _ true.    self primitiveFloatLessOrEqual.    successFlag ifFalse: [        successFlag _ true.        self primitiveLessOrEqual.    ].    self internalizeIPandSP.! !!Interpreter methodsFor: 'common selector sends'!bytecodePrimLessThan    | rcvr arg |    rcvr _ self internalStackValue: 1.    arg _ self internalStackValue: 0.    (self areIntegers: rcvr and: arg) ifTrue: [        ^ self booleanCheat: rcvr < arg    ].    self externalizeIPandSP.    successFlag _ true.    self primitiveFloatLessThan.    successFlag ifFalse: [        successFlag _ true.        self primitiveLessThan.    ].    self internalizeIPandSP.! !!Interpreter methodsFor: 'common selector sends'!bytecodePrimMakePoint    self externalizeIPandSP.    self primitiveMakePoint.    self internalizeIPandSP.! !!Interpreter methodsFor: 'common selector sends'!bytecodePrimMod    self externalizeIPandSP.    self primitiveMod.    self internalizeIPandSP.! !!Interpreter methodsFor: 'common selector sends'!bytecodePrimMultiply    | rcvr arg result |    rcvr _ self internalStackValue: 1.    arg _ self internalStackValue: 0.    (self areIntegers: rcvr and: arg) ifTrue: [        rcvr _ self integerValueOf: rcvr.        arg _ self integerValueOf: arg.        result _ rcvr * arg.        ((arg = 0 or: [(result // arg) = rcvr]) and:         [self isIntegerValue: result]) ifTrue: [            self longAt: (localSP _ localSP - 4)                    put: (self integerObjectOf: result).            ^ nil        ].    ].    self externalizeIPandSP.    successFlag _ true.    self primitiveFloatMultiply.    successFlag ifFalse: [        successFlag _ true.        self primitiveMultiply.    ].    self internalizeIPandSP.! !!Interpreter methodsFor: 'common selector sends'!bytecodePrimNew    messageSelector _ self specialSelector: 28.    argumentCount _ 0.    self normalSend.! !!Interpreter methodsFor: 'common selector sends'!bytecodePrimNewWithArg    messageSelector _ self specialSelector: 29.    argumentCount _ 1.    self normalSend.! !!Interpreter methodsFor: 'common selector sends' stamp: 'di 6/21/97 08:58'!bytecodePrimNext    messageSelector _ self specialSelector: 19.    argumentCount _ 0.    self normalSend.! !!Interpreter methodsFor: 'common selector sends' stamp: 'di 6/21/97 10:12'!bytecodePrimNextPut    messageSelector _ self specialSelector: 20.    argumentCount _ 1.    self normalSend.! !!Interpreter methodsFor: 'common selector sends'!bytecodePrimNotEqual    | rcvr arg |    rcvr _ self internalStackValue: 1.    arg _ self internalStackValue: 0.    (self areIntegers: rcvr and: arg) ifTrue: [        ^ self booleanCheat: rcvr ~= arg    ].    self externalizeIPandSP.    successFlag _ true.    self primitiveFloatNotEqual.    successFlag ifFalse: [        successFlag _ true.        self primitiveNotEqual.    ].    self internalizeIPandSP.! !!Interpreter methodsFor: 'common selector sends'!bytecodePrimPointX    self externalizeIPandSP.    self primitivePointX.    self internalizeIPandSP.! !!Interpreter methodsFor: 'common selector sends'!bytecodePrimPointY    self externalizeIPandSP.    self primitivePointY.    self internalizeIPandSP.! !!Interpreter methodsFor: 'common selector sends'!bytecodePrimSize    "See the comment in bytePrimitiveAt"    | arrayClass |    self externalizeIPandSP.    successFlag _ true.    arrayClass _ self fetchClassOf: (self stackValue: 0).    (self okStreamArrayClass: arrayClass)        ifTrue: [self primitiveSize]        ifFalse: [self failSpecialPrim: 0].    self internalizeIPandSP.! !!Interpreter methodsFor: 'common selector sends'!bytecodePrimSubtract    | rcvr arg result |    rcvr _ self internalStackValue: 1.    arg _ self internalStackValue: 0.    (self areIntegers: rcvr and: arg) ifTrue: [        result _ (self integerValueOf: rcvr) - (self integerValueOf: arg).        (self isIntegerValue: result) ifTrue: [            self longAt: (localSP _ localSP - 4)                    put: (self integerObjectOf: result).            ^ nil        ].    ].    self externalizeIPandSP.    successFlag _ true.    self primitiveFloatSubtract.    successFlag ifFalse: [        successFlag _ true.        self primitiveSubtract.    ].    self internalizeIPandSP.! !!Interpreter methodsFor: 'common selector sends'!bytecodePrimValue    | block |    block _ self internalStackTop.    successFlag _ true.    argumentCount _ 0.    self assertClassOf: block is: (self splObj: ClassBlockContext).    successFlag ifTrue: [        self externalizeIPandSP.        self primitiveValue.        self internalizeIPandSP.    ].    successFlag ifFalse: [        messageSelector _ self specialSelector: 25.        argumentCount _ 0.        ^ self normalSend    ].! !!Interpreter methodsFor: 'common selector sends'!bytecodePrimValueWithArg    | block |    block _ self internalStackValue: 1.    successFlag _ true.    argumentCount _ 1.    self assertClassOf: block is: (self splObj: ClassBlockContext).    successFlag ifTrue: [        self externalizeIPandSP.        self primitiveValue.        self internalizeIPandSP.    ].    successFlag ifFalse: [        messageSelector _ self specialSelector: 26.        argumentCount _ 1.        ^ self normalSend    ].! !!Interpreter methodsFor: 'primitive support'!failed    ^successFlag not! !!Interpreter methodsFor: 'primitive support'!failSpecialPrim: primIndex    "Used only for failing from a primitive that was entered as a special    bytecode.  This routine will look up the real method and, only if its    primitiveIndex is different, then it will run that primitive, otherwise    it will simply activate to run the fail code"    | bytecode selectorIndex newReceiver rcvrClass |    bytecode _ self getCurrentBytecode.    (bytecode < 176 or: [bytecode > 207])        ifTrue: ["Primitive was not running as a special bytecode"                ^ self primitiveFail].    selectorIndex _ (bytecode - 176) * 2.    messageSelector _ self fetchPointer: selectorIndex                ofObject: (self splObj: SpecialSelectors).    argumentCount _ self quickFetchInteger: selectorIndex + 1                ofObject: (self splObj: SpecialSelectors)."    self sendSelector: messageSelector argumentCount: count"    "The above line of code must be expanded and altered, because we only    want to run the ST code, not re-run the primitive and get into a loop"    newReceiver _ self stackValue: argumentCount.    rcvrClass _ self fetchClassOf: newReceiver.    self findNewMethodInClass: rcvrClass.    (primitiveIndex > 37 and: [primitiveIndex ~= primIndex])        ifTrue: [self executeNewMethod]        ifFalse: [self activateNewMethod]! !!Interpreter methodsFor: 'primitive support'!positive32BitIntegerFor: integerValue    | newLargeInteger |    "Note - integerValue is interpreted as POSITIVE, eg, as the result of        Bitmap>at:, or integer>bitAnd:."    (integerValue >= 0 and: [self isIntegerValue: integerValue])        ifTrue: [^ self integerObjectOf: integerValue].    newLargeInteger _        self instantiateSmallClass: (self splObj: ClassLargePositiveInteger)                sizeInBytes: 8                         fill: 0.    self storeByte: 3 ofObject: newLargeInteger        withValue: ((integerValue >> 24) bitAnd: 16rFF).    self storeByte: 2 ofObject: newLargeInteger        withValue: ((integerValue >> 16) bitAnd: 16rFF).    self storeByte: 1 ofObject: newLargeInteger        withValue: ((integerValue >> 8) bitAnd: 16rFF).    self storeByte: 0 ofObject: newLargeInteger        withValue: (integerValue bitAnd: 16rFF).    ^ newLargeInteger! !!Interpreter methodsFor: 'primitive support'!positive32BitValueOf: oop    "Convert the given object into an integer value.    The object may be either a positive ST integer or a four-byte LargePositiveInteger."    | sz value |    (self isIntegerObject: oop) ifTrue: [        value _ self integerValueOf: oop.        value < 0 ifTrue: [^ self primitiveFail].        ^ value].    self assertClassOf: oop is: (self splObj: ClassLargePositiveInteger).    successFlag ifTrue: [        sz _ self lengthOf: oop.        sz = 4 ifFalse: [^ self primitiveFail]].    successFlag ifTrue: [        ^ (self fetchByte: 0 ofObject: oop) +          ((self fetchByte: 1 ofObject: oop) <<  8) +          ((self fetchByte: 2 ofObject: oop) << 16) +          ((self fetchByte: 3 ofObject: oop) << 24) ].! !!Interpreter methodsFor: 'primitive support'!primIndex    ^ primitiveIndex! !!Interpreter methodsFor: 'primitive support'!primitiveFail    successFlag _ false.! !!Interpreter methodsFor: 'primitive support' stamp: 'jm 9/18/97 21:06'!primitiveResponse    primitiveIndex > MaxPrimitiveIndex ifTrue: [^ false].    successFlag _ true.    self dispatchOn: primitiveIndex in: PrimitiveTable.    "check for possible timer interrupts after each primitive"    (successFlag and:     [(nextWakeupTick ~= 0) and:     [self ioMSecs >= nextWakeupTick]]) ifTrue: [        interruptCheckCounter _ 1000.        self checkForInterrupts].    ^ successFlag! !!Interpreter methodsFor: 'primitive support'!success: successValue    successFlag _ successValue & successFlag.! !!Interpreter methodsFor: 'arithmetic primitives'!checkBooleanResult: result from: primIndex    successFlag        ifTrue: [self pushBool: result]        ifFalse: [self unPop: 2.  self failSpecialPrim: primIndex]! !!Interpreter methodsFor: 'arithmetic primitives'!checkIntegerResult: integerResult from: primIndex    (successFlag and: [self isIntegerValue: integerResult])        ifTrue: [self pushInteger: integerResult]        ifFalse: [self unPop: 2.  self failSpecialPrim: primIndex]! !!Interpreter methodsFor: 'arithmetic primitives'!compare31or32Bits: obj1 equal: obj2    "May set success to false"    "First compare two ST integers..."    ((self isIntegerObject: obj1)        and: [self isIntegerObject: obj2])        ifTrue: [^ obj1 = obj2].    "Now compare, assuming positive integers, but setting fail if not"    ^ (self positive32BitValueOf: obj1) = (self positive32BitValueOf: obj2)! !!Interpreter methodsFor: 'arithmetic primitives'!primitiveAdd    | rcvr arg result |    rcvr _ self stackValue: 1.    arg _ self stackValue: 0.    self pop: 2.    self success: (self areIntegers: rcvr and: arg).    successFlag ifTrue: [        result _ (self integerValueOf: rcvr) + (self integerValueOf: arg).    ].    self checkIntegerResult: result from: 1.! !!Interpreter methodsFor: 'arithmetic primitives'!primitiveBitAnd    | integerReceiver integerArgument |    successFlag _ true.    integerArgument _ self popPos32BitInteger.    integerReceiver _ self popPos32BitInteger.    successFlag        ifTrue: [self push: (self positive32BitIntegerFor:                    (integerReceiver bitAnd: integerArgument))]        ifFalse: [self unPop: 2.  self failSpecialPrim: 14]! !!Interpreter methodsFor: 'arithmetic primitives'!primitiveBitOr    | integerReceiver integerArgument |    successFlag _ true.    integerArgument _ self popPos32BitInteger.    integerReceiver _ self popPos32BitInteger.    successFlag        ifTrue: [self push: (self positive32BitIntegerFor:                    (integerReceiver bitOr: integerArgument))]        ifFalse: [self unPop: 2.  self failSpecialPrim: 15]! !!Interpreter methodsFor: 'arithmetic primitives'!primitiveBitShift     | integerReceiver integerArgument shifted |    successFlag _ true.    integerArgument _ self popInteger.    integerReceiver _ self popPos32BitInteger.    successFlag ifTrue: [        integerArgument >= 0 ifTrue: [            "Left shift -- must fail if we lose bits beyond 32"            self success: integerArgument <= 31.            shifted _ integerReceiver << integerArgument.            self success: (shifted >> integerArgument) = integerReceiver.        ] ifFalse: [            "Right shift -- OK to lose bits"            self success: integerArgument >= -31.            shifted _ integerReceiver bitShift: integerArgument.        ].    ].    successFlag        ifTrue: [self push: (self positive32BitIntegerFor: shifted)]        ifFalse: [self unPop: 2.  self failSpecialPrim: 17]! !!Interpreter methodsFor: 'arithmetic primitives'!primitiveBitXor    "Note: unlike all the other arithmetic primitives, this is called as    a real send, not as a special byte.  Thus successFlag has already    been set, and failure is normal, not through failSpecialPrim."    | integerReceiver integerArgument |    integerArgument _ self popPos32BitInteger.    integerReceiver _ self popPos32BitInteger.    successFlag        ifTrue: [self push: (self positive32BitIntegerFor:                    (integerReceiver bitXor: integerArgument))]        ifFalse: [self unPop: 2]! !!Interpreter methodsFor: 'arithmetic primitives'!primitiveDiv    "Rounds negative results towards negative infinity, rather than zero."    | rcvr arg result posArg posRcvr |    successFlag _ true.    arg _ self popInteger.    rcvr _ self popInteger.    self success: arg ~= 0.    successFlag ifTrue: [        rcvr > 0 ifTrue: [            arg > 0 ifTrue: [                result _ rcvr // arg.            ] ifFalse: [                "round negative result toward negative infinity"                posArg _ 0 - arg.                result _ 0 - ((rcvr + (posArg - 1)) // posArg).            ].        ] ifFalse: [            posRcvr _ 0 - rcvr.            arg > 0 ifTrue: [                "round negative result toward negative infinity"                result _ 0 - ((posRcvr + (arg - 1)) // arg).            ] ifFalse: [                posArg _ 0 - arg.                result _ posRcvr // posArg.            ].        ].        self checkIntegerResult: result from: 12]    ifFalse:        [self checkIntegerResult: 0 from: 12 "will fail"]! !!Interpreter methodsFor: 'arithmetic primitives'!primitiveDivide    | integerReceiver integerArgument |    successFlag _ true.    integerArgument _ self popInteger.    integerReceiver _ self popInteger.    self success: integerArgument ~= 0.    successFlag ifFalse: [integerArgument _ 1].  "fall through to fail"    self success: integerReceiver \\ integerArgument = 0.    self checkIntegerResult: integerReceiver // integerArgument from: 10! !!Interpreter methodsFor: 'arithmetic primitives'!primitiveEqual    | integerReceiver integerArgument result |    successFlag _ true.    integerArgument _ self popStack.    integerReceiver _ self popStack.    result _ self compare31or32Bits: integerReceiver equal: integerArgument.    self checkBooleanResult: result from: 7! !!Interpreter methodsFor: 'arithmetic primitives'!primitiveGreaterOrEqual    | integerReceiver integerArgument |    successFlag _ true.    integerArgument _ self popInteger.    integerReceiver _ self popInteger.    self checkBooleanResult: integerReceiver >= integerArgument from: 6! !!Interpreter methodsFor: 'arithmetic primitives'!primitiveGreaterThan    | integerReceiver integerArgument |    successFlag _ true.    integerArgument _ self popInteger.    integerReceiver _ self popInteger.    self checkBooleanResult: integerReceiver > integerArgument from: 4! !!Interpreter methodsFor: 'arithmetic primitives'!primitiveLessOrEqual    | integerReceiver integerArgument |    successFlag _ true.    integerArgument _ self popInteger.    integerReceiver _ self popInteger.    self checkBooleanResult: integerReceiver <= integerArgument from: 5! !!Interpreter methodsFor: 'arithmetic primitives'!primitiveLessThan    | integerReceiver integerArgument |    successFlag _ true.    integerArgument _ self popInteger.    integerReceiver _ self popInteger.    self checkBooleanResult: integerReceiver < integerArgument from: 3! !!Interpreter methodsFor: 'arithmetic primitives'!primitiveMakePoint    | integerReceiver integerArgument |    successFlag _ true.    integerArgument _ self popInteger.    integerReceiver _ self popInteger.    successFlag        ifTrue: [self push: (self makePointwithxValue: integerReceiver yValue: integerArgument)]        ifFalse: [self checkIntegerResult: 0 from: 18  "will fail"]! !!Interpreter methodsFor: 'arithmetic primitives'!primitiveMod    | integerReceiver integerArgument integerResult |    successFlag _ true.    integerArgument _ self popInteger.    integerReceiver _ self popInteger.    self success: integerArgument ~= 0.    successFlag ifFalse: [integerArgument _ 1].  "fall through to fail"    integerResult _ integerReceiver \\ integerArgument.    integerResult < 0 ifTrue: [integerResult _ integerResult + integerArgument].    self checkIntegerResult: integerResult from: 11! !!Interpreter methodsFor: 'arithmetic primitives'!primitiveMultiply    | rcvr arg result |    rcvr _ self stackValue: 1.    arg _ self stackValue: 0.    self pop: 2.    self success: (self areIntegers: rcvr and: arg).    successFlag ifTrue: [        rcvr _ self integerValueOf: rcvr.        arg _ self integerValueOf: arg.        result _ rcvr * arg.        "check for C overflow by seeing if computation is reversible"        self success: ((arg = 0) or: [(result // arg) = rcvr]).    ].    self checkIntegerResult: result from: 9.! !!Interpreter methodsFor: 'arithmetic primitives'!primitiveNotEqual    | integerReceiver integerArgument result |    successFlag _ true.    integerArgument _ self popStack.    integerReceiver _ self popStack.    result _ (self compare31or32Bits: integerReceiver equal: integerArgument) not.    self checkBooleanResult: result from: 8! !!Interpreter methodsFor: 'arithmetic primitives'!primitiveQuo    "Rounds negative results towards zero."    "Note: unlike the other arithmetic primitives, this is called as    a real send, not as a special byte.  Thus successFlag has already    been set, and failure is normal, not through failSpecialPrim."    | rcvr arg result |    arg _ self popInteger.    rcvr _ self popInteger.    self success: arg ~= 0.    successFlag ifTrue: [        rcvr > 0 ifTrue: [            arg > 0 ifTrue: [                result _ rcvr // arg.            ] ifFalse: [                result _ 0 - (rcvr // (0 - arg)).            ].        ] ifFalse: [            arg > 0 ifTrue: [                result _ 0 - ((0 - rcvr) // arg).            ] ifFalse: [                result _ (0 - rcvr) // (0 - arg).            ].        ].        self success: (self isIntegerValue: result)].    successFlag        ifTrue: [self pushInteger: result]        ifFalse: [self unPop: 2]! !!Interpreter methodsFor: 'arithmetic primitives'!primitiveSubtract    | integerReceiver integerArgument |    successFlag _ true.    integerArgument _ self popInteger.    integerReceiver _ self popInteger.    self checkIntegerResult: integerReceiver - integerArgument from: 2! !!Interpreter methodsFor: 'float primitives'!popFloat    "Note: May be called by translated primitive code."    | top result |    self returnTypeC: 'double'.    self var: #result declareC: 'double result'.    top _ self popStack.    self assertClassOf: top is: (self splObj: ClassFloat).    successFlag        ifTrue: [self fetchFloatAt: top + BaseHeaderSize into: result].    ^ result! !!Interpreter methodsFor: 'float primitives'!primitiveArctan    | rcvr |    self var: #rcvr declareC: 'double rcvr'.    rcvr _ self popFloat.    successFlag        ifTrue: [self pushFloat: (self cCode: 'atan(rcvr)')]        ifFalse: [self unPop: 1]! !!Interpreter methodsFor: 'float primitives'!primitiveAsFloat    | arg |    arg _ self popInteger.    successFlag        ifTrue: [ self pushFloat: (self cCode: '((double) arg)') ]        ifFalse: [ self unPop: 1 ].! !!Interpreter methodsFor: 'float primitives'!primitiveExp    "Computes E raised to the receiver power."    | rcvr |    self var: #rcvr declareC: 'double rcvr'.    rcvr _ self popFloat.    successFlag        ifTrue: [self pushFloat: (self cCode: 'exp(rcvr)')]        ifFalse: [self unPop: 1]! !!Interpreter methodsFor: 'float primitives'!primitiveExponent    "Exponent part of this float."    | rcvr frac pwr |    self var: #rcvr declareC: 'double rcvr'.    self var: #frac declareC: 'double frac'.    rcvr _ self popFloat.    successFlag        ifTrue: [            self cCode: 'frac = frexp(rcvr, &pwr)'.  "rcvr = frac * 2^pwr, where frac is in [0.5..1.0)"            (pwr = 0)                ifTrue: [self pushInteger: 0]                ifFalse: [self pushInteger: pwr - 1]]        ifFalse: [self unPop: 1].! !!Interpreter methodsFor: 'float primitives'!primitiveFloatAdd    | rcvr rcvrOop arg argOop result resultOop |    self var: #rcvr declareC: 'double rcvr'.    self var: #arg declareC: 'double arg'.    self var: #result declareC: 'double result'.    rcvrOop _ self stackValue: 1.    argOop _ self stackTop.    self assertFloat: rcvrOop and: argOop.    successFlag ifTrue: [        self fetchFloatAt: rcvrOop + BaseHeaderSize into: rcvr.        self fetchFloatAt: argOop + BaseHeaderSize into: arg.        result _ rcvr + arg.        resultOop _ self clone: rcvrOop.        self storeFloatAt: resultOop + BaseHeaderSize from: result.        self pop: 2 thenPush: resultOop].! !!Interpreter methodsFor: 'float primitives'!primitiveFloatDivide    | rcvr rcvrOop arg argOop result resultOop |    self var: #rcvr declareC: 'double rcvr'.    self var: #arg declareC: 'double arg'.    self var: #result declareC: 'double result'.    rcvrOop _ self stackValue: 1.    argOop _ self stackTop.    self assertFloat: rcvrOop and: argOop.    successFlag ifTrue: [        self fetchFloatAt: rcvrOop + BaseHeaderSize into: rcvr.        self fetchFloatAt: argOop + BaseHeaderSize into: arg.        self success: arg ~= 0.0.        successFlag ifTrue: [            result _ rcvr // arg.  "generates C / operation"            resultOop _ self clone: rcvrOop.            self storeFloatAt: resultOop + BaseHeaderSize from: result.            self pop: 2 thenPush: resultOop]].! !!Interpreter methodsFor: 'float primitives'!primitiveFloatEqual    | rcvr rcvrOop arg argOop |    self var: #rcvr declareC: 'double rcvr'.    self var: #arg declareC: 'double arg'.    rcvrOop _ self stackValue: 1.    argOop _ self stackTop.    self assertFloat: rcvrOop and: argOop.    successFlag ifTrue: [        self fetchFloatAt: rcvrOop + BaseHeaderSize into: rcvr.        self fetchFloatAt: argOop + BaseHeaderSize into: arg.        self pop: 2.        self pushBool: rcvr = arg].! !!Interpreter methodsFor: 'float primitives'!primitiveFloatGreaterOrEqual    | rcvr rcvrOop arg argOop |    self var: #rcvr declareC: 'double rcvr'.    self var: #arg declareC: 'double arg'.    rcvrOop _ self stackValue: 1.    argOop _ self stackTop.    self assertFloat: rcvrOop and: argOop.    successFlag ifTrue: [        self fetchFloatAt: rcvrOop + BaseHeaderSize into: rcvr.        self fetchFloatAt: argOop + BaseHeaderSize into: arg.        self pop: 2.        self pushBool: rcvr >= arg].! !!Interpreter methodsFor: 'float primitives'!primitiveFloatGreaterThan    | rcvr rcvrOop arg argOop |    self var: #rcvr declareC: 'double rcvr'.    self var: #arg declareC: 'double arg'.    rcvrOop _ self stackValue: 1.    argOop _ self stackTop.    self assertFloat: rcvrOop and: argOop.    successFlag ifTrue: [        self fetchFloatAt: rcvrOop + BaseHeaderSize into: rcvr.        self fetchFloatAt: argOop + BaseHeaderSize into: arg.        self pop: 2.        self pushBool: rcvr > arg].! !!Interpreter methodsFor: 'float primitives'!primitiveFloatLessOrEqual    | rcvr rcvrOop arg argOop |    self var: #rcvr declareC: 'double rcvr'.    self var: #arg declareC: 'double arg'.    rcvrOop _ self stackValue: 1.    argOop _ self stackTop.    self assertFloat: rcvrOop and: argOop.    successFlag ifTrue: [        self fetchFloatAt: rcvrOop + BaseHeaderSize into: rcvr.        self fetchFloatAt: argOop + BaseHeaderSize into: arg.        self pop: 2.        self pushBool: rcvr <= arg].! !!Interpreter methodsFor: 'float primitives'!primitiveFloatLessThan    | rcvr rcvrOop arg argOop |    self var: #rcvr declareC: 'double rcvr'.    self var: #arg declareC: 'double arg'.    rcvrOop _ self stackValue: 1.    argOop _ self stackTop.    self assertFloat: rcvrOop and: argOop.    successFlag ifTrue: [        self fetchFloatAt: rcvrOop + BaseHeaderSize into: rcvr.        self fetchFloatAt: argOop + BaseHeaderSize into: arg.        self pop: 2.        self pushBool: rcvr < arg].! !!Interpreter methodsFor: 'float primitives'!primitiveFloatMultiply    | rcvr rcvrOop arg argOop result resultOop |    self var: #rcvr declareC: 'double rcvr'.    self var: #arg declareC: 'double arg'.    self var: #result declareC: 'double result'.    rcvrOop _ self stackValue: 1.    argOop _ self stackTop.    self assertFloat: rcvrOop and: argOop.    successFlag ifTrue: [        self fetchFloatAt: rcvrOop + BaseHeaderSize into: rcvr.        self fetchFloatAt: argOop + BaseHeaderSize into: arg.        result _ rcvr * arg.        resultOop _ self clone: rcvrOop.        self storeFloatAt: resultOop + BaseHeaderSize from: result.        self pop: 2 thenPush: resultOop].! !!Interpreter methodsFor: 'float primitives'!primitiveFloatNotEqual    | rcvr rcvrOop arg argOop |    self var: #rcvr declareC: 'double rcvr'.    self var: #arg declareC: 'double arg'.    rcvrOop _ self stackValue: 1.    argOop _ self stackTop.    self assertFloat: rcvrOop and: argOop.    successFlag ifTrue: [        self fetchFloatAt: rcvrOop + BaseHeaderSize into: rcvr.        self fetchFloatAt: argOop + BaseHeaderSize into: arg.        self pop: 2.        self pushBool: rcvr ~= arg].! !!Interpreter methodsFor: 'float primitives'!primitiveFloatSubtract    | rcvr rcvrOop arg argOop result resultOop |    self var: #rcvr declareC: 'double rcvr'.    self var: #arg declareC: 'double arg'.    self var: #result declareC: 'double result'.    rcvrOop _ self stackValue: 1.    argOop _ self stackTop.    self assertFloat: rcvrOop and: argOop.    successFlag ifTrue: [        self fetchFloatAt: rcvrOop + BaseHeaderSize into: rcvr.        self fetchFloatAt: argOop + BaseHeaderSize into: arg.        result _ rcvr - arg.        resultOop _ self clone: rcvrOop.        self storeFloatAt: resultOop + BaseHeaderSize from: result.        self pop: 2 thenPush: resultOop].! !!Interpreter methodsFor: 'float primitives'!primitiveFractionalPart    | rcvr frac trunc |    self var: #rcvr declareC: 'double rcvr'.    self var: #frac declareC: 'double frac'.    self var: #trunc declareC: 'double trunc'.    rcvr _ self popFloat.    successFlag        ifTrue: [            self cCode: 'frac = modf(rcvr, &trunc)'.            self pushFloat: frac]        ifFalse: [self unPop: 1]! !!Interpreter methodsFor: 'float primitives'!primitiveLogN    "Natural log."    | rcvr |    self var: #rcvr declareC: 'double rcvr'.    rcvr _ self popFloat.    successFlag        ifTrue: [self pushFloat: (self cCode: 'log(rcvr)')]        ifFalse: [self unPop: 1]! !!Interpreter methodsFor: 'float primitives'!primitiveSine    | rcvr |    self var: #rcvr declareC: 'double rcvr'.    rcvr _ self popFloat.    successFlag        ifTrue: [self pushFloat: (self cCode: 'sin(rcvr)')]        ifFalse: [self unPop: 1]! !!Interpreter methodsFor: 'float primitives'!primitiveSquareRoot    | rcvr |    self var: #rcvr declareC: 'double rcvr'.    rcvr _ self popFloat.    self success: rcvr >= 0.0.    successFlag        ifTrue: [self pushFloat: (self cCode: 'sqrt(rcvr)')]        ifFalse: [self unPop: 1]! !!Interpreter methodsFor: 'float primitives'!primitiveTimesTwoPower    | rcvr arg |    self var: #rcvr declareC: 'double rcvr'.    arg _ self popInteger.    rcvr _ self popFloat.    successFlag        ifTrue: [ self pushFloat: (self cCode: 'ldexp(rcvr, arg)') ]        ifFalse: [ self unPop: 2 ].! !!Interpreter methodsFor: 'float primitives' stamp: '6/7/97 09:59 di'!primitiveTruncated     | rcvr frac trunc |    self var: #rcvr declareC: 'double rcvr'.    self var: #frac declareC: 'double frac'.    self var: #trunc declareC: 'double trunc'.    rcvr _ self popFloat.    successFlag ifTrue: [        self cCode: 'frac = modf(rcvr, &trunc)'.        self cCode: 'success((-1073741824.0 <= trunc) && (trunc <= 1073741823.0))'.    ].    successFlag        ifTrue: [self cCode: 'pushInteger((int) trunc)']        ifFalse: [self unPop: 1]! !!Interpreter methodsFor: 'float primitives'!pushFloat: f    | newFloatObj |    self var: #f declareC: 'double f'.    newFloatObj _ self instantiateSmallClass: (self splObj: ClassFloat) sizeInBytes: 12 fill: 0.    self storeFloatAt: newFloatObj + BaseHeaderSize from: f.    self push: newFloatObj.! !!Interpreter methodsFor: 'array and stream primitives'!asciiOfCharacter: characterObj  "Returns an integer object"    self inline: false.    self assertClassOf: characterObj is: (self splObj: ClassCharacter).    successFlag        ifTrue: [^ self fetchPointer: CharacterValueIndex ofObject: characterObj]        ifFalse: [^ ConstZero]  "in case some code needs an int"! !!Interpreter methodsFor: 'array and stream primitives'!byteLengthOf: oop    "Return the number of indexable bytes in the given object. This is basically a special copy of lengthOf: for BitBlt."    | header sz fmt |    header _ self baseHeader: oop.    (header bitAnd: TypeMask) = HeaderTypeSizeAndClass        ifTrue: [ sz _ (self sizeHeader: oop) bitAnd: AllButTypeMask ]        ifFalse: [ sz _ header bitAnd: 16rFC ].    fmt _ (header >> 8) bitAnd: 16rF.    fmt < 8        ifTrue: [ ^ (sz - BaseHeaderSize)]  "words"        ifFalse: [ ^ (sz - BaseHeaderSize) - (fmt bitAnd: 3)]  "bytes"! !!Interpreter methodsFor: 'array and stream primitives'!characterForAscii: integerObj  "Arg must lie in range 0-255!!"    ^ self fetchPointer: (self integerValueOf: integerObj)            ofObject: (self splObj: CharacterTable)! !!Interpreter methodsFor: 'array and stream primitives'!commonAt: stringy    "This version of at: is called from the special byteCode, from    primitiveAt, and from primStringAt.  The boolean 'stringy'    indicates that the result should be converted to a Character."    | index rcvr result |    self inline: true.    index _ self stackTop.    rcvr _ self stackValue: 1.    (self isIntegerObject: index) & (self isIntegerObject: rcvr) not ifTrue: [        index _ self integerValueOf: index.        result _ self stObject: rcvr at: index.        (stringy and: [successFlag]) ifTrue: [result _ self characterForAscii: result].    ] ifFalse: [        successFlag _ false.    ].    successFlag ifTrue: [        self pop: 2 thenPush: result.    ] ifFalse: [        stringy            ifTrue: [self failSpecialPrim: 63]            ifFalse: [self failSpecialPrim: 60].    ].! !!Interpreter methodsFor: 'array and stream primitives'!commonAtPut: stringy    "See the comment in commonAt:."    | value valToStore index rcvr |    self inline: true.    value _ valToStore _ self stackTop.    index _ self stackValue: 1.    rcvr _ self stackValue: 2.    (self isIntegerObject: index) & (self isIntegerObject: rcvr) not ifTrue: [        index _ self integerValueOf: index.        stringy ifTrue: [valToStore _ self asciiOfCharacter: value].        self stObject: rcvr at: index put: valToStore.    ] ifFalse: [        successFlag _ false.    ].    successFlag ifTrue: [        self pop: 3 thenPush: value.    ] ifFalse: [        stringy            ifTrue: [self failSpecialPrim: 64]            ifFalse: [self failSpecialPrim: 61].    ].! !!Interpreter methodsFor: 'array and stream primitives'!lengthOf: oop    "Return the number of indexable bytes or words in the given object. Assume the argument is not an integer. For a CompiledMethod, the size of the method header (in bytes) should be subtracted from the result."    | header sz fmt |    self inline: true.    "from ObjectMemory>sizeBitsOf:..."    header _ self baseHeader: oop.    (header bitAnd: TypeMask) = HeaderTypeSizeAndClass        ifTrue: [ sz _ (self sizeHeader: oop) bitAnd: AllButTypeMask ]        ifFalse: [ sz _ header bitAnd: 16rFC ].    "from ObjectMemory>formatOf:..."    fmt _ (header >> 8) bitAnd: 16rF.    fmt < 8        ifTrue: [ ^ (sz - BaseHeaderSize) >> 2 ]  "words"        ifFalse: [ ^ (sz - BaseHeaderSize) - (fmt bitAnd: 3) ]  "bytes"! !!Interpreter methodsFor: 'array and stream primitives'!lengthOf: oop baseHeader: hdr format: fmt    "Return the number of indexable bytes or words in the given object. Assume the given oop is not an integer. For a CompiledMethod, the size of the method header (in bytes) should be subtracted from the result of this method."    | sz |    self inline: true.    (hdr bitAnd: TypeMask) = HeaderTypeSizeAndClass        ifTrue: [ sz _ (self sizeHeader: oop) bitAnd: AllButTypeMask ]        ifFalse: [ sz _ hdr bitAnd: 16rFC ].    fmt < 8        ifTrue: [ ^ (sz - BaseHeaderSize) >> 2 ]  "words"        ifFalse: [ ^ (sz - BaseHeaderSize) - (fmt bitAnd: 3) ]  "bytes"! !!Interpreter methodsFor: 'array and stream primitives'!okArrayClass: cl    ^(cl = (self splObj: ClassArray) or:      [cl = (self splObj: ClassBitmap) or:      [cl = (self splObj: ClassByteArray)]])! !!Interpreter methodsFor: 'array and stream primitives'!okStreamArrayClass: cl    ^(cl = (self splObj: ClassString) or:      [cl = (self splObj: ClassArray) or:      [cl = (self splObj: ClassByteArray) or:      [cl = (self splObj: ClassBitmap)]]])! !!Interpreter methodsFor: 'array and stream primitives'!primitiveAt    self commonAt: false.! !!Interpreter methodsFor: 'array and stream primitives' stamp: 'di 6/21/97 10:13'!primitiveAtEnd    | stream array index limit arrayClass size |    stream _ self popStack.    successFlag _ ((self isPointers: stream)            and: [(self lengthOf: stream) >= (StreamReadLimitIndex+1)]).     successFlag ifTrue: [        array _ self fetchPointer: StreamArrayIndex ofObject: stream.        index _ self fetchInteger: StreamIndexIndex ofObject: stream.        limit _ self fetchInteger: StreamReadLimitIndex ofObject: stream.        arrayClass _ self fetchClassOf: array.        self success: (self okStreamArrayClass: arrayClass).        size _ self stSizeOf: array].     successFlag        ifTrue: [self pushBool: (index >= limit) | (index >= size)]        ifFalse: [self unPop: 1].! !!Interpreter methodsFor: 'array and stream primitives'!primitiveAtPut    self commonAtPut: false.! !!Interpreter methodsFor: 'array and stream primitives' stamp: 'di 6/21/97 10:13'!primitiveNext    | stream array index limit arrayClass stringy result |    stream _ self popStack.    successFlag _        ((self isPointers: stream) and:         [(self lengthOf: stream) >= (StreamReadLimitIndex + 1)]).     successFlag ifTrue: [        array _ self fetchPointer: StreamArrayIndex ofObject: stream.        index _ self fetchInteger: StreamIndexIndex ofObject: stream.        limit _ self fetchInteger: StreamReadLimitIndex ofObject: stream.        arrayClass _ self fetchClassOf: array.        stringy _ arrayClass = (self splObj: ClassString).        stringy ifFalse: [            self success: (self okStreamArrayClass: arrayClass)].        self success: index < limit].    successFlag ifTrue: [        index _ index + 1.        self pushRemappableOop: stream.        result _ self stObject: array at: index.  "may cause GC!!"        stream _ self popRemappableOop].    successFlag ifTrue: [        self storeInteger: StreamIndexIndex            ofObject: stream            withValue: index].    successFlag ifTrue: [        stringy            ifTrue: [self push: (self characterForAscii: result)]            ifFalse: [self push: result].    ] ifFalse: [        self unPop: 1].! !!Interpreter methodsFor: 'array and stream primitives' stamp: 'di 6/21/97 10:13'!primitiveNextPut    | value stream index limit array arrayClass storeVal |    value _ self popStack.    stream _ self popStack.    successFlag _ ((self isPointers: stream)            and: [(self lengthOf: stream) >= (StreamWriteLimitIndex+1)]).     successFlag ifTrue: [        array _ self fetchPointer: StreamArrayIndex ofObject: stream.        index _ self fetchInteger: StreamIndexIndex ofObject: stream.        limit _ self fetchInteger: StreamWriteLimitIndex ofObject: stream.        arrayClass _ self fetchClassOf: array.        self success: (self okStreamArrayClass: arrayClass).        self success: index < limit].    successFlag ifTrue:        [index _ index + 1.        arrayClass = (self splObj: ClassString)            ifTrue: [storeVal _ self asciiOfCharacter: value]            ifFalse: [storeVal _ value].        self stObject: array at: index put: storeVal].    successFlag ifTrue:        [self storeInteger: StreamIndexIndex ofObject: stream            withValue: index].    successFlag        ifTrue: [self push: value]        ifFalse: [self unPop: 2]! !!Interpreter methodsFor: 'array and stream primitives'!primitiveSize    | rcvr sz |    rcvr _ self stackTop.    (self isIntegerObject: rcvr)        ifTrue: [sz _ 0]  "integers have no indexable fields"        ifFalse: [sz _ self stSizeOf: rcvr].    successFlag        ifTrue: [self pop: 1. self pushInteger: sz]        ifFalse: [self failSpecialPrim: 62].! !!Interpreter methodsFor: 'array and stream primitives'!primitiveStringAt    self commonAt: true.! !!Interpreter methodsFor: 'array and stream primitives'!primitiveStringAtPut    self commonAtPut: true.! !!Interpreter methodsFor: 'array and stream primitives'!primitiveStringReplace"<array> primReplaceFrom: start to: stop with: replacement startingAt: repStart     <primitive: 105>"    | array start stop repl replStart hdr arrayFmt totalLength arrayInstSize replFmt replInstSize srcIndex |    array _ self stackValue: 4.    start _ self stackIntegerValue: 3.    stop _ self stackIntegerValue: 2.    repl _ self stackValue: 1.    replStart _ self stackIntegerValue: 0.    successFlag ifFalse: [^ self primitiveFail].    (self isIntegerObject: repl)  "can happen in LgInt copy"        ifTrue: [^ self primitiveFail].    hdr _ self baseHeader: array.    arrayFmt _ (hdr >> 8) bitAnd: 16rF.    totalLength _ self lengthOf: array baseHeader: hdr format: arrayFmt.    arrayInstSize _ self fixedFieldsOf: array format: arrayFmt length: totalLength.    ((start >= 1) and: [(start <= stop) and: [stop + arrayInstSize <= totalLength]])        ifFalse: [^ self primitiveFail].    hdr _ self baseHeader: repl.    replFmt _ (hdr >> 8) bitAnd: 16rF.    totalLength _ self lengthOf: repl baseHeader: hdr format: replFmt.    replInstSize _ self fixedFieldsOf: repl format: replFmt length: totalLength.    ((replStart >= 1) and: [stop - start + replStart + replInstSize <= totalLength])        ifFalse: [^ self primitiveFail].    "Array formats (without byteSize bits, if bytes array) must be same"    arrayFmt < 8        ifTrue: [arrayFmt = replFmt ifFalse: [^ self primitiveFail]]        ifFalse: [(arrayFmt bitAnd: 16rC) = (replFmt bitAnd: 16rC) ifFalse: [^ self primitiveFail]].    srcIndex _ replStart + replInstSize - 1.   " - 1 for 0-based access"    start + arrayInstSize - 1 to: stop + arrayInstSize - 1 do: [:i |         arrayFmt < 4 ifTrue: [  "pointer type objects"            self storePointer: i ofObject: array withValue:                (self fetchPointer: srcIndex ofObject: repl)]        ifFalse: [            arrayFmt < 8 ifTrue: [  "long-word type objects"                self storeWord: i ofObject: array withValue:                    (self fetchWord: srcIndex ofObject: repl)]            ifFalse: [  "byte-type objects"                self storeByte: i ofObject: array withValue:                    (self fetchByte: srcIndex ofObject: repl)]].        srcIndex _ srcIndex + 1.    ].    self pop: 4.  "leave rcvr on stack"! !!Interpreter methodsFor: 'array and stream primitives'!stObject: array at: index    "Return what ST would return for <obj> at: index."    | hdr fmt totalLength fixedFields |    self inline: false.    hdr _ self baseHeader: array.    fmt _ (hdr >> 8) bitAnd: 16rF.    totalLength _ self lengthOf: array baseHeader: hdr format: fmt.    fixedFields _ self fixedFieldsOf: array format: fmt length: totalLength.    ((index >= 1) and: [index <= (totalLength - fixedFields)]) ifFalse: [successFlag _ false].    successFlag        ifTrue: [^ self subscript: array with: (index + fixedFields) format: fmt]        ifFalse: [^ 0 ].! !!Interpreter methodsFor: 'array and stream primitives'!stObject: array at: index put: value    "Do what ST would return for <obj> at: index put: value."    | hdr fmt totalLength fixedFields |    self inline: false.    hdr _ self baseHeader: array.    fmt _ (hdr >> 8) bitAnd: 16rF.    totalLength _ self lengthOf: array baseHeader: hdr format: fmt.    fixedFields _ self fixedFieldsOf: array format: fmt length: totalLength.    ((index >= 1) and: [index <= (totalLength - fixedFields)]) ifFalse: [successFlag _ false].    successFlag ifTrue:        [self subscript: array with: (index + fixedFields) storing: value format: fmt].! !!Interpreter methodsFor: 'array and stream primitives'!stSizeOf: oop    "Return the number of indexable fields in the given object. (i.e., what Smalltalk would return for <obj> size)."    "Note: Assume oop is not a SmallInteger!!"    | hdr fmt totalLength fixedFields |    self inline: true.    hdr _ self baseHeader: oop.    fmt _ (hdr >> 8) bitAnd: 16rF.    totalLength _ self lengthOf: oop baseHeader: hdr format: fmt.    fixedFields _ self fixedFieldsOf: oop format: fmt length: totalLength.    ^ totalLength - fixedFields! !!Interpreter methodsFor: 'array and stream primitives'!subscript: array with: index format: fmt    "Note: This method assumes that the index is within bounds!!"    self inline: true.    fmt < 4 ifTrue: [  "pointer type objects"        ^ self fetchPointer: index - 1 ofObject: array].    fmt < 8 ifTrue: [  "long-word type objects"        ^ self positive32BitIntegerFor:            (self fetchWord: index - 1 ofObject: array)    ] ifFalse: [  "byte-type objects"        ^ self integerObjectOf:            (self fetchByte: index - 1 ofObject: array)    ].! !!Interpreter methodsFor: 'array and stream primitives'!subscript: array with: index storing: oopToStore format: fmt    "Note: This method assumes that the index is within bounds!!"    | valueToStore |    self inline: true.    fmt < 4 ifTrue: [  "pointer type objects"        self storePointer: index - 1 ofObject: array withValue: oopToStore.    ] ifFalse: [        fmt < 8 ifTrue: [  "long-word type objects"            valueToStore _ self positive32BitValueOf: oopToStore.            successFlag ifTrue:                [self storeWord: index - 1 ofObject: array withValue: valueToStore].        ] ifFalse: [  "byte-type objects"            (self isIntegerObject: oopToStore) ifFalse: [successFlag _ false].            valueToStore _ self integerValueOf: oopToStore.            ((valueToStore >= 0) and: [valueToStore <= 255]) ifFalse: [successFlag _ false].            successFlag ifTrue:                [self storeByte: index - 1 ofObject: array withValue: valueToStore].        ].    ].! !!Interpreter methodsFor: 'object access primitives'!primitiveArrayBecome    | arg rcvr |    arg _ self popStack.    rcvr _ self stackTop.    self success: (self become: rcvr with: arg).    successFlag ifFalse: [ self unPop: 1 ].! !!Interpreter methodsFor: 'object access primitives'!primitiveAsOop    | thisReceiver |    thisReceiver _ self popStack.    self success: (self isIntegerObject: thisReceiver) not.    successFlag        ifTrue: [self pushInteger: (self hashBitsOf: thisReceiver)]        ifFalse: [self unPop: 1]! !!Interpreter methodsFor: 'object access primitives'!primitiveClass    | instance |    instance _ self popStack.    self push: (self fetchClassOf: instance)! !!Interpreter methodsFor: 'object access primitives'!primitiveClone    "Return a shallow copy of the receiver."    | newCopy |    newCopy _ self clone: (self stackTop).    self pop: 1 thenPush: newCopy.! !!Interpreter methodsFor: 'object access primitives'!primitiveEquivalent    | thisObject otherObject |    otherObject _ self popStack.    thisObject _ self popStack.    self pushBool: thisObject = otherObject! !!Interpreter methodsFor: 'object access primitives'!primitiveInstVarAt    | index rcvr hdr fmt totalLength fixedFields value |    index _ self popInteger.    rcvr _ self popStack.    successFlag ifTrue: [        hdr _ self baseHeader: rcvr.        fmt _ (hdr >> 8) bitAnd: 16rF.        totalLength _ self lengthOf: rcvr baseHeader: hdr format: fmt.        fixedFields _ self fixedFieldsOf: rcvr format: fmt length: totalLength.        ((index >= 1) and: [index <= fixedFields])            ifFalse: [successFlag _ false]].    successFlag        ifTrue: [value _ self subscript: rcvr with: index format: fmt].    successFlag        ifTrue: [self push: value]        ifFalse: [self unPop: 2]! !!Interpreter methodsFor: 'object access primitives'!primitiveInstVarAtPut    | newValue index rcvr hdr fmt totalLength fixedFields |    newValue _ self popStack.    index _ self popInteger.    rcvr _ self popStack.    successFlag ifTrue: [        hdr _ self baseHeader: rcvr.        fmt _ (hdr >> 8) bitAnd: 16rF.        totalLength _ self lengthOf: rcvr baseHeader: hdr format: fmt.        fixedFields _ self fixedFieldsOf: rcvr format: fmt length: totalLength.        ((index >= 1) and: [index <= fixedFields])            ifFalse: [successFlag _ false]].    successFlag        ifTrue: [self subscript: rcvr with: index storing: newValue format: fmt].    successFlag        ifTrue: [self push: newValue]        ifFalse: [self unPop: 3]! !!Interpreter methodsFor: 'object access primitives'!primitiveNew    "Allocate a new fixed-size instance. Fail if the allocation would leave less than lowSpaceThreshold bytes free."    | class spaceOkay |    class _ self popStack.    spaceOkay _ self sufficientSpaceToInstantiate: class indexableSize: 0.    self success: spaceOkay.    successFlag        ifTrue: [ self push: (self instantiateClass: class indexableSize: 0) ]        ifFalse: [ self unPop: 1 ].! !!Interpreter methodsFor: 'object access primitives'!primitiveNewWithArg    "Allocate a new indexable instance. Fail if the allocation would leave less than lowSpaceThreshold bytes free."    | size class spaceOkay |    size _ self popInteger.    class _ self popStack.    self success: size >= 0.    successFlag ifTrue: [        spaceOkay _ self sufficientSpaceToInstantiate: class indexableSize: size.        self success: spaceOkay.    ].    successFlag        ifTrue: [ self push: (self instantiateClass: class indexableSize: size) ]        ifFalse: [ self unPop: 2 ].! !!Interpreter methodsFor: 'object access primitives'!primitiveNextInstance    | object instance |    object _ self popStack.    instance _ self instanceAfter: object.    instance = nilObj        ifTrue: [self unPop: 1. self primitiveFail]        ifFalse: [self push: instance]! !!Interpreter methodsFor: 'object access primitives'!primitiveNextObject    "Return the object following the receiver in the heap. Return the SmallInteger zero when there are no more objects."    | object instance |    object _ self popStack.    instance _ self accessibleObjectAfter: object.    instance = nil        ifTrue: [ self pushInteger: 0 ]        ifFalse: [ self push: instance ].! !!Interpreter methodsFor: 'object access primitives'!primitiveObjectAt  "Defined for CompiledMethods only"    | thisReceiver index |    index  _ self popInteger.    thisReceiver _ self popStack.    self success: index > 0.    self success: index <= ((self literalCountOf: thisReceiver) + LiteralStart).    successFlag        ifTrue: [self push: (self fetchPointer: index - 1                    ofObject: thisReceiver)]        ifFalse: [self unPop: 2]! !!Interpreter methodsFor: 'object access primitives'!primitiveObjectAtPut  "Defined for CompiledMethods only"    | thisReceiver index newValue |    newValue _ self popStack.    index _ self popInteger.    thisReceiver _ self popStack.    self success: index > 0.    self success: index <= ((self literalCountOf: thisReceiver) + LiteralStart).    successFlag        ifTrue: [self storePointer: index - 1                ofObject: thisReceiver                withValue: newValue.            self push: newValue]        ifFalse: [self unPop: 3]! !!Interpreter methodsFor: 'object access primitives'!primitiveObjectPointsTo    | rcvr thang lastField |    thang _ self popStack.    rcvr _ self popStack.    (self isIntegerObject: rcvr) ifTrue: [^ self pushBool: false].    lastField _ self lastPointerOf: rcvr.    BaseHeaderSize to: lastField by: 4 do:        [:i | (self longAt: rcvr + i) = thang            ifTrue: [^ self pushBool: true]].    self pushBool: false.! !!Interpreter methodsFor: 'object access primitives'!primitivePointX    | rcvr |     successFlag _ true.    rcvr _ self popStack.    self assertClassOf: rcvr is: (self splObj: ClassPoint).    successFlag        ifTrue: [self push: (self fetchPointer: XIndex ofObject: rcvr)]        ifFalse: [self unPop: 1.  self failSpecialPrim: 0  "will fail"]! !!Interpreter methodsFor: 'object access primitives'!primitivePointY    | rcvr |     successFlag _ true.    rcvr _ self popStack.    self assertClassOf: rcvr is: (self splObj: ClassPoint).    successFlag        ifTrue: [self push: (self fetchPointer: YIndex ofObject: rcvr)]        ifFalse: [self unPop: 1.  self failSpecialPrim: 0  "will fail"]! !!Interpreter methodsFor: 'object access primitives'!primitiveSomeInstance    | class instance |    class _ self popStack.    instance _ self initialInstanceOf: class.    instance = nilObj        ifTrue: [self primitiveFail]        ifFalse: [self push: instance]! !!Interpreter methodsFor: 'object access primitives'!primitiveSomeObject    "Return the first object in the heap."    self pop: 1.    self push: self firstAccessibleObject.! !!Interpreter methodsFor: 'object access primitives'!sufficientSpaceToInstantiate: classOop indexableSize: size    "Return the number of bytes required to allocate an instance of the given class with the given number of indexable fields."    "Details: For speed, over-estimate space needed for fixed fields or literals; the low space threshold is a blurry line."    | format okay |    self inline: true.    format _ ((self formatOfClass: classOop) >> 8) bitAnd: 16rF.    "fail if attempting to call new: on non-indexable class"    (size > 0 and: [format < 2]) ifTrue: [ ^ false ].    format < 8 ifTrue: [        "indexable fields are words or pointers"        okay _ self sufficientSpaceToAllocate: (2500 + (size * 4)).    ] ifFalse: [        "indexable fields are bytes"        okay _ self sufficientSpaceToAllocate: (2500 + size).    ].    ^ okay! !!Interpreter methodsFor: 'control primitives'!primitiveBlockCopy    | context methodContext contextSize newContext initialIP |    context _ self stackValue: 1.    (self isIntegerObject: (self fetchPointer: MethodIndex ofObject: context)) ifTrue: [        "context is a block; get the context of its enclosing method"        methodContext _ self fetchPointer: HomeIndex ofObject: context.    ] ifFalse: [        methodContext _ context.    ].    contextSize _ self sizeBitsOf: methodContext.  "in bytes, including header"    context _ nil.  "context is no longer needed and is not preserved across allocation"    "remap methodContext in case GC happens during allocation"    self pushRemappableOop: methodContext.    newContext _ self instantiateSmallClass: (self splObj: ClassBlockContext)                               sizeInBytes: contextSize                                       fill: nilObj.    methodContext _ self popRemappableOop.    initialIP _ self integerObjectOf: instructionPointer - method.    "Was instructionPointer + 3, but now it's greater by         methodOop + 4 (headerSize) and less by 1 due to preIncrement"    "Assume: have just allocated a new context; it must be young.     Thus, can use uncheck stores. See the comment in fetchContextRegisters."    self storeWord: InitialIPIndex                    ofObject: newContext        withValue: initialIP.    self storeWord: InstructionPointerIndex        ofObject: newContext        withValue: initialIP.    self storeStackPointerValue: 0                inContext: newContext.    self storePointerUnchecked: BlockArgumentCountIndex    ofObject: newContext        withValue: (self stackValue: 0).    self storePointerUnchecked: HomeIndex        ofObject: newContext        withValue: methodContext.    self pop: 2.  "block argument count, rcvr"    self push: newContext.! !!Interpreter methodsFor: 'control primitives'!primitivePerform    | performSelector newReceiver selectorIndex |    performSelector _ messageSelector.    messageSelector _ self stackValue: argumentCount - 1.    newReceiver _ self stackValue: argumentCount.    "NOTE: the following lookup may fail and be converted to #doesNotUnderstand:,        so we must adjust argument count now, so that would work."    argumentCount _ argumentCount - 1.    self lookupMethodInClass: (self fetchClassOf: newReceiver).    self success: (self argumentCountOf: newMethod) = argumentCount.    successFlag        ifTrue: [selectorIndex _ self stackPointerIndex - argumentCount.                self transfer: argumentCount                    fromIndex: selectorIndex + 1                    ofObject: activeContext                    toIndex: selectorIndex                    ofObject: activeContext.                self pop: 1.                self executeNewMethod.  "Recursive xeq affects successFlag"                successFlag _ true]        ifFalse: [argumentCount _ argumentCount + 1.                messageSelector _ performSelector]! !!Interpreter methodsFor: 'control primitives' stamp: 'jm 9/18/97 21:36'!primitivePerformWithArgs    | thisReceiver performSelector argumentArray arraySize index cntxSize |    argumentArray _ self popStack.    arraySize _ self fetchWordLengthOf: argumentArray.    cntxSize _ self fetchWordLengthOf: activeContext.    self success: (self stackPointerIndex + arraySize) < cntxSize.    self assertClassOf: argumentArray is: (self splObj: ClassArray).    successFlag        ifTrue: [performSelector _ messageSelector.                messageSelector _ self popStack.                thisReceiver _ self stackTop.                argumentCount _ arraySize.                index _ 1.                [index <= argumentCount]                    whileTrue:                    [self push: (self fetchPointer: index - 1 ofObject: argumentArray).                    index _ index + 1].                self lookupMethodInClass: (self fetchClassOf: thisReceiver).                self success: (self argumentCountOf: newMethod) = argumentCount.                successFlag                    ifTrue: [self executeNewMethod.  "Recursive xeq affects successFlag"                            successFlag _ true]                    ifFalse: [self pop: argumentCount.                            self push: messageSelector.                            self push: argumentArray.                            argumentCount _ 2.                            messageSelector _ performSelector]]    ifFalse: [self unPop: 1]! !!Interpreter methodsFor: 'control primitives'!primitiveValue    | blockContext blockArgumentCount initialIP |    blockContext _ self stackValue: argumentCount.    blockArgumentCount _ self argumentCountOfBlock: blockContext.    self success: (argumentCount = blockArgumentCount            and: [(self fetchPointer: CallerIndex ofObject: blockContext) = nilObj]).    successFlag        ifTrue: [self transfer: argumentCount                fromIndex: self stackPointerIndex - argumentCount + 1                ofObject: activeContext                toIndex: TempFrameStart                ofObject: blockContext.            "Assume: The call to transfer:... makes blockContext a root if necessary,             allowing use to use unchecked stored in the following code."            self pop: argumentCount + 1.            initialIP _ self fetchPointer: InitialIPIndex    ofObject: blockContext.            self storePointerUnchecked: InstructionPointerIndex ofObject: blockContext                withValue: initialIP.            self storeStackPointerValue: argumentCount    inContext: blockContext.            self storePointerUnchecked: CallerIndex        ofObject: blockContext                withValue: activeContext.            self newActiveContext: blockContext]! !!Interpreter methodsFor: 'control primitives'!primitiveValueWithArgs    | argumentArray blockContext blockArgumentCount arrayArgumentCount initialIP |    argumentArray _ self popStack.    blockContext _ self popStack.    blockArgumentCount _ self argumentCountOfBlock: blockContext.    self assertClassOf: argumentArray is: (self splObj: ClassArray).    successFlag ifTrue: [        arrayArgumentCount _ self fetchWordLengthOf: argumentArray.        self success: (arrayArgumentCount = blockArgumentCount            and: [(self fetchPointer: CallerIndex ofObject: blockContext) = nilObj])].    successFlag ifTrue: [        self transfer: arrayArgumentCount            fromIndex: 0            ofObject: argumentArray            toIndex: TempFrameStart            ofObject: blockContext.        "Assume: The call to transfer:... makes blockContext a root if necessary,         allowing use to use unchecked stored in the following code."        initialIP _ self fetchPointer: InitialIPIndex            ofObject: blockContext.        self storePointerUnchecked: InstructionPointerIndex    ofObject: blockContext            withValue: initialIP.        self storeStackPointerValue: arrayArgumentCount    inContext: blockContext.        self storePointerUnchecked: CallerIndex                ofObject: blockContext            withValue: activeContext.        self newActiveContext: blockContext.    ] ifFalse: [self unPop: 2].! !!Interpreter methodsFor: 'processes'!addLastLink: proc toList: aList    "Add the given process to the given linked list and set the backpointer    of process to its new list."    | lastLink |    (self isEmptyList: aList) ifTrue: [        self storePointer: FirstLinkIndex ofObject: aList withValue: proc.    ] ifFalse: [        lastLink _ self fetchPointer: LastLinkIndex ofObject: aList.        self storePointer: NextLinkIndex ofObject: lastLink withValue: proc.    ].    self storePointer: LastLinkIndex ofObject: aList withValue: proc.    self storePointer: MyListIndex   ofObject:  proc withValue: aList.! !!Interpreter methodsFor: 'processes' stamp: 'jm 9/10/97 20:00'!checkForInterrupts    "Check for possible interrupts and handle one if necessary."    | sema now index externalObjects semaClass |    self inline: false.    now _ self ioMSecs.    now < lastTick ifTrue: [        "millisecond clock wrapped"        nextPollTick _ now + (nextPollTick - lastTick).        nextWakeupTick ~= 0            ifTrue: [nextWakeupTick _ now + (nextWakeupTick - lastTick)]].    lastTick _ now.  "used to detect millisecond clock wrapping"    signalLowSpace ifTrue: [        signalLowSpace _ false.  "reset flag"        sema _ (self splObj: TheLowSpaceSemaphore).        sema = nilObj ifFalse: [^ self synchronousSignal: sema]].    now >= nextPollTick ifTrue: [        self ioProcessEvents.  "sets interruptPending if interrupt key pressed"        nextPollTick _ now + 500].  "msecs to wait before next call to ioProcessEvents"    interruptPending ifTrue: [        interruptPending _ false.  "reset interrupt flag"        sema _ (self splObj: TheInterruptSemaphore).        sema = nilObj ifFalse: [^ self synchronousSignal: sema]].    ((nextWakeupTick ~= 0) and: [now >= nextWakeupTick]) ifTrue: [        nextWakeupTick _ 0.  "reset timer interrupt"        sema _ (self splObj: TheTimerSemaphore).        sema = nilObj ifFalse: [^ self synchronousSignal: sema]].    "signal all semaphores in semaphoresToSignal"     semaphoresToSignalCount > 0 ifTrue: [        externalObjects _ self splObj: ExternalObjectsArray.        semaClass _ self splObj: ClassSemaphore.        1 to: semaphoresToSignalCount do: [:i |            index _ semaphoresToSignal at: i.            sema _ self fetchPointer: index - 1 ofObject: externalObjects.                "Note: semaphore indices are 1-based"            (self fetchClassOf: sema) = semaClass                ifTrue: [self synchronousSignal: sema]].        semaphoresToSignalCount _ 0].! !!Interpreter methodsFor: 'processes'!internalQuickCheckForInterrupts    "Internal version of quickCheckForInterrupts for use within jumps."    ((interruptCheckCounter _ interruptCheckCounter - 1) <= 0) ifTrue: [        interruptCheckCounter _ 1000.        self externalizeIPandSP.        self checkForInterrupts.        self internalizeIPandSP.    ].! !!Interpreter methodsFor: 'processes'!isEmptyList: aLinkedList    ^ (self fetchPointer: FirstLinkIndex ofObject: aLinkedList) = nilObj! !!Interpreter methodsFor: 'processes'!primitiveResume    | proc |    proc _ self stackTop.  "rcvr"    "self success: ((self fetchClassOf: proc) = (self splObj: ClassProcess))."    successFlag ifTrue: [ self resume: proc ].! !!Interpreter methodsFor: 'processes'!primitiveSignal    | sema |    sema _ self stackTop.  "rcvr"    self assertClassOf: sema is: (self splObj: ClassSemaphore).    successFlag ifTrue: [ self synchronousSignal: sema ].! !!Interpreter methodsFor: 'processes'!primitiveSuspend    | activeProc |    activeProc _ self fetchPointer: ActiveProcessIndex                         ofObject: self schedulerPointer.    self success: self stackTop = activeProc.    successFlag ifTrue: [        self pop: 1.        self push: nilObj.        self transferTo: self wakeHighestPriority.    ].! !!Interpreter methodsFor: 'processes'!primitiveWait    | sema excessSignals activeProc |    sema _ self stackTop.  "rcvr"    self assertClassOf: sema is: (self splObj: ClassSemaphore).    successFlag ifTrue: [        excessSignals _            self fetchInteger: ExcessSignalsIndex ofObject: sema.        excessSignals > 0 ifTrue: [            self storeInteger: ExcessSignalsIndex                ofObject: sema withValue: excessSignals - 1.        ] ifFalse: [            activeProc _ self fetchPointer: ActiveProcessIndex                                 ofObject: self schedulerPointer.            self addLastLink: activeProc toList: sema.            self transferTo: self wakeHighestPriority.        ].    ].! !!Interpreter methodsFor: 'processes'!putToSleep: aProcess    "Save the given process on the scheduler process list for its priority."    | priority processLists processList |    priority _ self quickFetchInteger: PriorityIndex ofObject: aProcess.    processLists _ self fetchPointer: ProcessListsIndex ofObject: self schedulerPointer.    processList _ self fetchPointer: priority - 1 ofObject: processLists.    self addLastLink: aProcess toList: processList.! !!Interpreter methodsFor: 'processes'!quickCheckForInterrupts    "Quick check for possible user or timer interrupts. Decrement a counter and only do a real check when counter reaches zero or when a low space or user interrupt is pending."    "Note: Clients who set signalLowSpace or interruptPending should also set interruptCheckCounter to zero to get immediate results."    "Note: Requires that instructionPointer and stackPointer be external."    ((interruptCheckCounter _ interruptCheckCounter - 1) <= 0) ifTrue: [        interruptCheckCounter _ 1000.        self checkForInterrupts.    ].! !!Interpreter methodsFor: 'processes'!removeFirstLinkOfList: aList    "Remove the first process from the given linked list."    | first last next |    first _ self fetchPointer: FirstLinkIndex ofObject: aList.    last  _ self fetchPointer: LastLinkIndex ofObject: aList.    first = last ifTrue: [        self storePointer: FirstLinkIndex ofObject: aList withValue: nilObj.        self storePointer:  LastLinkIndex ofObject: aList withValue: nilObj.    ] ifFalse: [        next _ self fetchPointer: NextLinkIndex ofObject: first.        self storePointer: FirstLinkIndex ofObject: aList withValue: next.    ].    self storePointer: NextLinkIndex ofObject: first withValue: nilObj.    ^ first! !!Interpreter methodsFor: 'processes'!resume: aProcess    | activeProc activePriority newPriority |    self inline: false.    activeProc _ self fetchPointer: ActiveProcessIndex                         ofObject: self schedulerPointer.    activePriority _ self quickFetchInteger: PriorityIndex ofObject: activeProc.    newPriority   _ self quickFetchInteger: PriorityIndex ofObject: aProcess.    newPriority > activePriority ifTrue: [        self putToSleep: activeProc.        self transferTo: aProcess.    ] ifFalse: [        self putToSleep: aProcess.    ].! !!Interpreter methodsFor: 'processes'!schedulerPointer    ^ self fetchPointer: ValueIndex        ofObject: (self splObj: SchedulerAssociation)! !!Interpreter methodsFor: 'processes' stamp: 'jm 8/24/97 22:55'!signalSemaphoreWithIndex: index    "If it is not there already, record the given semaphore index in the list of semaphores to be signaled at the next convenient moment. Set the interruptCheckCounter to zero to force a real interrupt check as soon as possible."    index <= 0 ifTrue: [^ nil].  "bad index; ignore it"    interruptCheckCounter _ 0.    1 to: semaphoresToSignalCount do: [:i |        (semaphoresToSignal at: i) = index ifTrue: [^ nil]].    semaphoresToSignalCount < SemaphoresToSignalSize ifTrue: [        semaphoresToSignalCount _ semaphoresToSignalCount + 1.        semaphoresToSignal at: semaphoresToSignalCount put: index].! !!Interpreter methodsFor: 'processes'!synchronousSignal: aSemaphore    "Signal the given semaphore from within the interpreter."    | excessSignals |    self inline: false.    (self isEmptyList: aSemaphore) ifTrue: [        "no process is waiting on this semaphore"        excessSignals _            self fetchInteger: ExcessSignalsIndex ofObject: aSemaphore.        self storeInteger: ExcessSignalsIndex            ofObject: aSemaphore withValue: excessSignals + 1.    ] ifFalse: [        self resume: (self removeFirstLinkOfList: aSemaphore).    ].! !!Interpreter methodsFor: 'processes'!transferTo: newProc    "Record a process to be awoken on the next interpreter cycle."    | sched oldProc |    sched _ self schedulerPointer.    oldProc _ self fetchPointer: ActiveProcessIndex ofObject: sched.    self storePointer: SuspendedContextIndex ofObject: oldProc withValue: activeContext.    self storePointer: ActiveProcessIndex      ofObject:   sched withValue: newProc.    self newActiveContext:        (self fetchPointer: SuspendedContextIndex ofObject: newProc).    reclaimableContextCount _ 0.! !!Interpreter methodsFor: 'processes'!wakeHighestPriority    "Return the highest priority process that is ready to run."    "Note: It is a fatal VM error if there is no runnable process."    | schedLists p processList |    schedLists _ self fetchPointer: ProcessListsIndex                ofObject: self schedulerPointer.    p _ self fetchWordLengthOf: schedLists.    p _ p - 1.  "index of last indexable field"    processList _ self fetchPointer: p ofObject: schedLists.    [self isEmptyList: processList] whileTrue: [        p _ p - 1.        p < 0 ifTrue: [ self error: 'scheduler could not find a runnable process' ].        processList _ self fetchPointer: p ofObject: schedLists.    ].    ^ self removeFirstLinkOfList: processList! !!Interpreter methodsFor: 'I/O primitives'!fullDisplayUpdate    "Repaint the entire smalltalk screen, ignoring the affected rectangle. Used when the Smalltalk window is brought to the front or uncovered."    | displayObj dispBits w h dispBitsIndex d |    displayObj _ self splObj: TheDisplay.    ((self isPointers: displayObj) and: [(self lengthOf: displayObj) >= 4]) ifTrue: [        dispBits _ self fetchPointer: 0 ofObject: displayObj.        w _ self fetchInteger: 1 ofObject: displayObj.        h _ self fetchInteger: 2 ofObject: displayObj.        d _ self fetchInteger: 3 ofObject: displayObj.        dispBitsIndex _ dispBits + BaseHeaderSize.  "index in memory byte array"        self cCode: 'ioShowDisplay(dispBitsIndex, w, h, d, 0, w, 0, h)'.    ].! !!Interpreter methodsFor: 'I/O primitives'!primitiveBeCursor    "Set the cursor to the given shape. The Mac only supports 16x16 pixel cursors. Cursor offsets are handled by Smalltalk."    | cursorObj bitsObj extentX extentY offsetObj offsetX offsetY cursorBitsIndex |    cursorObj _ self stackTop.    self success: ((self isPointers: cursorObj) and: [(self lengthOf: cursorObj) >= 5]).    successFlag ifTrue: [        bitsObj _ self fetchPointer: 0 ofObject: cursorObj.        extentX _ self fetchInteger: 1 ofObject: cursorObj.        extentY _ self fetchInteger: 2 ofObject: cursorObj.        offsetObj _ self fetchPointer: 4 ofObject: cursorObj.        self success: ((self isPointers: offsetObj) and: [(self lengthOf: offsetObj) >= 2]).    ].    successFlag ifTrue: [        offsetX _ self fetchInteger: 0 ofObject: offsetObj.        offsetY _ self fetchInteger: 1 ofObject: offsetObj.        self success: ((extentX = 16) and: [extentY = 16]).        self success: ((offsetX >= -16) and: [offsetX <= 0]).        self success: ((offsetY >= -16) and: [offsetY <= 0]).        self success: ((self isWords: bitsObj) and: [(self lengthOf: bitsObj) = 16]).        cursorBitsIndex _ bitsObj + BaseHeaderSize.    ].    successFlag ifTrue: [        self cCode: 'ioSetCursor(cursorBitsIndex, offsetX, offsetY)'.    ].! !!Interpreter methodsFor: 'I/O primitives'!primitiveBeDisplay    "Record the system Display object."    | rcvr |    rcvr _ self stackTop.    self success: ((self isPointers: rcvr) and: [(self lengthOf: rcvr) >= 4]).    successFlag ifTrue: [        "record the display object both in a variable and in the specialObjectsOop"        self storePointer: TheDisplay ofObject: specialObjectsOop withValue: rcvr.    ].! !!Interpreter methodsFor: 'I/O primitives'!primitiveBeep    self ioBeep.! !!Interpreter methodsFor: 'I/O primitives'!primitiveCopyBits    "Invoke the copyBits primitive. If the destination is the display, then copy it to the screen."    | rcvr |    rcvr _ self stackTop.    self success: (self loadBitBltFrom: rcvr).    successFlag ifTrue: [        self copyBits.        self showDisplayBits.    ].! !!Interpreter methodsFor: 'I/O primitives'!primitiveDrawLoop    "Invoke the line drawing primitive."    | rcvr xDelta yDelta |    rcvr _ self stackValue: 2.    xDelta _ self stackIntegerValue: 1.    yDelta _ self stackIntegerValue: 0.    self success: (self loadBitBltFrom: rcvr).    successFlag ifTrue: [        self drawLoopX: xDelta Y: yDelta.        self showDisplayBits.        self pop: 2].! !!Interpreter methodsFor: 'I/O primitives'!primitiveInputSemaphore    "Register the input semaphore. If the argument is not a Semaphore, unregister the current input semaphore."    | arg |    arg _ self popStack.    ((self fetchClassOf: arg) = (self splObj: ClassSemaphore)) ifTrue: [        self storePointer: TheInputSemaphore ofObject: specialObjectsOop withValue: arg.    ] ifFalse: [        self storePointer: TheInputSemaphore ofObject: specialObjectsOop withValue: nilObj.    ].! !!Interpreter methodsFor: 'I/O primitives'!primitiveInputWord    "Return an integer indicating the reason for the most recent input interrupt."    self pop: 1.    self pushInteger: 0.    "noop for now"! !!Interpreter methodsFor: 'I/O primitives'!primitiveInterruptSemaphore    "Register the user interrupt semaphore. If the argument is not a Semaphore, unregister the current interrupt semaphore."    | arg |    arg _ self popStack.    ((self fetchClassOf: arg) = (self splObj: ClassSemaphore)) ifTrue: [        self storePointer: TheInterruptSemaphore ofObject: specialObjectsOop withValue: arg.    ] ifFalse: [        self storePointer: TheInterruptSemaphore ofObject: specialObjectsOop withValue: nilObj.    ].! !!Interpreter methodsFor: 'I/O primitives'!primitiveKbdNext    "Return the next keycode and remove it from the input buffer. The low byte is the 8-bit ISO character. The next four bits are the Smalltalk modifier bits <cmd><option><ctrl><shift>."    | keystrokeWord |    self pop: 1.    keystrokeWord _ self ioGetKeystroke.    keystrokeWord >= 0        ifTrue: [self pushInteger: keystrokeWord]        ifFalse: [self push: nilObj].! !!Interpreter methodsFor: 'I/O primitives'!primitiveKbdPeek    "Return the next keycode and without removing it from the input buffer. The low byte is the 8-bit ISO character. The next four bits are the Smalltalk modifier bits <cmd><option><ctrl><shift>."    | keystrokeWord |    self pop: 1.    keystrokeWord _ self ioPeekKeystroke.    keystrokeWord >= 0        ifTrue: [self pushInteger: keystrokeWord]        ifFalse: [self push: nilObj].! !!Interpreter methodsFor: 'I/O primitives'!primitiveMouseButtons    "Return the mouse button state. The low three bits encode the state of the <red><yellow><blue> mouse buttons. The next four bits encode the Smalltalk modifier bits <cmd><option><ctrl><shift>."    | buttonWord |    self pop: 1.    buttonWord _ self ioGetButtonState.    self pushInteger: buttonWord.! !!Interpreter methodsFor: 'I/O primitives'!primitiveMousePoint    "Return a Point indicating current position of the mouse. Note that mouse coordinates may be negative if the mouse moves above or to the left of the top-left corner of the Smalltalk window."    | pointWord x y |    self pop: 1.    pointWord _ self ioMousePoint.    x _ self signExtend16: ((pointWord >> 16) bitAnd: 16rFFFF).    y _ self signExtend16: (pointWord bitAnd: 16rFFFF).    self push: (self makePointwithxValue: x  yValue: y).! !!Interpreter methodsFor: 'I/O primitives'!primitiveScanCharacters    "Invoke the scanCharacters primitive."    | rcvr start stop string rightX stopArray displayFlag |    rcvr _ self stackValue: 6.    start _ self stackIntegerValue: 5.    stop _ self stackIntegerValue: 4.    string _ self stackValue: 3.    rightX _ self stackIntegerValue: 2.    stopArray _ self stackValue: 1.    displayFlag _ self booleanValueOf: (self stackValue: 0).    successFlag ifFalse: [^ nil].    self success: (self loadScannerFrom: rcvr                    start: start stop: stop string: string rightX: rightX                    stopArray: stopArray displayFlag: displayFlag).    successFlag        ifTrue: [self scanCharacters].    successFlag        ifTrue: [            displayFlag ifTrue: [self showDisplayBits].            self pop: 7.            self push: self stopReason].! !!Interpreter methodsFor: 'I/O primitives'!primitiveScreenSize    "Return a point indicating the current size of the Smalltalk window."    | pointWord |    self pop: 1.    pointWord _ self ioScreenSize.    self push:        (self makePointwithxValue: ((pointWord >>16) bitAnd: 16rFFFF)                           yValue: (pointWord bitAnd: 16rFFFF)).! !!Interpreter methodsFor: 'I/O primitives'!primitiveSetInterruptKey    "Set the user interrupt keycode. The keycode is an integer whose encoding is described in the comment for primitiveKbdNext."    | keycode |    keycode _ self popInteger.    successFlag        ifTrue: [ interruptKeycode _ keycode ]        ifFalse: [ self unPop: 1 ].! !!Interpreter methodsFor: 'I/O primitives'!primitiveWarpBits    "Invoke the warpBits primitive. If the destination is the display, then copy it to the screen."    | rcvr |    rcvr _ self stackValue: self argCount.    self success: (self loadBitBltFrom: rcvr).    successFlag ifTrue: [        self warpBits.        self showDisplayBits.    ].! !!Interpreter methodsFor: 'I/O primitives'!showDisplayBits    "Repaint the portion of the Smalltalk screen bounded by the affected rectangle. Used to synchronize the screen after a Bitblt to the Smalltalk Display object."    | displayObj dispBits w h affectedRectL affectedRectR affectedRectT affectedRectB dispBitsIndex d |    displayObj _ self splObj: TheDisplay.    self targetForm = displayObj ifFalse: [^ nil].    self success: ((self isPointers: displayObj) and: [(self lengthOf: displayObj) >= 4]).    successFlag ifTrue: [        dispBits _ self fetchPointer: 0 ofObject: displayObj.        w _ self fetchInteger: 1 ofObject: displayObj.        h _ self fetchInteger: 2 ofObject: displayObj.        d _ self fetchInteger: 3 ofObject: displayObj.    ].    successFlag ifTrue: [        affectedRectL _ self affectedLeft.        affectedRectR _ self affectedRight.        affectedRectT _ self affectedTop.        affectedRectB _ self affectedBottom.        dispBitsIndex _ dispBits + BaseHeaderSize.  "index in memory byte array"        self cCode: 'ioShowDisplay(dispBitsIndex, w, h, d, affectedRectL, affectedRectR, affectedRectT, affectedRectB)'.    ].! !!Interpreter methodsFor: 'file primitives'!asciiDirectoryDelimiter    ^ self cCode: 'dir_Delimitor()'! !!Interpreter methodsFor: 'file primitives'!fileRecordSize    "Return the size of a Smalltalk file record in bytes."    ^ self cCode: 'sizeof(SQFile)'.! !!Interpreter methodsFor: 'file primitives'!fileValueOf: objectPointer    "Return a pointer to the first byte of of the file record within the given Smalltalk object, or nil if objectPointer is not a file record."    | fileIndex |    self returnTypeC: 'SQFile *'.    self success:        ((self isBytes: objectPointer) and:         [(self lengthOf: objectPointer) = self fileRecordSize]).    successFlag ifTrue: [        fileIndex _ objectPointer + BaseHeaderSize.        ^ self cCode: '(SQFile *) fileIndex'    ] ifFalse:  [        ^ nil    ].! !!Interpreter methodsFor: 'file primitives'!makeDirEntryName: entryName size: entryNameSize    createDate: createDate modDate: modifiedDate    isDir: dirFlag fileSize: fileSize    | modDateOop createDateOop nameString results |    self var: 'entryName' declareC: 'char *entryName'.    "allocate storage for results, remapping newly allocated     oops in case GC happens during allocation"    self pushRemappableOop:        (self instantiateClass: (self splObj: ClassArray) indexableSize: 5).    self pushRemappableOop:        (self instantiateClass: (self splObj: ClassString) indexableSize: entryNameSize)..    self pushRemappableOop: (self positive32BitIntegerFor: createDate).    self pushRemappableOop: (self positive32BitIntegerFor: modifiedDate).    modDateOop   _ self popRemappableOop.    createDateOop _ self popRemappableOop.    nameString    _ self popRemappableOop.    results         _ self popRemappableOop.    "copy name into Smalltalk string"    0 to: entryNameSize - 1 do: [ :i |        self storeByte: i ofObject: nameString withValue: (entryName at: i).    ].    self storePointer: 0 ofObject: results withValue: nameString.    self storePointer: 1 ofObject: results withValue: createDateOop.    self storePointer: 2 ofObject: results withValue: modDateOop.    dirFlag        ifTrue: [ self storePointer: 3 ofObject: results withValue: trueObj ]        ifFalse: [ self storePointer: 3 ofObject: results withValue: falseObj ].    self storePointer: 4 ofObject: results        withValue: (self integerObjectOf: fileSize).    ^ results! !!Interpreter methodsFor: 'file primitives'!primitiveDirectoryCreate    | dirName dirNameIndex dirNameSize |    dirName _ self stackTop.    self success: (self isBytes: dirName).    successFlag ifTrue: [        dirNameIndex _ dirName + BaseHeaderSize.        dirNameSize _ self lengthOf: dirName.    ].    successFlag ifTrue: [        self success:            (self cCode: 'dir_Create((char *) dirNameIndex, dirNameSize)').    ].    successFlag ifTrue: [        self pop: 1.  "pop dirName; leave rcvr on stack"    ].! !!Interpreter methodsFor: 'file primitives'!primitiveDirectoryDelimitor    | ascii |    ascii _ self asciiDirectoryDelimiter.    self success: ((ascii >= 0) and: [ascii <= 255]).    successFlag ifTrue: [        self pop: 1.  "pop rcvr"        self push: (self fetchPointer: ascii ofObject: (self splObj: CharacterTable)).    ].! !!Interpreter methodsFor: 'file primitives'!primitiveDirectoryLookup    | index pathName pathNameIndex pathNameSize status entryName entryNameSize createDate modifiedDate dirFlag fileSize |    self var: 'entryName' declareC: 'char entryName[256]'.    index _ self stackIntegerValue: 0.    pathName _ self stackValue: 1.    self success: (self isBytes: pathName).    successFlag ifTrue: [        pathNameIndex _ pathName + BaseHeaderSize.        pathNameSize _ self lengthOf: pathName.    ].    successFlag ifTrue: [        status _ self cCode:            'dir_Lookup(                (char *) pathNameIndex, pathNameSize, index,                entryName, &entryNameSize, &createDate, &modifiedDate,                &dirFlag, &fileSize)'.        status = DirNoMoreEntries ifTrue: [            "no more entries; return nil"            self pop: 3.  "pop pathName, index, rcvr"            self push: nilObj.            ^ nil        ].        status = DirBadPath ifTrue: [ ^ self primitiveFail ].  "bad path"    ].    successFlag ifTrue: [        self pop: 3.  "pop pathName, index, rcvr"        self push:            (self makeDirEntryName: entryName size: entryNameSize                createDate: createDate modDate: modifiedDate                isDir: dirFlag fileSize: fileSize).    ].! !!Interpreter methodsFor: 'file primitives'!primitiveDirectorySetMacTypeAndCreator    | creatorString typeString fileName creatorStringIndex typeStringIndex fileNameIndex fileNameSize |    creatorString _ self stackTop.    typeString _ self stackValue: 1.    fileName _ self stackValue: 2.    self success: ((self isBytes: creatorString) and: [(self lengthOf: creatorString) = 4]).    self success: ((self isBytes: typeString) and: [(self lengthOf: typeString) = 4]).    self success: (self isBytes: fileName).    successFlag ifTrue: [        creatorStringIndex _ creatorString + BaseHeaderSize.        typeStringIndex _ typeString + BaseHeaderSize.        fileNameIndex _ fileName + BaseHeaderSize.        fileNameSize _ self lengthOf: fileName.    ].    successFlag ifTrue: [        self success:            (self cCode: 'dir_SetMacFileTypeAndCreator(                (char *) fileNameIndex, fileNameSize,                (char *) typeStringIndex, (char *) creatorStringIndex)').    ].    successFlag ifTrue: [        self pop: 3.  "pop filename, type, creator; leave rcvr on stack"    ].! !!Interpreter methodsFor: 'file primitives'!primitiveFileAtEnd    | file atEnd |    self var: 'file' declareC: 'SQFile *file'.    file _ self fileValueOf: self stackTop.    successFlag ifTrue: [ atEnd _ self sqFileAtEnd: file ].    successFlag ifTrue: [        self pop: 2.  "rcvr, file"        self pushBool: atEnd.    ].! !!Interpreter methodsFor: 'file primitives'!primitiveFileClose    | file |    self var: 'file' declareC: 'SQFile *file'.    file _ self fileValueOf: self stackTop.    successFlag ifTrue: [ self sqFileClose: file ].    successFlag ifTrue: [ self pop: 1  "pop file; leave rcvr on stack" ].! !!Interpreter methodsFor: 'file primitives'!primitiveFileDelete    | namePointer nameIndex nameSize |    namePointer _ self stackTop.    self success: (self isBytes: namePointer).    successFlag ifTrue: [        nameIndex _ namePointer + BaseHeaderSize.        nameSize _ self lengthOf: namePointer.    ].    successFlag ifTrue: [        self sqFileDeleteName: nameIndex Size: nameSize.    ].    successFlag ifTrue: [ self pop: 1. "pop name, leave rcvr on stack" ].! !!Interpreter methodsFor: 'file primitives'!primitiveFileGetPosition    | file position |    self var: 'file' declareC: 'SQFile *file'.    file _ self fileValueOf: (self stackTop).    successFlag ifTrue: [ position _ self sqFileGetPosition: file ].    successFlag ifTrue: [        self pop: 2.  "rcvr, file"        self pushInteger: position.    ].! !!Interpreter methodsFor: 'file primitives'!primitiveFileOpen    | writeFlag namePointer filePointer file nameIndex nameSize |    self var: 'file' declareC: 'SQFile *file'.    writeFlag _ self booleanValueOf: (self stackTop).    namePointer _ self stackValue: 1.    self success: (self isBytes: namePointer).    successFlag ifTrue: [        filePointer _ self instantiateClass: (self splObj: ClassByteArray)                           indexableSize: self fileRecordSize.        file _ self fileValueOf: filePointer.        nameIndex _ namePointer + BaseHeaderSize.        nameSize _ self lengthOf: namePointer.    ].    successFlag ifTrue: [        self cCode: 'sqFileOpen(file, nameIndex, nameSize, writeFlag)'.    ].    successFlag ifTrue: [        self pop: 3.  "rcvr, name, writeFlag"        self push: filePointer.    ].! !!Interpreter methodsFor: 'file primitives'!primitiveFileRead    | count startIndex array file byteSize arrayIndex bytesRead |    self var: 'file' declareC: 'SQFile *file'.    count        _ self stackIntegerValue: 0.    startIndex    _ self stackIntegerValue: 1.    array        _ self stackValue: 2.    file            _ self fileValueOf: (self stackValue: 3).    "buffer can be any indexable words or bytes object except CompiledMethod"    self success: (self isWordsOrBytes: array).    (self isWords: array)        ifTrue: [ byteSize _ 4 ]        ifFalse: [ byteSize _ 1 ].    self success: (        (startIndex >= 1) and:        [(startIndex + count - 1) <= (self lengthOf: array)]).    successFlag ifTrue: [        arrayIndex _ array + BaseHeaderSize.        "Note: adjust startIndex for zero-origin indexing"        bytesRead _ self sqFile: file Read: (count * byteSize)                         Into: arrayIndex                           At: ((startIndex - 1) * byteSize).    ].    successFlag ifTrue: [        self pop: 5.  "pop rcvr, file, array, startIndex, count"        self pushInteger: bytesRead // byteSize.  "push # of elements read"    ].! !!Interpreter methodsFor: 'file primitives'!primitiveFileRename    | oldNamePointer newNamePointer oldNameIndex oldNameSize newNameIndex newNameSize |    newNamePointer _ self stackTop.    oldNamePointer _ self stackValue: 1.    self success: (self isBytes: newNamePointer).    self success: (self isBytes: oldNamePointer).    successFlag ifTrue: [        newNameIndex _ newNamePointer + BaseHeaderSize.        newNameSize _ self lengthOf: newNamePointer.        oldNameIndex _ oldNamePointer + BaseHeaderSize.        oldNameSize _ self lengthOf: oldNamePointer.    ].    successFlag ifTrue: [        self sqFileRenameOld: oldNameIndex Size: oldNameSize New: newNameIndex Size: newNameSize.    ].    successFlag ifTrue: [        self pop: 2.  "pop new and old names, leave rcvr on stack"    ].! !!Interpreter methodsFor: 'file primitives'!primitiveFileSetPosition    | newPosition file |    self var: 'file' declareC: 'SQFile *file'.    newPosition _ self stackIntegerValue: 0.    file _ self fileValueOf: (self stackValue: 1).    successFlag ifTrue: [ self sqFile: file SetPosition: newPosition ].    successFlag ifTrue: [ self pop: 2 "pop position, file; leave rcvr on stack" ].! !!Interpreter methodsFor: 'file primitives'!primitiveFileSize    | file size |    self var: 'file' declareC: 'SQFile *file'.    file _ self fileValueOf: (self stackTop).    successFlag ifTrue: [ size _ self sqFileSize: file ].    successFlag ifTrue: [        self pop: 2.  "rcvr, file"        self pushInteger: size.    ].! !!Interpreter methodsFor: 'file primitives'!primitiveFileWrite    | count startIndex array file byteSize arrayIndex bytesWritten |    self var: 'file' declareC: 'SQFile *file'.    count        _ self stackIntegerValue: 0.    startIndex    _ self stackIntegerValue: 1.    array        _ self stackValue: 2.    file            _ self fileValueOf: (self stackValue: 3).    "buffer can be any indexable words or bytes object except CompiledMethod"    self success: (self isWordsOrBytes: array).    (self isWords: array)        ifTrue: [ byteSize _ 4 ]        ifFalse: [ byteSize _ 1 ].    self success: (        (startIndex >= 1) and:        [(startIndex + count - 1) <= (self lengthOf: array)]).    successFlag ifTrue: [        arrayIndex _ array + BaseHeaderSize.        "Note: adjust startIndex for zero-origin indexing"        bytesWritten _            self sqFile: file                Write: (count * byteSize)                From: arrayIndex At: ((startIndex - 1) * byteSize).    ].    successFlag ifTrue: [        self pop: 5.  "pop rcvr, file, array, startIndex, count"        self pushInteger: bytesWritten // byteSize.  "push # of elements written"    ].! !!Interpreter methodsFor: 'memory space primitives'!primitiveBytesLeft    "Reports bytes available at this moment. For more meaningful results, calls to this primitive should be preceeded by a full or incremental garbage collection."    self pop: 1.    self pushInteger: (self sizeOfFree: freeBlock).! !!Interpreter methodsFor: 'memory space primitives'!primitiveFullGC    "Do a quick, incremental garbage collection and return the number of bytes available."    self pop: 1.    self incrementalGC.  "maximimize space for forwarding table"    self fullGC.    self pushInteger: (self sizeOfFree: freeBlock).! !!Interpreter methodsFor: 'memory space primitives'!primitiveIncrementalGC    "Do a quick, incremental garbage collection and return the number of bytes immediately available. (Note: more space may be made available by doing a full garbage collection."    self pop: 1.    self incrementalGC.    self pushInteger: (self sizeOfFree: freeBlock).! !!Interpreter methodsFor: 'memory space primitives'!primitiveLowSpaceSemaphore    "Register the low-space semaphore. If the argument is not a Semaphore, unregister the current low-space Semaphore."    | arg |    arg _ self popStack.    ((self fetchClassOf: arg) = (self splObj: ClassSemaphore)) ifTrue: [        self storePointer: TheLowSpaceSemaphore ofObject: specialObjectsOop withValue: arg.    ] ifFalse: [        self storePointer: TheLowSpaceSemaphore ofObject: specialObjectsOop withValue: nilObj.    ].! !!Interpreter methodsFor: 'memory space primitives'!primitiveSignalAtBytesLeft    "Set the low-water mark for free space. When the free space falls below this level, the new and new: primitives fail and system attempts to allocate space (e.g., to create a method context) cause the low-space semaphore (if one is registered) to be signalled."    | bytes |    bytes _ self popInteger.    successFlag        ifTrue: [ lowSpaceThreshold _ bytes ]        ifFalse: [            lowSpaceThreshold _ 0.            self unPop: 1.        ].! !!Interpreter methodsFor: 'socket primitives' stamp: 'jm 9/3/97 11:57'!primitiveInitializeNetwork    | resolverSemaIndex err |    resolverSemaIndex _ self stackIntegerValue: 0.    successFlag ifTrue: [        err _ self sqNetworkInit: resolverSemaIndex.        self success: err = 0.    ].    successFlag ifTrue: [        self pop: 1.  "pop resolverSemaIndex, leave rcvr on stack"    ].! !!Interpreter methodsFor: 'socket primitives'!primitiveSocketAbortConnection    | s |    self var: #s declareC: 'SocketPtr s'.    s _ self socketValueOf: self stackTop.    successFlag ifTrue: [        self sqSocketAbortConnection: s.    ].    successFlag ifTrue: [        self pop: 1.  "pop s; leave rcvr on stack"    ].! !!Interpreter methodsFor: 'socket primitives'!primitiveSocketCloseConnection    | s |    self var: #s declareC: 'SocketPtr s'.    s _ self socketValueOf: self stackTop.    successFlag ifTrue: [        self sqSocketCloseConnection: s.    ].    successFlag ifTrue: [        self pop: 1.  "pop s; leave rcvr on stack"    ].! !!Interpreter methodsFor: 'socket primitives'!primitiveSocketConnectionStatus    | s status |    self var: #s declareC: 'SocketPtr s'.    s _ self socketValueOf: self stackTop.    successFlag ifTrue: [        status _ self sqSocketConnectionStatus: s.    ].    successFlag ifTrue: [        self pop: 2 thenPush: (self integerObjectOf: status).    ].! !!Interpreter methodsFor: 'socket primitives' stamp: 'jm 9/3/97 11:57'!primitiveSocketConnectToPort    | port addr s |    self var: #s declareC: 'SocketPtr s'.    port _ self stackIntegerValue: 0.    addr _ self netAddressToInt: (self stackValue: 1).    s _ self socketValueOf: (self stackValue: 2).    successFlag ifTrue: [        self sqSocket: s ConnectTo: addr Port: port.    ].    successFlag ifTrue: [        self pop: 3.  "pop s, addr, port; leave rcvr on stack"    ].! !!Interpreter methodsFor: 'socket primitives' stamp: 'jm 9/3/97 11:58'!primitiveSocketCreate    | semaIndex sendBufSize recvBufSize socketType netType socketOop s |    self var: #s declareC: 'SocketPtr s'.    semaIndex    _ self stackIntegerValue: 0.    sendBufSize    _ self stackIntegerValue: 1.    recvBufSize    _ self stackIntegerValue: 2.    socketType    _ self stackIntegerValue: 3.    netType        _ self stackIntegerValue: 4.    successFlag ifTrue: [        socketOop _ self instantiateClass: (self splObj: ClassByteArray)                        indexableSize: self socketRecordSize.        s _ self socketValueOf: socketOop.        self sqSocket: s CreateNetType: netType SocketType: socketType            RecvBytes: recvBufSize SendBytes: sendBufSize SemaID: semaIndex.        successFlag ifTrue: [            self pop: 6  "netType, socketType, recvBufSize, sendBufSize, semaIndex, rcvr"                thenPush: socketOop.        ].    ].! !!Interpreter methodsFor: 'socket primitives'!primitiveSocketDestroy    | s |    self var: #s declareC: 'SocketPtr s'.    s _ self socketValueOf: self stackTop.    successFlag ifTrue: [        self sqSocketDestroy: s.    ].    successFlag ifTrue: [        self pop: 1.  "pop s; leave rcvr on stack"    ].! !!Interpreter methodsFor: 'socket primitives'!primitiveSocketError    | s err |    self var: #s declareC: 'SocketPtr s'.    s _ self socketValueOf: self stackTop.    successFlag ifTrue: [        err _ self sqSocketError: s.    ].    successFlag ifTrue: [        self pop: 2 thenPush: (self integerObjectOf: err).    ].! !!Interpreter methodsFor: 'socket primitives' stamp: 'jm 9/3/97 11:58'!primitiveSocketListenOnPort    | port s |    self var: #s declareC: 'SocketPtr s'.    port _ self stackIntegerValue: 0.    s _ self socketValueOf: (self stackValue: 1).    successFlag ifTrue: [        self sqSocket: s ListenOnPort: port.    ].    successFlag ifTrue: [        self pop: 2.  "pop s, port; leave rcvr on stack"    ].! !!Interpreter methodsFor: 'socket primitives'!primitiveSocketLocalAddress    | s addr |    self var: #s declareC: 'SocketPtr s'.    s _ self socketValueOf: self stackTop.    successFlag ifTrue: [        addr _ self sqSocketLocalAddress: s.    ].    successFlag ifTrue: [        self pop: 2 thenPush: (self intToNetAddress: addr).    ].! !!Interpreter methodsFor: 'socket primitives'!primitiveSocketLocalPort    | s port |    self var: #s declareC: 'SocketPtr s'.    s _ self socketValueOf: self stackTop.    successFlag ifTrue: [        port _ self sqSocketLocalPort: s.    ].    successFlag ifTrue: [        self pop: 2 thenPush: (self integerObjectOf: port).    ].! !!Interpreter methodsFor: 'socket primitives'!primitiveSocketReceiveDataAvailable    | s dataIsAvailable |    self var: #s declareC: 'SocketPtr s'.    s _ self socketValueOf: self stackTop.    successFlag ifTrue: [        dataIsAvailable _ self sqSocketReceiveDataAvailable: s.    ].    successFlag ifTrue: [        self pop: 2.  "pop s, rcvr"        self pushBool: dataIsAvailable.    ].! !!Interpreter methodsFor: 'socket primitives'!primitiveSocketReceiveDataBufCount    | count startIndex array s byteSize arrayBase bufStart bytesReceived |    self var: #s declareC: 'SocketPtr s'.    count        _ self stackIntegerValue: 0.    startIndex    _ self stackIntegerValue: 1.    array        _ self stackValue: 2.    s            _ self socketValueOf: (self stackValue: 3).    "buffer can be any indexable words or bytes object except CompiledMethod"    self success: (self isWordsOrBytes: array).    (self isWords: array)        ifTrue: [byteSize _ 4]        ifFalse: [byteSize _ 1].    self success: (        (startIndex >= 1) and:        [(count >= 0) and:        [(startIndex + count - 1) <= (self lengthOf: array)]]).    successFlag ifTrue: [        "Note: adjust bufStart for zero-origin indexing"        arrayBase _ array + BaseHeaderSize.        bufStart _ arrayBase + ((startIndex - 1) * byteSize).        bytesReceived _            self sqSocket: s                ReceiveDataBuf: bufStart                Count: (count * byteSize).    ].    successFlag ifTrue: [        self pop: 5.  "pop rcvr, s, array, startIndex, count"        self pushInteger: bytesReceived // byteSize.  "push # of elements"    ].! !!Interpreter methodsFor: 'socket primitives'!primitiveSocketRemoteAddress    | s addr |    self var: #s declareC: 'SocketPtr s'.    s _ self socketValueOf: self stackTop.    successFlag ifTrue: [        addr _ self sqSocketRemoteAddress: s.    ].    successFlag ifTrue: [        self pop: 2 thenPush: (self intToNetAddress: addr).    ].! !!Interpreter methodsFor: 'socket primitives'!primitiveSocketRemotePort    | s port |    self var: #s declareC: 'SocketPtr s'.    s _ self socketValueOf: self stackTop.    successFlag ifTrue: [        port _ self sqSocketRemotePort: s.    ].    successFlag ifTrue: [        self pop: 2 thenPush: (self integerObjectOf: port).    ].! !!Interpreter methodsFor: 'socket primitives'!primitiveSocketSendDataBufCount    | count startIndex array s byteSize arrayBase bufStart bytesSent |    self var: #s declareC: 'SocketPtr s'.    count        _ self stackIntegerValue: 0.    startIndex    _ self stackIntegerValue: 1.    array        _ self stackValue: 2.    s            _ self socketValueOf: (self stackValue: 3).    "buffer can be any indexable words or bytes object except CompiledMethod"    self success: (self isWordsOrBytes: array).    (self isWords: array)        ifTrue: [byteSize _ 4]        ifFalse: [byteSize _ 1].    self success: (        (startIndex >= 1) and:        [(count >= 0) and:        [(startIndex + count - 1) <= (self lengthOf: array)]]).    successFlag ifTrue: [        "Note: adjust bufStart for zero-origin indexing"        arrayBase _ array + BaseHeaderSize.        bufStart _ arrayBase + ((startIndex - 1) * byteSize).        bytesSent _            self sqSocket: s                SendDataBuf: bufStart                Count: (count * byteSize).    ].    successFlag ifTrue: [        self pop: 5.  "pop rcvr, s, array, startIndex, count"        self pushInteger: bytesSent // byteSize.  "push # of elements"    ].! !!Interpreter methodsFor: 'socket primitives'!primitiveSocketSendDone    | s done |    self var: #s declareC: 'SocketPtr s'.    s _ self socketValueOf: self stackTop.    successFlag ifTrue: [        done _ self sqSocketSendDone: s.    ].    successFlag ifTrue: [        self pop: 2.  "pop s, rcvr"        self pushBool: done.    ].! !!Interpreter methodsFor: 'socket primitives'!socketRecordSize    "Return the size of a Smalltalk socket record in bytes."    ^ self cCode: 'sizeof(SQSocket)'.! !!Interpreter methodsFor: 'socket primitives'!socketValueOf: socketOop    "Return a pointer to the first byte of of the socket record within the given Smalltalk object, or nil if socketOop is not a socket record."    | socketIndex |    self returnTypeC: 'SQSocket *'.    self success:        ((self isBytes: socketOop) and:         [(self lengthOf: socketOop) = self socketRecordSize]).    successFlag ifTrue: [        socketIndex _ socketOop + BaseHeaderSize.        ^ self cCode: '(SQSocket *) socketIndex'    ] ifFalse:  [        ^ nil    ].! !!Interpreter methodsFor: 'resolver primitives'!intToNetAddress: addr    "Convert the given 32-bit integer into an internet network address represented as a four-byte ByteArray."    | netAddressOop |    netAddressOop _        self instantiateSmallClass: (self splObj: ClassByteArray)            sizeInBytes: 8            fill: 0.    self storeByte: 0 ofObject: netAddressOop        withValue: ((addr >> 24) bitAnd: 16rFF).    self storeByte: 1 ofObject: netAddressOop        withValue: ((addr >> 16) bitAnd: 16rFF).    self storeByte: 2 ofObject: netAddressOop        withValue: ((addr >> 8) bitAnd: 16rFF).    self storeByte: 3 ofObject: netAddressOop        withValue: (addr bitAnd: 16rFF).    ^ netAddressOop! !!Interpreter methodsFor: 'resolver primitives'!netAddressToInt: oop    "Convert the given internet network address (represented as a four-byte ByteArray) into a 32-bit integer. Fail if the given oop is not a four-byte ByteArray."    | sz |    self assertClassOf: oop is: (self splObj: ClassByteArray).    successFlag ifTrue: [        sz _ self lengthOf: oop.        sz = 4 ifFalse: [^ self primitiveFail]].    successFlag ifTrue: [        ^ (self fetchByte: 3 ofObject: oop) +          ((self fetchByte: 2 ofObject: oop) << 8) +          ((self fetchByte: 1 ofObject: oop) << 16) +          ((self fetchByte: 0 ofObject: oop) << 24) ].! !!Interpreter methodsFor: 'resolver primitives'!primitiveResolverAbortLookup    self sqResolverAbort.! !!Interpreter methodsFor: 'resolver primitives'!primitiveResolverAddressLookupResult    | sz s |    sz _ self sqResolverAddrLookupResultSize.    successFlag ifTrue: [        s _ self instantiateClass: (self splObj: ClassString) indexableSize: sz.        self sqResolverAddrLookup: (self cCoerce: (s + BaseHeaderSize) to: 'char *')            Result: sz.    ].    successFlag ifTrue: [        self pop: 1 thenPush: s.    ].! !!Interpreter methodsFor: 'resolver primitives'!primitiveResolverError    | err |    err _ self sqResolverError.    successFlag ifTrue: [        self pop: 1 thenPush: (self integerObjectOf: err).    ].! !!Interpreter methodsFor: 'resolver primitives'!primitiveResolverLocalAddress    | addr |    addr _ self sqResolverLocalAddress.    successFlag ifTrue: [        self pop: 1 thenPush: (self intToNetAddress: addr).    ].! !!Interpreter methodsFor: 'resolver primitives'!primitiveResolverNameLookupResult    | addr |    addr _ self sqResolverNameLookupResult.    successFlag ifTrue: [        self pop: 1 thenPush: (self intToNetAddress: addr).    ].! !!Interpreter methodsFor: 'resolver primitives'!primitiveResolverStartAddressLookup    | addr |    addr _ self netAddressToInt: self stackTop.    successFlag ifTrue: [        self sqResolverStartAddrLookup: addr.    ].    successFlag ifTrue: [        self pop: 1.  "pop addr, leave rcvr on stack"    ].! !!Interpreter methodsFor: 'resolver primitives'!primitiveResolverStartNameLookup    | name sz |    name _ self stackTop.    self assertClassOf: name is: (self splObj: ClassString).    successFlag ifTrue: [        sz _ self lengthOf: name.        self sqResolverStartName: (self cCoerce: (name + BaseHeaderSize) to: 'char *')            Lookup: sz.    ].    successFlag ifTrue: [        self pop: 1.  "pop name, leave rcvr on stack"    ].! !!Interpreter methodsFor: 'resolver primitives'!primitiveResolverStatus    | status |    status _ self sqResolverStatus.    successFlag ifTrue: [        self pop: 1 thenPush: (self integerObjectOf: status).    ].! !!Interpreter methodsFor: 'sound primitives' stamp: '6/7/97 09:59 di'!primitiveConstantFill    "Fill the receiver, which must be an indexable bytes or words objects, with the given integer value."    | fillValue rcvr rcvrIsBytes end i |    fillValue _ self positive32BitValueOf: self stackTop.     rcvr _ self stackValue: 1.    self success: (self isWordsOrBytes: rcvr).    rcvrIsBytes _ self isBytes: rcvr.    rcvrIsBytes ifTrue: [        self success: ((fillValue >= 0) and: [fillValue <= 255]).    ].    successFlag ifTrue: [        end _ rcvr + (self sizeBitsOf: rcvr).        i _ rcvr + BaseHeaderSize.        rcvrIsBytes ifTrue: [            [i < end] whileTrue: [                self byteAt: i put: fillValue.                i _ i + 1.            ].        ] ifFalse: [            [i < end] whileTrue: [                self longAt: i put: fillValue.                i _ i + 4.            ].        ].        self pop: 1.  "pop fillValue; leave rcvr on stack"    ].! !!Interpreter methodsFor: 'sound primitives'!primitiveShortAt    "Treat the receiver, which can be indexible by either bytes or words, as an array of signed 16-bit values. Return the contents of the given index. Note that the index specifies the i-th 16-bit entry, not the i-th byte or word."    | index rcvr sz addr value |    index _ self stackIntegerValue: 0.    rcvr _ self stackValue: 1.    self success: ((self isIntegerObject: rcvr) not and: [self isWordsOrBytes: rcvr]).    successFlag ifFalse: [ ^ nil ].    sz _ ((self sizeBitsOf: rcvr) - BaseHeaderSize) // 2.  "number of 16-bit fields"    self success: ((index >= 1) and: [index <= sz]).    successFlag ifTrue: [        addr _ rcvr + BaseHeaderSize + (2 * (index - 1)).        value _ self cCode: '*((short int *) addr)'.        self pop: 2.  "pop rcvr, index"        self pushInteger: value.  "push element value"    ].! !!Interpreter methodsFor: 'sound primitives'!primitiveShortAtPut    "Treat the receiver, which can be indexible by either bytes or words, as an array of signed 16-bit values. Set the contents of the given index to the given value. Note that the index specifies the i-th 16-bit entry, not the i-th byte or word."    | index rcvr sz addr value |    value _ self stackIntegerValue: 0.    index _ self stackIntegerValue: 1.    rcvr _ self stackValue: 2.    self success: ((self isIntegerObject: rcvr) not and: [self isWordsOrBytes: rcvr]).    successFlag ifFalse: [ ^ nil ].    sz _ ((self sizeBitsOf: rcvr) - BaseHeaderSize) // 2.  "number of 16-bit fields"    self success: ((index >= 1) and: [index <= sz]).    self success: ((value >= -32768) and: [value <= 32767]).    successFlag ifTrue: [        addr _ rcvr + BaseHeaderSize + (2 * (index - 1)).        self cCode: '*((short int *) addr) = value'.        self pop: 2.  "pop index and value; leave rcvr on stack"    ].! !!Interpreter methodsFor: 'sound primitives'!primitiveSoundAvailableSpace    "Returns the number of sample frames of available sound output buffer space."    | frames |    frames _ self cCode: 'snd_AvailableSpace()'.  "-1 if sound output not started"    self success: frames >= 0.    successFlag ifTrue: [        self pop: 1.  "rcvr"        self push: (self positive32BitIntegerFor: frames).    ].! !!Interpreter methodsFor: 'sound primitives' stamp: 'jm 8/22/97 16:27'!primitiveSoundGetRecordingSampleRate    "Return a float representing the actual sampling rate during recording. Fail if not currently recording."    | rate |    self var: #rate declareC: 'double rate'.    rate _ self cCode: 'snd_GetRecordingSampleRate()'.  "fail if not recording"    successFlag ifTrue: [        self pop: 1.  "rcvr"        self pushFloat: rate.    ].! !!Interpreter methodsFor: 'sound primitives' stamp: 'jm 9/10/97 08:15'!primitiveSoundInsertSamples    "Insert a buffer's worth of sound samples into the currently playing buffer. Used to make a sound start playing as quickly as possible. The new sound is mixed with the previously buffered sampled."    "Details: Unlike primitiveSoundPlaySamples, this primitive always starts with the first sample the given sample buffer. Its third argument specifies the number of samples past the estimated sound output buffer position the inserted sound should start. If successful, it returns the number of samples inserted."    | leadTime buf frameCount framesPlayed |    leadTime _ self stackIntegerValue: 0.    buf _ self stackValue: 1.    frameCount _ self stackIntegerValue: 2.    self success: (self isWords: buf).    self success: (frameCount <= (self lengthOf: buf)).    successFlag ifTrue: [        framesPlayed _            self cCode: 'snd_InsertSamplesFromLeadTime(frameCount, buf + 4, leadTime)'.        self success: framesPlayed >= 0].    successFlag ifTrue: [        self pop: 4.  "pop frameCount, buf, leadTime, rcvr"        self push: (self positive32BitIntegerFor: framesPlayed)].! !!Interpreter methodsFor: 'sound primitives'!primitiveSoundPlaySamples    "Output a buffer's worth of sound samples."    | startIndex buf frameCount framesPlayed |    startIndex _ self stackIntegerValue: 0.    buf _ self stackValue: 1.    frameCount _ self stackIntegerValue: 2.    self success: (self isWords: buf).    self success: (        (startIndex >= 1) and:        [(startIndex + frameCount - 1) <= (self lengthOf: buf)]).    successFlag ifTrue: [        framesPlayed _            self cCode: 'snd_PlaySamplesFromAtLength(frameCount, buf + 4, startIndex - 1)'.        self success: framesPlayed >= 0.    ].    successFlag ifTrue: [        self pop: 4.  "pop frameCount, buf, startIndex, rcvr"        self push: (self positive32BitIntegerFor: framesPlayed).    ].! !!Interpreter methodsFor: 'sound primitives'!primitiveSoundPlaySilence    "Output a buffer's worth of silence. Returns the number of sample frames played."    | framesPlayed |    framesPlayed _ self cCode: 'snd_PlaySilence()'.  "-1 if sound output not started"    self success: framesPlayed >= 0.    successFlag ifTrue: [        self pop: 1.  "rcvr"        self push: (self positive32BitIntegerFor: framesPlayed).    ].! !!Interpreter methodsFor: 'sound primitives' stamp: 'jm 8/22/97 21:59'!primitiveSoundRecordSamples    "Record a buffer's worth of 16-bit sound samples."    | startWordIndex buf bufSizeInBytes samplesRecorded |    startWordIndex _ self stackIntegerValue: 0.    buf _ self stackValue: 1.    self success: (self isWords: buf).    successFlag ifTrue: [        bufSizeInBytes _ (self lengthOf: buf) * 4.        self success: ((startWordIndex >= 1) and: [((startWordIndex - 1) * 2) < bufSizeInBytes]).    ].    successFlag ifTrue: [        samplesRecorded _            self cCode: 'snd_RecordSamplesIntoAtLength(buf + 4, startWordIndex - 1, bufSizeInBytes)'.    ].    successFlag ifTrue: [        self pop: 3.  "pop rcvr, startWordIndex, buf"        self push: (self integerObjectOf: samplesRecorded).    ].! !!Interpreter methodsFor: 'sound primitives' stamp: 'jm 9/18/97 13:15'!primitiveSoundSetRecordLevel    "Set the sound input recording level."    | level |    level _ self stackIntegerValue: 0.    successFlag ifTrue: [        self cCode: 'snd_SetRecordLevel(level)'.    ].    successFlag ifTrue: [        self pop: 1.  "pop level; leave rcvr on stack"    ].! !!Interpreter methodsFor: 'sound primitives' stamp: 'jm 8/23/97 20:18'!primitiveSoundStart    "Start the double-buffered sound output with the given buffer size, sample rate, and stereo flag."    | stereoFlag samplesPerSec bufFrames |    stereoFlag        _ self booleanValueOf: (self stackValue: 0).    samplesPerSec    _ self stackIntegerValue: 1.    bufFrames        _ self stackIntegerValue: 2.    successFlag ifTrue: [        self success: (self cCode: 'snd_Start(bufFrames, samplesPerSec, stereoFlag, 0)').    ].    successFlag ifTrue: [        self pop: 3.  "pop bufFrames, samplesPerSec, stereoFlag; leave rcvr on stack"    ].! !!Interpreter methodsFor: 'sound primitives' stamp: 'jm 9/18/97 13:15'!primitiveSoundStartRecording    "Start recording sound with the given parameters."    | semaIndex stereoFlag desiredSamplesPerSec |    semaIndex                _ self stackIntegerValue: 0.    stereoFlag                _ self booleanValueOf: (self stackValue: 1).    desiredSamplesPerSec    _ self stackIntegerValue: 2.    successFlag ifTrue: [        self cCode: 'snd_StartRecording(desiredSamplesPerSec, stereoFlag, semaIndex)'.    ].    successFlag ifTrue: [        self pop: 3.  "pop desiredSamplesPerSec, stereoFlag, and semaIndex; leave rcvr on stack"    ].! !!Interpreter methodsFor: 'sound primitives' stamp: 'jm 8/23/97 20:17'!primitiveSoundStartWithSemaphore    "Start the double-buffered sound output with the given buffer size, sample rate, stereo flag, and semaphore index."    | semaIndex stereoFlag samplesPerSec bufFrames |    semaIndex        _ self stackIntegerValue: 0.    stereoFlag        _ self booleanValueOf: (self stackValue: 1).    samplesPerSec    _ self stackIntegerValue: 2.    bufFrames        _ self stackIntegerValue: 3.    successFlag ifTrue: [        self success: (self cCode: 'snd_Start(bufFrames, samplesPerSec, stereoFlag, semaIndex)').    ].    successFlag ifTrue: [        self pop: 4.  "pop bufFrames, samplesPerSec, stereoFlag, semaIndex; leave rcvr on stack"    ].! !!Interpreter methodsFor: 'sound primitives'!primitiveSoundStop    "Stop double-buffered sound output."    self cCode: 'snd_Stop()'.  "leave rcvr on stack"    ! !!Interpreter methodsFor: 'sound primitives' stamp: 'jm 8/22/97 16:22'!primitiveSoundStopRecording    "Stop recording sound."    self cCode: 'snd_StopRecording()'.  "leave rcvr on stack"! !!Interpreter methodsFor: 'other primitives'!primitiveClipboardText    "When called with a single string argument, post the string to the clipboard. When called with zero arguments, return a string containing the current clipboard contents."    | s sz |    argumentCount = 1 ifTrue: [        s _ self stackTop.        self assertClassOf: s is: (self splObj: ClassString).        successFlag ifTrue: [            sz _ self stSizeOf: s.            self clipboardWrite: sz From: (s + BaseHeaderSize) At: 0.            self pop: 1.  "pop s, leave rcvr on stack"        ].    ] ifFalse: [        sz _ self clipboardSize.        s _ self instantiateClass: (self splObj: ClassString)                      indexableSize: sz.        self clipboardRead: sz Into: (s + BaseHeaderSize) At: 0.        self pop: 1.  "rcvr"        self push: s.    ].! !!Interpreter methodsFor: 'other primitives'!primitiveExitToDebugger    self error: 'Exit to debugger at user request'.! !!Interpreter methodsFor: 'other primitives'!primitiveFlushCache    "Clear the method lookup cache. This must be done after every programming change."    self flushMethodCache.! !!Interpreter methodsFor: 'other primitives' stamp: 'jm 9/3/97 11:54'!primitiveGetAttribute    "Fetch the system attribute with the given integer ID. The result is a string, which will be empty if the attribute is not defined."    | attr sz s |    attr _ self stackIntegerValue: 0.    successFlag ifTrue: [        sz _ self attributeSize: attr.        s _ self instantiateClass: (self splObj: ClassString) indexableSize: sz.        self getAttribute: attr Into: (s + BaseHeaderSize) Length: sz.        self pop: 2.  "rcvr, attr"        self push: s].! !!Interpreter methodsFor: 'other primitives'!primitiveImageName    "When called with a single string argument, record the string as the current image file name. When called with zero arguments, return a string containing the current image file name."    | s sz |    argumentCount = 1 ifTrue: [        s _ self stackTop.        self assertClassOf: s is: (self splObj: ClassString).        successFlag ifTrue: [            sz _ self stSizeOf: s.            self imageNamePut: (s + BaseHeaderSize) Length: sz.            self pop: 1.  "pop s, leave rcvr on stack"        ].    ] ifFalse: [        sz _ self imageNameSize.        s _ self instantiateClass: (self splObj: ClassString) indexableSize: sz.        self imageNameGet: (s + BaseHeaderSize) Length: sz.        self pop: 1.  "rcvr"        self push: s.    ].! !!Interpreter methodsFor: 'other primitives' stamp: 'jm 9/14/97 10:53'!primitiveMillisecondClock    "Return the value of the millisecond clock as an integer. Note that the millisecond clock wraps around periodically. On some platforms it can wrap daily. The range is limited to SmallInteger maxVal / 2 to allow delays of up to that length without overflowing a SmallInteger."    self pop: 1.  "pop rcvr"    self push: (self integerObjectOf: (self ioMSecs bitAnd: 16r1FFFFFFF)).! !!Interpreter methodsFor: 'other primitives'!primitiveNoop    "A placeholder for primitives that haven't been implemented or are being withdrawn gradually. Just absorbs any arguments and returns the receiver."    self pop: argumentCount.  "pop args, leave rcvr on stack"! !!Interpreter methodsFor: 'other primitives'!primitiveQuit    self ioExit.! !!Interpreter methodsFor: 'other primitives'!primitiveReadJoystick    "Read an input word from the joystick with the given index."    | index |    index _ self stackIntegerValue: 0.    successFlag ifTrue: [        self pop: 2.  "index, rcvr"        self push: (self positive32BitIntegerFor: (self joystickRead: index)).    ].! !!Interpreter methodsFor: 'other primitives' stamp: 'jm 9/3/97 11:57'!primitiveRelinquishProcessor    "Relinquish the processor for up to the given number of microseconds. The exact behavior of this primitive is platform dependent."    | microSecs |    microSecs _ self stackIntegerValue: 0.    successFlag ifTrue: [        self ioRelinquishProcessorForMicroseconds: microSecs.        self pop: 1].  "microSecs; leave rcvr on stack"! !!Interpreter methodsFor: 'other primitives'!primitiveSecondsClock    "Return the number of seconds since January 1, 1901 as an integer."    self pop: 1.  "pop rcvr"    self push: (self positive32BitIntegerFor: self ioSeconds).! !!Interpreter methodsFor: 'other primitives'!primitiveSignalAtMilliseconds    "Cause the time semaphore, if one has been registered, to be signalled when the millisecond clock is greater than or equal to the given tick value. A tick value of zero turns off timer interrupts."    | tick sema |    tick _ self popInteger.    sema _ self popStack.    successFlag ifTrue: [        (self fetchClassOf: sema) = (self splObj: ClassSemaphore) ifTrue: [            self storePointer: TheTimerSemaphore ofObject: specialObjectsOop withValue: sema.            nextWakeupTick _ tick.        ] ifFalse: [            self storePointer: TheTimerSemaphore ofObject: specialObjectsOop withValue: nilObj.            nextWakeupTick _ 0.        ].    ] ifFalse: [        self unPop: 2.  "sema, tick"    ].! !!Interpreter methodsFor: 'other primitives'!primitiveSnapshot    | activeProc dataSize rcvr |    "save the state of the current process and save it on the scheduler queue"    self storeContextRegisters: activeContext.    activeProc _        self fetchPointer: ActiveProcessIndex ofObject: self schedulerPointer.    self storePointer: SuspendedContextIndex            ofObject: activeProc          withValue: activeContext.    "compact memory and compute the size of the memory actually in use"    self incrementalGC.  "maximimize space for forwarding table"    self fullGC.    dataSize _ freeBlock - (self startOfMemory).    "Assume: all objects are below the start of the free block"    successFlag ifTrue: [        rcvr _ self popStack.  "pop rcvr"        self push: trueObj.        self writeImageFile: dataSize.        self pop: 1.  "pop true"    ].    successFlag        ifTrue: [ self push: falseObj ]        ifFalse: [ self push: rcvr ].! !!Interpreter methodsFor: 'other primitives'!primitiveSpecialObjectsOop    "Return the oop of the SpecialObjectsArray."    self pop: 1.    self push: specialObjectsOop.! !!Interpreter methodsFor: 'other primitives' stamp: 'jm 9/14/97 12:53'!primitiveVMParameter    "Behaviour depends on argument count:        0 args:    return an Array of VM parameter values;        1 arg:    return the indicated VM parameter;        2 args:    set the VM indicated parameter.    VM parameters are numbered as follows:        1    end of old-space (0-based, read-only)        2    end of young-space (read-only)        3    end of memory (read-only)        4    allocationCount (read-only)        5    allocations between GCs (read-write, but read-only for now)        6    survivor count tenuring threshold (read-write, but read-only for now)        7    full GCs since startup (read-only)        8    total milliseconds in full GCs since startup (read-only)        9    incremental GCs since startup (read-only)        10    total milliseconds in incremental GCs since startup (read-only)        11    tenures of surving objects since startup (read-only)"    "Note: Thanks to Ian Piumarta for this primitive."    | result mem |    mem _ self cCoerce: memory to: 'int'.    argumentCount = 0 ifTrue: [        result _ self instantiateClass: (self splObj: ClassArray) indexableSize: 11.        self stObject: result at: 1 put: (self integerObjectOf: youngStart - mem).        self stObject: result at: 2 put: (self integerObjectOf: freeBlock - mem).        self stObject: result at: 3 put: (self integerObjectOf: endOfMemory - mem).        self stObject: result at: 4 put: (self integerObjectOf: allocationCount).        self stObject: result at: 5 put: (self integerObjectOf: allocationsBetweenGCs).        self stObject: result at: 6 put: (self integerObjectOf: tenuringThreshold).        self stObject: result at: 7 put: (self integerObjectOf: statFullGCs).        self stObject: result at: 8 put: (self integerObjectOf: statFullGCMSecs).        self stObject: result at: 9 put: (self integerObjectOf: statIncrGCs).        self stObject: result at: 10 put: (self integerObjectOf: statIncrGCMSecs).        self stObject: result at: 11 put: (self integerObjectOf: statTenures).        self pop: 1 thenPush: result.        ^ nil].    self primitiveFail.! !!Interpreter methodsFor: 'other primitives'!primitiveVMPath    "Return a string containing the path name of VM's directory."    | s sz |    sz _ self vmPathSize.    s _ self instantiateClass: (self splObj: ClassString) indexableSize: sz.    self vmPathGet: (s + BaseHeaderSize) Length: sz.    self pop: 1.  "rcvr"    self push: s.! !!Interpreter methodsFor: 'debug printing'!cr    "For testing in Smalltalk, this method should be overridden in a subclass."    self printf: '\n'.! !!Interpreter methodsFor: 'debug printing'!print: s    "For testing in Smalltalk, this method should be overridden in a subclass."    self var: #s declareC: 'char *s'.    self cCode: 'printf("%s", s)'.! !!Interpreter methodsFor: 'debug printing'!printChar: aByte    "For testing in Smalltalk, this method should be overridden in a subclass."    self putchar: aByte.! !!Interpreter methodsFor: 'debug printing'!printNum: n    "For testing in Smalltalk, this method should be overridden in a subclass."    self cCode: 'printf("%ld", (long) n)'.! !!Interpreter methodsFor: 'debug support'!allAccessibleObjectsOkay    "Ensure that all accessible objects in the heap are okay."    | oop |    oop _ self firstAccessibleObject.    [oop = nil] whileFalse: [        self okayFields: oop.        oop _ self accessibleObjectAfter: oop.    ].! !!Interpreter methodsFor: 'debug support'!findClassOfMethod: meth forReceiver: rcvr    | currClass classDict classDictSize methodArray i done |    currClass _ self fetchClassOf: rcvr.    done _ false.    [done] whileFalse: [        classDict _ self fetchPointer: MessageDictionaryIndex ofObject: currClass.        classDictSize _ self fetchWordLengthOf: classDict.        methodArray _ self fetchPointer: MethodArrayIndex ofObject: classDict.        i _ 0.        [i < (classDictSize - SelectorStart)] whileTrue: [            meth = (self fetchPointer: i ofObject: methodArray) ifTrue: [ ^currClass ].            i _ i + 1.        ].        currClass _ self fetchPointer: SuperclassIndex ofObject: currClass.        done _ currClass = nilObj.    ].    ^self fetchClassOf: rcvr    "method not found in superclass chain"! !!Interpreter methodsFor: 'debug support'!findSelectorOfMethod: meth forReceiver: rcvr    | currClass done classDict classDictSize methodArray i |    currClass _ self fetchClassOf: rcvr.    done _ false.    [done] whileFalse: [        classDict _ self fetchPointer: MessageDictionaryIndex ofObject: currClass.        classDictSize _ self fetchWordLengthOf: classDict.        methodArray _ self fetchPointer: MethodArrayIndex ofObject: classDict.        i _ 0.        [i <= (classDictSize - SelectorStart)] whileTrue: [            meth = (self fetchPointer: i ofObject: methodArray) ifTrue: [                ^(self fetchPointer: i + SelectorStart ofObject: classDict)            ].            i _ i + 1.        ].        currClass _ self fetchPointer: SuperclassIndex ofObject: currClass.        done _ currClass = nilObj.    ].    ^self splObj: SelectorDoesNotUnderstand    "method not found in superclass chain"! !!Interpreter methodsFor: 'debug support'!okayActiveProcessStack    | cntxt |    cntxt _ activeContext.        [cntxt = nilObj] whileFalse: [        self okayFields: cntxt.        cntxt _ (self fetchPointer: SenderIndex ofObject: cntxt).    ].! !!Interpreter methodsFor: 'debug support'!okayFields: oop    "If this is a pointers object, check that its fields are all okay oops."    | i fieldOop |    (oop = nil or: [oop = 0]) ifTrue: [ ^true ].    (self isIntegerObject: oop) ifTrue: [ ^true ].    self okayOop: oop.    self oopHasOkayClass: oop.    (self isPointers: oop) ifFalse: [ ^true ].    i _ (self lengthOf: oop) - 1.    [i >= 0] whileTrue: [        fieldOop _ self fetchPointer: i ofObject: oop.        (self isIntegerObject: fieldOop) ifFalse: [            self okayOop: fieldOop.            self oopHasOkayClass: fieldOop.        ].        i _ i - 1.    ].! !!Interpreter methodsFor: 'debug support'!okayInterpreterObjects    | oopOrZero oop |    self okayFields: nilObj.    self okayFields: falseObj.    self okayFields: trueObj.    self okayFields: specialObjectsOop.    self okayFields: activeContext.    self okayFields: method.    self okayFields: receiver.    self okayFields: theHomeContext.    self okayFields: messageSelector.    self okayFields: newMethod.    1 to: MethodCacheEntries do: [ :i |        oopOrZero _ methodCache at: i.        oopOrZero = 0 ifFalse: [            self okayFields: (methodCache at: i).                            "selector"            self okayFields: (methodCache at: i + MethodCacheEntries).        "class"            self okayFields: (methodCache at: i + (2 * MethodCacheEntries)).    "method"        ].    ].    1 to: remapBufferCount do: [ :i |        oop _ remapBuffer at: i.        (self isIntegerObject: oop) ifFalse: [            self okayFields: oop.        ].    ].    self okayActiveProcessStack.! !!Interpreter methodsFor: 'debug support'!okayOop: oop    "Verify that the given oop is legitimate. Check address, header, and size but not class."    | sz type fmt |    "address and size checks"    (self isIntegerObject: oop) ifTrue: [ ^true ].    ((0 < oop) & (oop < endOfMemory))        ifFalse: [ self error: 'oop is not a valid address' ].    ((oop \\ 4) = 0)        ifFalse: [ self error: 'oop is not a word-aligned address' ].    sz _ self sizeBitsOf: oop.    (oop + sz) < endOfMemory        ifFalse: [ self error: 'oop size would make it extend beyond the end of memory' ].    "header type checks"    type _ self headerType: oop.    type = HeaderTypeFree        ifTrue:  [ self error: 'oop is a free chunk, not an object' ].    type = HeaderTypeShort ifTrue: [        (((self baseHeader: oop) >> 12) bitAnd: 16r1F) = 0            ifTrue:  [ self error: 'cannot have zero compact class field in a short header' ].    ].    type = HeaderTypeClass ifTrue: [        ((oop >= 4) and: [(self headerType: oop - 4) = type])            ifFalse: [ self error: 'class header word has wrong type' ].    ].    type = HeaderTypeSizeAndClass ifTrue: [        ((oop >= 8) and:         [(self headerType: oop - 8) = type and:         [(self headerType: oop - 4) = type]])            ifFalse: [ self error: 'class header word has wrong type' ].    ].    "format check"    fmt _ self formatOf: oop.    ((fmt = 4) | (fmt = 5) | (fmt = 7))        ifTrue:  [ self error: 'oop has an unknown format type' ].    "mark and root bit checks"    ((self longAt: oop) bitAnd: 16r20000000) = 0        ifFalse: [ self error: 'unused header bit 30 is set; should be zero' ]."xxx    ((self longAt: oop) bitAnd: MarkBit) = 0        ifFalse: [ self error: 'mark bit should not be set except during GC' ].xxx"    (((self longAt: oop) bitAnd: RootBit) = 1 and:     [oop >= youngStart])        ifTrue: [ self error: 'root bit is set in a young object' ].    ^true! !!Interpreter methodsFor: 'debug support'!oopHasOkayClass: oop    "Attempt to verify that the given oop has a reasonable behavior. The class must be a valid, non-integer oop and must not be nilObj. It must be a pointers object with three or more fields. Finally, the instance specification field of the behavior must match that of the instance."    | oopClass formatMask behaviorFormatBits oopFormatBits |    self okayOop: oop.    oopClass _ self fetchClassOf: oop.    (self isIntegerObject: oopClass)        ifTrue: [ self error: 'a SmallInteger is not a valid class or behavior' ].    self okayOop: oopClass.    ((self isPointers: oopClass) and: [(self lengthOf: oopClass) >= 3])        ifFalse: [ self error: 'a class (behavior) must be a pointers object of size >= 3' ].    (self isBytes: oop)        ifTrue: [ formatMask _ 16rC00 ]  "ignore extra bytes size bits"        ifFalse: [ formatMask _ 16rF00 ].    behaviorFormatBits _ (self formatOfClass: oopClass) bitAnd: formatMask.    oopFormatBits _ (self baseHeader: oop) bitAnd: formatMask.    behaviorFormatBits = oopFormatBits        ifFalse: [ self error: 'object and its class (behavior) formats differ' ].    ^true! !!Interpreter methodsFor: 'debug support'!printCallStack    | ctxt home methodClass methodSel |    ctxt _ activeContext.    [ctxt = nilObj] whileFalse: [        (self fetchClassOf: ctxt) = (self splObj: ClassBlockContext)            ifTrue: [ home _ self fetchPointer: HomeIndex ofObject: ctxt ]            ifFalse: [ home _ ctxt ].        methodClass _            self findClassOfMethod: (self fetchPointer: MethodIndex ofObject: home)                       forReceiver: (self fetchPointer: ReceiverIndex ofObject: home).        methodSel _            self findSelectorOfMethod: (self fetchPointer: MethodIndex ofObject: home)                         forReceiver: (self fetchPointer: ReceiverIndex ofObject: home).        self printNum: ctxt.        self print: ' '.        ctxt = home ifFalse: [ self print: '[] in ' ].        self printNameOfClass: methodClass count: 5.        self print: '>'.        self printStringOf: methodSel.        self cr.        ctxt _ (self fetchPointer: SenderIndex ofObject: ctxt).    ].! !!Interpreter methodsFor: 'debug support'!printNameOfClass: classOop count: cnt    "Details: The count argument is used to avoid a possible infinite recursion if classOop is a corrupted object."    cnt <= 0 ifTrue: [ ^ self print: 'bad class' ].    (self sizeBitsOf: classOop) = 16r20 ifTrue: [        self printNameOfClass: (self fetchPointer: 6 "thisClass" ofObject: classOop) count: cnt - 1.        self print: ' class'.    ] ifFalse: [        self printStringOf: (self fetchPointer: 6 "name" ofObject: classOop).    ].! !!Interpreter methodsFor: 'debug support'!printStringOf: oop    | fmt cnt i |    fmt _ self formatOf: oop.    fmt < 8 ifTrue: [ ^nil ].    cnt _ 100 min: (self lengthOf: oop).    i _ 0.    [i < cnt] whileTrue: [        self printChar: (self fetchByte: i ofObject: oop).        i _ i + 1.    ].! !!Interpreter methodsFor: 'debug support'!reportContexts    | cntxt big small |    big _ 0.    cntxt _ freeLargeContexts.    [cntxt = NilContext] whileFalse: [        big _ big + 1.        cntxt _ self fetchWord: 0 ofObject: cntxt.    ].    small _ 0.    cntxt _ freeSmallContexts.    [cntxt = NilContext] whileFalse: [        small _ small + 1.        cntxt _ self fetchWord: 0 ofObject: cntxt.    ].    self print: 'Recycled contexts: '.    self printNum: small; print: ' small, '.    self printNum: big; print: ' large ('.    self printNum: (big * LargeContextSize) + (small * SmallContextSize).    self print: ' bytes)'.    self cr.! !!Interpreter methodsFor: 'image save/restore' stamp: 'di 9/23/97 15:22'!byteSwapByteObjects    "Byte-swap the words of all bytes objects in the image, including Strings, ByteArrays, and CompiledMethods. This returns these objects to their original byte ordering after blindly byte-swapping the entire image. For compiled methods, byte-swap only their bytecodes part."    | oop fmt wordAddr methodHeader |    oop _ self firstObject.    [oop < endOfMemory] whileTrue: [        (self isFreeObject: oop) ifFalse: [            fmt _ self formatOf: oop.            fmt >= 8 ifTrue: [  "oop contains bytes"                wordAddr _ oop + BaseHeaderSize.                fmt >= 12 ifTrue: [                    "compiled method; start after methodHeader and literals"                    methodHeader _ self longAt: oop + BaseHeaderSize.                    wordAddr _ wordAddr + 4 + (((methodHeader >> 10) bitAnd: 16rFF) * 4).                ].                self reverseBytesFrom: wordAddr to: oop + (self sizeBitsOf: oop).            ].         ].        oop _ self objectAfter: oop.    ].! !!Interpreter methodsFor: 'image save/restore'!byteSwapped: w    "Return the given integer with its bytes in the reverse order."    ^ ((w bitShift: -24) bitAnd: 16rFF) +      ((w bitShift: -8) bitAnd: 16rFF00) +      ((w bitShift: 8) bitAnd: 16rFF0000) +      ((w bitShift: 24) bitAnd: 16rFF000000)! !!Interpreter methodsFor: 'image save/restore'!checkImageVersionFrom: f    "Read and verify the image file version number and return true if the the given image file needs to be byte-swapped. As a side effect, position the file stream just after the version number of the image header. This code prints a warning and does a hard-exit if it cannot find a valid version number."    "This code is based on C code by Ian Piumarta."    | expectedVersion version firstVersion |    self var: #f declareC: 'FILE *f'.    expectedVersion _ self imageFormatVersion.    "check the version number"    self fileSeek: f position: 0.    version _ firstVersion _ self getLongFromFile: f swap: false.    (version = expectedVersion) ifTrue: [^ false].    "try with byte reversal"    self fileSeek: f position: 0.    version _ self getLongFromFile: f swap: true.    (version = expectedVersion) ifTrue: [^ true].    "try skipping the first 512 bytes (prepended by certain Mac file transfer utilities)"    self fileSeek: f position: 512.    version _ self getLongFromFile: f swap: false.    (version = expectedVersion) ifTrue: [^ false].    "try skipping the first 512 bytes with byte reversal"    self fileSeek: f position: 512.    version _ self getLongFromFile: f swap: true.    (version = expectedVersion) ifTrue: [^ true].    "hard failure; abort"    self print: 'This interpreter (vers. '.    self printNum: expectedVersion.    self print: ' cannot read image file (vers. '.    self printNum: firstVersion.    self cr.    self ioExit.! !!Interpreter methodsFor: 'image save/restore'!fileSeek: f position: pos    "Position the given file stream to the given offset from the start of the file."    self var: #f declareC: 'FILE *f'.    self cCode: 'fseek(f, pos, SEEK_SET)'.! !!Interpreter methodsFor: 'image save/restore'!getLongFromFile: f swap: swapFlag    "Return the next 4-byte word of the given file, byte-swapped according to the given flag."    | w |    self var: #f declareC: 'FILE *f'.    self cCode: 'fread(&w, sizeof(char), 4, f)'.    swapFlag        ifTrue: [^ self byteSwapped: w]        ifFalse: [^ w].! !!Interpreter methodsFor: 'image save/restore'!imageFormatVersion    "Return a magic constant that changes when the image format changes. Since the image reading code uses this to detect byte ordering, one must avoid version numbers that are invariant under byte reversal."    ^ 6502! !!Interpreter methodsFor: 'image save/restore'!positionOfFile: f    "Return the current position of the given file stream."    self var: #f declareC: 'FILE *f'.    ^ self cCode: 'ftell(f)'! !!Interpreter methodsFor: 'image save/restore'!putLong: n toFile: f    "Append the given 4-byte long word to the given file in this platforms 'natural' byte order. (Bytes will be swapped, if necessary, when the image is read on a different platform.) Set successFlag to false if the write fails."    | wordsWritten |    self var: #f declareC: 'FILE *f'.    wordsWritten _ self cCode: 'fwrite(&n, sizeof(int), 1, f)'.    self success: wordsWritten = 1.! !!Interpreter methodsFor: 'image save/restore'!readImageFromFile: f HeapSize: desiredHeapSize    "Read an image from the given file stream, allocating the given amount of memory to its object heap. Fail if the image has an unknown format or requires more than the given amount of memory."    "Details: This method detects when the image was stored on a machine with the opposite byte ordering from this machine and swaps the bytes automatically. Furthermore, it allows the header information to start 512 bytes into the file, since some file transfer programs for the Macintosh apparently prepend a Mac-specific header of this size. Note that this same 512 bytes of prefix area could also be used to store an exec command on Unix systems, allowing one to launch Smalltalk by invoking the image name as a command."    "This code is based on C code by Ian Piumarta and Smalltalk code by Tim Rowledge. Many thanks to both of you!!!!"    | swapBytes headerStart headerSize dataSize oldBaseAddr minimumMemory memStart bytesRead bytesToShift |    self var: #f declareC: 'FILE *f'.    swapBytes _ self checkImageVersionFrom: f.    headerStart _ (self positionOfFile: f) - 4.  "record header start position"    headerSize            _ self getLongFromFile: f swap: swapBytes.    dataSize                _ self getLongFromFile: f swap: swapBytes.    oldBaseAddr            _ self getLongFromFile: f swap: swapBytes.    specialObjectsOop        _ self getLongFromFile: f swap: swapBytes.    lastHash            _ self getLongFromFile: f swap: swapBytes.    savedWindowSize    _ self getLongFromFile: f swap: swapBytes.    lastHash = 0 ifTrue: [        "lastHash wasn't stored (e.g. by the cloner); use 999 as the seed"        lastHash _ 999].    "compare memory requirements with availability".    minimumMemory _ dataSize + 80000.  "need at least 80K of breathing room"    desiredHeapSize < minimumMemory        ifTrue: [ self error: 'Insufficient memory for this image' ].    "allocate a contiguous block of memory for the Squeak heap"    memory _ self cCode: '(unsigned char *) malloc(desiredHeapSize)'.    memory = nil        ifTrue: [ self error: 'Failed to allocate memory for the heap' ].    memStart _ self startOfMemory.    memoryLimit _ (memStart + desiredHeapSize) - 24.  "decrease memoryLimit a tad for safety"    endOfMemory _ memStart + dataSize.    "position file after the header"    self fileSeek: f position: headerStart + headerSize.    "read in the image in bulk, then swap the bytes if necessary"    bytesRead _ self cCode: 'fread(memory, sizeof(unsigned char), dataSize, f)'.    bytesRead ~= dataSize        ifTrue: [ self error: 'Read failed or premature end of image file' ].    swapBytes ifTrue: [self reverseBytesInImage].    "compute difference between old and new memory base addresses"    bytesToShift _ memStart - oldBaseAddr.    self initializeInterpreter: bytesToShift.  "adjusts all oops to new location"    ^ dataSize! !!Interpreter methodsFor: 'image save/restore' stamp: 'di 9/23/97 15:20'!reverseBytesFrom: startAddr to: stopAddr    "Byte-swap the given range of memory (not inclusive!!)."    | addr |    addr _ startAddr.    [addr < stopAddr] whileTrue:        [self longAt: addr put: (self byteSwapped: (self longAt: addr)).        addr _ addr + 4].! !!Interpreter methodsFor: 'image save/restore' stamp: 'di 10/2/97 00:31'!reverseBytesInImage    "Byte-swap all words in memory after reading in the entire image file with bulk read. Contributed by Tim Rowledge."    "First, byte-swap every word in the image. This fixes objects headers."    self reverseBytesFrom: self startOfMemory to: endOfMemory.    "Second, return the bytes of bytes-type objects to their orginal order."    self byteSwapByteObjects.! !!Interpreter methodsFor: 'image save/restore' stamp: 'jm 9/21/97 18:07'!writeImageFile: imageBytes    | headerStart headerSize f bytesWritten |    self var: #f declareC: 'FILE *f'.    "local constants"    headerStart _ 0.  "change to 512 to leave room for a Unix exec string"    headerSize _ 64.  "header size in bytes; do not change!!"    f _ self cCode: 'fopen(imageName, "wb")'.    f = nil ifTrue: [        "could not open the image file for writing"        self success: false.        ^ nil ].    self cCode: '/* Note: on Unix systems one could put an exec command here, padded to 512 bytes */'.    "position file to start of header"    self fileSeek: f position: headerStart.    self putLong: (self imageFormatVersion) toFile: f.    self putLong: headerSize toFile: f.    self putLong: imageBytes toFile: f.    self putLong: (self startOfMemory) toFile: f.    self putLong: specialObjectsOop toFile: f.    self putLong: lastHash toFile: f.    self putLong: (self ioScreenSize) toFile: f.    1 to: 9 do: [:i | self putLong: 0 toFile: f].  "fill remaining header words with zeros"    successFlag ifFalse: [        "write or seek failure"        self cCode: 'fclose(f)'.        ^ nil ].    "position file after the header"    self fileSeek: f position: headerStart + headerSize.    "write the image data"    bytesWritten _ self cCode: 'fwrite(memory, sizeof(unsigned char), imageBytes, f)'.    self success: bytesWritten = imageBytes.    self cCode: 'fclose(f)'.    "set Mac file type and creator; this is a noop on other platforms"    self cCode: 'dir_SetMacFileTypeAndCreator(imageName, strlen(imageName), "STim", "FAST")'.! !!Interpreter methodsFor: 'quick primitives' stamp: 'jm 9/18/97 21:06'!primitiveLoadInstVar    | thisReceiver |    thisReceiver _ self popStack.    self push: (self fetchPointer: primitiveIndex-264 ofObject: thisReceiver)! !!Interpreter methodsFor: 'quick primitives' stamp: 'jm 9/18/97 21:06'!primitivePushFalse    self popStack.    self push: falseObj! !!Interpreter methodsFor: 'quick primitives' stamp: 'jm 9/18/97 21:06'!primitivePushMinusOne    self popStack.    self push: ConstMinusOne! !!Interpreter methodsFor: 'quick primitives' stamp: 'jm 9/18/97 21:06'!primitivePushNil    self popStack.    self push: nilObj! !!Interpreter methodsFor: 'quick primitives' stamp: 'jm 9/18/97 21:06'!primitivePushOne    self popStack.    self push: ConstOne! !!Interpreter methodsFor: 'quick primitives' stamp: 'jm 9/18/97 21:06'!primitivePushSelf"    no-op, really...    thisReceiver _ self popStack.    self push: thisReceiver"! !!Interpreter methodsFor: 'quick primitives' stamp: 'jm 9/18/97 21:06'!primitivePushTrue    self popStack.    self push: trueObj! !!Interpreter methodsFor: 'quick primitives' stamp: 'jm 9/18/97 21:06'!primitivePushTwo    self popStack.    self push: ConstTwo! !!Interpreter methodsFor: 'quick primitives' stamp: 'jm 9/18/97 21:06'!primitivePushZero    self popStack.    self push: ConstZero! !!Interpreter class methodsFor: 'initialization' stamp: 'jm 8/22/97 12:57'!initialize    "Interpreter initialize"    super initialize.  "initialize ObjectMemory constants"    self initializeAssociationIndex.    self initializeBytecodeTable.    self initializeCharacterIndex.    self initializeClassIndices.    self initializeContextIndices.    self initializeDirectoryLookupResultCodes.    self initializeMessageIndices.    self initializeMethodIndices.    self initializePointIndices.    self initializePrimitiveTable.    self initializeSchedulerIndices.    self initializeSmallIntegers.    self initializeStreamIndices.    MethodCacheEntries _ 512.     MethodCacheMask _ MethodCacheEntries - 1.    (MethodCacheEntries bitAnd: MethodCacheMask) = 0        ifFalse: [ self error: 'MethodCacheEntries must be a power of two' ].    MethodCacheSize _ MethodCacheEntries * 4.    CacheProbeMax _ 3.    SemaphoresToSignalSize _ 25.! !!Interpreter class methodsFor: 'initialization'!initializeAssociationIndex    ValueIndex _ 1! !!Interpreter class methodsFor: 'initialization'!initializeBytecodeTable    "Interpreter initializeBytecodeTable"    "Note: This table will be used to generate a C switch statement."    BytecodeTable _ Array new: 256.    self table: BytecodeTable from:    #(        (  0  15 pushReceiverVariableBytecode)        ( 16  31 pushTemporaryVariableBytecode)        ( 32  63 pushLiteralConstantBytecode)        ( 64  95 pushLiteralVariableBytecode)        ( 96 103 storeAndPopReceiverVariableBytecode)        (104 111 storeAndPopTemporaryVariableBytecode)        (112 pushReceiverBytecode)        (113 pushConstantTrueBytecode)        (114 pushConstantFalseBytecode)        (115 pushConstantNilBytecode)        (116 pushConstantMinusOneBytecode)        (117 pushConstantZeroBytecode)        (118 pushConstantOneBytecode)        (119 pushConstantTwoBytecode)        (120 returnReceiver)        (121 returnTrue)        (122 returnFalse)        (123 returnNil)        (124 returnTopFromMethod)        (125 returnTopFromBlock)        (126 unknownBytecode)        (127 unknownBytecode)        (128 extendedPushBytecode)        (129 extendedStoreBytecode)        (130 extendedStoreAndPopBytecode)        (131 singleExtendedSendBytecode)        (132 doubleExtendedDoAnythingBytecode)        (133 singleExtendedSuperBytecode)        (134 secondExtendedSendBytecode)        (135 popStackBytecode)        (136 duplicateTopBytecode)        (137 pushActiveContextBytecode)        (138 143 experimentalBytecode)        (144 151 shortUnconditionalJump)        (152 159 shortConditionalJump)        (160 167 longUnconditionalJump)        (168 171 longJumpIfTrue)        (172 175 longJumpIfFalse)        "176-191 were sendArithmeticSelectorBytecode"        (176 bytecodePrimAdd)        (177 bytecodePrimSubtract)        (178 bytecodePrimLessThan)        (179 bytecodePrimGreaterThan)        (180 bytecodePrimLessOrEqual)        (181 bytecodePrimGreaterOrEqual)        (182 bytecodePrimEqual)        (183 bytecodePrimNotEqual)        (184 bytecodePrimMultiply)        (185 bytecodePrimDivide)        (186 bytecodePrimMod)        (187 bytecodePrimMakePoint)        (188 bytecodePrimBitShift)        (189 bytecodePrimDiv)        (190 bytecodePrimBitAnd)        (191 bytecodePrimBitOr)            "192-207 were sendCommonSelectorBytecode"        (192 bytecodePrimAt)        (193 bytecodePrimAtPut)        (194 bytecodePrimSize)        (195 bytecodePrimNext)        (196 bytecodePrimNextPut)        (197 bytecodePrimAtEnd)        (198 bytecodePrimEquivalent)        (199 bytecodePrimClass)        (200 bytecodePrimBlockCopy)        (201 bytecodePrimValue)        (202 bytecodePrimValueWithArg)        (203 bytecodePrimDo)        (204 bytecodePrimNew)        (205 bytecodePrimNewWithArg)        (206 bytecodePrimPointX)        (207 bytecodePrimPointY)        (208 255 sendLiteralSelectorBytecode)    ).! !!Interpreter class methodsFor: 'initialization'!initializeCharacterIndex    CharacterValueIndex _ 0! !!Interpreter class methodsFor: 'initialization'!initializeClassIndices    "Class Class"    SuperclassIndex _ 0.    MessageDictionaryIndex _ 1.    InstanceSpecificationIndex _ 2.    "Fields of a message dictionary"    MethodArrayIndex _ 1.    SelectorStart _ 2! !!Interpreter class methodsFor: 'initialization'!initializeContextIndices    "Class MethodContext"    SenderIndex _ 0.    InstructionPointerIndex _ 1.    StackPointerIndex _ 2.    MethodIndex _ 3.    ReceiverIndex _ 5.    TempFrameStart _ 6.    "Class BlockContext"    CallerIndex _ 0.    BlockArgumentCountIndex _ 3.    InitialIPIndex _ 4.    HomeIndex _ 5! !!Interpreter class methodsFor: 'initialization'!initializeDirectoryLookupResultCodes    DirEntryFound _ 0.    DirNoMoreEntries _ 1.    DirBadPath _ 2.! !!Interpreter class methodsFor: 'initialization'!initializeMessageIndices    MessageSelectorIndex _ 0.    MessageArgumentsIndex _ 1.    MessageSize _ 2! !!Interpreter class methodsFor: 'initialization'!initializeMethodIndices    "Class CompiledMethod"    HeaderIndex _ 0.    LiteralStart _ 1! !!Interpreter class methodsFor: 'initialization'!initializePointIndices    XIndex _ 0.    YIndex _ 1! !!Interpreter class methodsFor: 'initialization' stamp: 'jm 9/18/97 21:09'!initializePrimitiveTable    "Interpreter initializePrimitiveTable"    "This table generates a C switch statement."    "NOTE: The real limit here is 2047, but our C compiler currently barfs over 700"    MaxPrimitiveIndex _ 699.    PrimitiveTable _ Array new: MaxPrimitiveIndex+1.    self table: PrimitiveTable from:     #(        "Integer Primitives (0-19)"        (0 primitiveFail)        (1 primitiveAdd)        (2 primitiveSubtract)        (3 primitiveLessThan)        (4 primitiveGreaterThan)        (5 primitiveLessOrEqual)        (6 primitiveGreaterOrEqual)        (7 primitiveEqual)        (8 primitiveNotEqual)        (9 primitiveMultiply)        (10 primitiveDivide)        (11 primitiveMod)        (12 primitiveDiv)        (13 primitiveQuo)        (14 primitiveBitAnd)        (15 primitiveBitOr)        (16 primitiveBitXor)        (17 primitiveBitShift)        (18 primitiveMakePoint)        (19 primitiveFail)        "LargeInteger Primitives (20-39)"        "32-bit logic is aliased to Integer prims above"        (20 39 primitiveFail)        "Float Primitives (40-59)"        (40 primitiveAsFloat)        (41 primitiveFloatAdd)        (42 primitiveFloatSubtract)        (43 primitiveFloatLessThan)        (44 primitiveFloatGreaterThan)        (45 primitiveFloatLessOrEqual)        (46 primitiveFloatGreaterOrEqual)        (47 primitiveFloatEqual)        (48 primitiveFloatNotEqual)        (49 primitiveFloatMultiply)        (50 primitiveFloatDivide)        (51 primitiveTruncated)        (52 primitiveFractionalPart)        (53 primitiveExponent)        (54 primitiveTimesTwoPower)        (55 primitiveSquareRoot)        (56 primitiveSine)        (57 primitiveArctan)        (58 primitiveLogN)        (59 primitiveExp)        "Subscript and Stream Primitives (60-67)"        (60 primitiveAt)        (61 primitiveAtPut)        (62 primitiveSize)        (63 primitiveStringAt)        (64 primitiveStringAtPut)        (65 primitiveNext)        (66 primitiveNextPut)        (67 primitiveAtEnd)        "StorageManagement Primitives (68-79)"        (68 primitiveObjectAt)        (69 primitiveObjectAtPut)        (70 primitiveNew)        (71 primitiveNewWithArg)        (72 primitiveFail)                    "Blue Book: primitiveBecome"        (73 primitiveInstVarAt)        (74 primitiveInstVarAtPut)        (75 primitiveAsOop)        (76 primitiveFail)                    "Blue Book: primitiveAsObject"        (77 primitiveSomeInstance)        (78 primitiveNextInstance)        (79 primitiveNewMethod)        "Control Primitives (80-89)"        (80 primitiveFail)                       "Blue Book:  primitiveBlockCopy"        (81 primitiveValue)        (82 primitiveValueWithArgs)        (83 primitivePerform)        (84 primitivePerformWithArgs)        (85 primitiveSignal)        (86 primitiveWait)        (87 primitiveResume)        (88 primitiveSuspend)        (89 primitiveFlushCache)        "Input/Output Primitives (90-109)"        (90 primitiveMousePoint)        (91 primitiveFail)                    "Blue Book: primitiveCursorLocPut"        (92 primitiveFail)                    "Blue Book: primitiveCursorLink"        (93 primitiveInputSemaphore)        (94 primitiveFail)                    "Blue Book: primitiveSampleInterval"        (95 primitiveInputWord)        (96 primitiveCopyBits)        (97 primitiveSnapshot)        (98 primitiveFail)                    "Blue Book: primitiveTimeWordsInto"        (99 primitiveFail)                    "Blue Book: primitiveTickWordsInto"        (100 primitiveFail)                    "Blue Book: primitiveSignalAtTick"        (101 primitiveBeCursor)        (102 primitiveBeDisplay)        (103 primitiveScanCharacters)        (104 primitiveDrawLoop)        (105 primitiveStringReplace)        (106 primitiveScreenSize)        (107 primitiveMouseButtons)        (108 primitiveKbdNext)        (109 primitiveKbdPeek)        "System Primitives (110-119)"        (110 primitiveEquivalent)        (111 primitiveClass)        (112 primitiveBytesLeft)        (113 primitiveQuit)        (114 primitiveExitToDebugger)        (115 primitiveFail)                    "Blue Book: primitiveOopsLeft"        (116 primitiveFail)        (117 primitiveFail)        (118 primitiveFail)        (119 primitiveFail)        "Miscellaneous Primitives (120-127)"        (120 primitiveFail)        (121 primitiveImageName)        (122 primitiveNoop)                    "Blue Book: primitiveImageVolume"        (123 primitiveFail)        (124 primitiveLowSpaceSemaphore)        (125 primitiveSignalAtBytesLeft)        (126 primitiveFail)        (127 primitiveFail)        "Squeak Primitives Start Here"        "Squeak Miscellaneous Primitives (128-149)"        (128 primitiveArrayBecome)        (129 primitiveSpecialObjectsOop)        (130 primitiveFullGC)        (131 primitiveIncrementalGC)        (132 primitiveObjectPointsTo)        (133 primitiveSetInterruptKey)        (134 primitiveInterruptSemaphore)        (135 primitiveMillisecondClock)        (136 primitiveSignalAtMilliseconds)        (137 primitiveSecondsClock)        (138 primitiveSomeObject)        (139 primitiveNextObject)        (140 primitiveBeep)        (141 primitiveClipboardText)        (142 primitiveVMPath)        (143 primitiveShortAt)        (144 primitiveShortAtPut)        (145 primitiveConstantFill)        (146 primitiveReadJoystick)        (147 primitiveWarpBits)        (148 primitiveClone)        (149 primitiveGetAttribute)        "File Primitives (150-169)"        (150 primitiveFileAtEnd)        (151 primitiveFileClose)        (152 primitiveFileGetPosition)        (153 primitiveFileOpen)        (154 primitiveFileRead)        (155 primitiveFileSetPosition)        (156 primitiveFileDelete)        (157 primitiveFileSize)        (158 primitiveFileWrite)        (159 primitiveFileRename)        (160 primitiveDirectoryCreate)        (161 primitiveDirectoryDelimitor)        (162 primitiveDirectoryLookup)        (163 168 primitiveFail)        (169 primitiveDirectorySetMacTypeAndCreator)        "Sound Primitives (170-199)"        (170 primitiveSoundStart)        (171 primitiveSoundStartWithSemaphore)        (172 primitiveSoundStop)        (173 primitiveSoundAvailableSpace)        (174 primitiveSoundPlaySamples)        (175 primitiveSoundPlaySilence)        "obsolete; will be removed in the future"        (176 primWaveTableSoundmixSampleCountintostartingAtpan)        (177 primFMSoundmixSampleCountintostartingAtpan)        (178 primPluckedSoundmixSampleCountintostartingAtpan)        (179 primSampledSoundmixSampleCountintostartingAtpan)        (180 188 primitiveFail)        (189 primitiveSoundInsertSamples)        (190 primitiveSoundStartRecording)        (191 primitiveSoundStopRecording)        (192 primitiveSoundGetRecordingSampleRate)        (193 primitiveSoundRecordSamples)        (194 primitiveSoundSetRecordLevel)        (195 199 primitiveFail)        "Networking Primitives (200-229)"        (200 primitiveInitializeNetwork)        (201 primitiveResolverStartNameLookup)        (202 primitiveResolverNameLookupResult)        (203 primitiveResolverStartAddressLookup)        (204 primitiveResolverAddressLookupResult)        (205 primitiveResolverAbortLookup)        (206 primitiveResolverLocalAddress)        (207 primitiveResolverStatus)        (208 primitiveResolverError)        (209 primitiveSocketCreate)        (210 primitiveSocketDestroy)        (211 primitiveSocketConnectionStatus)        (212 primitiveSocketError)        (213 primitiveSocketLocalAddress)        (214 primitiveSocketLocalPort)        (215 primitiveSocketRemoteAddress)        (216 primitiveSocketRemotePort)        (217 primitiveSocketConnectToPort)        (218 primitiveSocketListenOnPort)        (219 primitiveSocketCloseConnection)        (220 primitiveSocketAbortConnection)        (221 primitiveSocketReceiveDataBufCount)        (222 primitiveSocketReceiveDataAvailable)        (223 primitiveSocketSendDataBufCount)        (224 primitiveSocketSendDone)        (225 229 primitiveFail)        "Other Primitives (230-249)"        (230 primitiveRelinquishProcessor)        (231 249 primitiveFail)        "VM Implementor Primitives (250-255)"        (250 clearProfile)        (251 dumpProfile)        (252 startProfiling)        (253 stopProfiling)        (254 primitiveVMParameter)        (255 primitiveFail)        "Quick Push Const Methods"        (256 primitivePushSelf)        (257 primitivePushTrue)        (258 primitivePushFalse)        (259 primitivePushNil)        (260 primitivePushMinusOne)        (261 primitivePushZero)        (262 primitivePushOne)        (263 primitivePushTwo)        "Quick Push Const Methods"        (264 519 primitiveLoadInstVar)        "Unassigned Primitives"        (520 primitiveBeep) "test of new primitive indices"        (521 699 primitiveFail)    ).! !!Interpreter class methodsFor: 'initialization'!initializeSchedulerIndices    "Class ProcessorScheduler"    ProcessListsIndex _ 0.    ActiveProcessIndex _ 1.    "Class LinkedList"    FirstLinkIndex _ 0.    LastLinkIndex _ 1.    "Class Semaphore"    ExcessSignalsIndex _ 2.    "Class Link"    NextLinkIndex _ 0.    "Class Process"    SuspendedContextIndex _ 1.    PriorityIndex _ 2.    MyListIndex _ 3! !!Interpreter class methodsFor: 'initialization'!initializeSmallIntegers    "SmallIntegers"    ConstMinusOne _ Interpreter new integerObjectOf: -1.    ConstZero _ Interpreter new integerObjectOf: 0.    ConstOne _ Interpreter new integerObjectOf: 1.    ConstTwo _ Interpreter new integerObjectOf: 2! !!Interpreter class methodsFor: 'initialization'!initializeStreamIndices    StreamArrayIndex _ 0.    StreamIndexIndex _ 1.    StreamReadLimitIndex _ 2.    StreamWriteLimitIndex _ 3.! !!Interpreter class methodsFor: 'initialization'!table: anArray from: specArray    "SpecArray is an array of either (index selector) or (index1 index2 selector)."    | contiguous |    contiguous _ 0.    specArray do: [ :spec |        (spec at: 1) = contiguous ifFalse: [ self error: 'Non-contiguous table entry' ].        spec size = 2 ifTrue: [            anArray at: ((spec at: 1) + 1) put: (spec at: 2).            contiguous _ contiguous + 1.        ] ifFalse: [            (spec at: 1) to: (spec at: 2) do: [ :i | anArray at: (i + 1) put: (spec at: 3) ].            contiguous _ contiguous + ((spec at: 2) - (spec at: 1)) + 1.        ].    ].! !!Interpreter class methodsFor: 'constants'!bytecodeTable    ^ BytecodeTable! !!Interpreter class methodsFor: 'constants'!primitiveTable    ^ PrimitiveTable! !!Interpreter class methodsFor: 'translation' stamp: 'jm 8/22/97 15:27'!declareCVarsIn: aCCodeGenerator    aCCodeGenerator var: 'methodCache'        declareC: 'int methodCache[', (MethodCacheSize + 1) printString, ']'.    aCCodeGenerator var: 'localIP' declareC: 'char * localIP'.    aCCodeGenerator var: 'localSP' declareC: 'char * localSP'.    aCCodeGenerator var: 'semaphoresToSignal'        declareC: 'int semaphoresToSignal[', (SemaphoresToSignalSize + 1) printString, ']'.! !!Interpreter class methodsFor: 'translation'!patchInterp: fileName    "Interpreter patchInterp: 'Squeak VM PPC'"    "This will patch out the unneccesary range check (a compare     and branch) in the inner interpreter dispatch loop."    "NOTE: You must edit in the Interpeter file name, and the     number of instructions (delta) to count back to find the compare     and branch that we want to get rid of."    | delta f code len remnant i |    delta _ 6.    f _ FileStream fileNamed: fileName.    f binary.    code _ Bitmap new: (len _ f size) // 4.    f nextInto: code.    remnant _ f next: len - (code size * 4).    i _ 0.    ["Look for a BCTR instruction"    (i _ code indexOf: 16r4E800420 startingAt: i + 1 ifAbsent: [0]) > 0] whileTrue: [        "Look for a CMPLWI FF, 6 instrs back"           ((code at: i - delta) bitAnd: 16rFFE0FFFF) = 16r280000FF ifTrue: [               "Copy dispatch instrs back over the compare"            SelectionMenu notify: 'Patching at ', i hex.            0 to: delta - 2 do: [ :j |                code at: (i - delta) + j put: (code at: (i - delta) + j + 2).            ].        ].    ].    f position: 0; nextPutAll: code; nextPutAll: remnant.    f close.! !!Interpreter class methodsFor: 'translation'!translate: fileName doInlining: inlineFlag    "Time millisecondsToRun: [        Interpreter translate: 'InterpTest.c' doInlining: true.        Smalltalk beep]"    | cg |    BitBltSimulation initialize.    Interpreter initialize.    ObjectMemory initialize.    cg _ CCodeGenerator new initialize.    cg addClass: BitBltSimulation.    cg addClass: Interpreter.    cg addClass: ObjectMemory.    BitBltSimulation declareCVarsIn: cg.    Interpreter declareCVarsIn: cg.    ObjectMemory declareCVarsIn: cg.    cg storeCodeOnFile: fileName doInlining: inlineFlag.! !InterpreterSimulator comment:'This class defines basic memory access and primitive simulation so that the Interpreter can run simulated in the Squeak environment.  It also defines a number of handy object viewing methods to facilitate pawing around in the object memory.To see the thing actually run, you could (after backing up this image and changes), execute    (InterpreterSimulator new openOn: Smalltalk imageName) testand be patient both to wait for things to happen, and to accept various things that may go wrong depending on how large or unusual your image may be.  We usually do this with a small and simple benchmark image.'!!InterpreterSimulator methodsFor: 'initialization'!close  "close any files that ST may have opened"    filesOpen do: [:f | f setToEnd; close]! !!InterpreterSimulator methodsFor: 'initialization' stamp: 'jm 8/22/97 12:59'!initialize    "Initialize the InterpreterSimulator when running the interpreter inside Smalltalk. The primary responsibility of this method is to allocate Smalltalk Arrays for variables that will be declared as statically-allocated global arrays in the translated code."    "initialize class variables"    ObjectMemory initialize.    Interpreter initialize.    methodCache _ Array new: MethodCacheSize.    rootTable _ Array new: RootTableSize.    remapBuffer _ Array new: RemapBufferSize.    semaphoresToSignal _ Array new: SemaphoresToSignalSize.    "initialize InterpreterSimulator variables used for debugging"    byteCount _ 0.    sendCount _ 0.    traceOn _ true.    myBitBlt _ BitBltSimulation new setInterpreter: self.    displayForm _ nil.  "displayForm is created in response to primitiveBeDisplay"    filesOpen _ OrderedCollection new.! !!InterpreterSimulator methodsFor: 'initialization'!nextLongFrom: aStream    "Read a 32-bit quantity from the given (binary) stream."    | bytes |    bytes _ aStream nextInto: (ByteArray new: 4).    ^ Integer        byte1: (bytes at: 4)        byte2: (bytes at: 3)        byte3: (bytes at: 2)        byte4: (bytes at: 1)! !!InterpreterSimulator methodsFor: 'initialization' stamp: 'di 9/23/97 15:51'!nextLongFrom: aStream swap: swapFlag    swapFlag         ifTrue: [^ self byteSwapped: (self nextLongFrom: aStream)]        ifFalse: [^ self nextLongFrom: aStream]! !!InterpreterSimulator methodsFor: 'initialization'!openOn: fileName    "(InterpreterSimulator new openOn: 'clonex.image') test"    self openOn: fileName extraMemory: 500000.! !!InterpreterSimulator methodsFor: 'initialization' stamp: 'di 9/27/97 09:24'!openOn: fileName extraMemory: extraBytes    "InterpreterSimulator new openOn: 'clone.im' extraMemory: 100000"    | f version headerSize count oldBaseAddr bytesToShift swapBytes |    "open image file and read the header"    checkAssertions _ false.    f _ FileStream oldFileNamed: fileName.    imageName _ f fullName.    f binary; readOnly.    version _ self nextLongFrom: f.  "current version: 16r1966 (=6502)"    version = self imageFormatVersion        ifTrue: [swapBytes _ false]        ifFalse: [(version _ self byteSwapped: version) = self imageFormatVersion                    ifTrue: [swapBytes _ true]                    ifFalse: [self error: 'incomaptible image format']].    headerSize _ self nextLongFrom: f swap: swapBytes.    endOfMemory _ self nextLongFrom: f swap: swapBytes.  "first unused location in heap"    oldBaseAddr _ self nextLongFrom: f swap: swapBytes.  "object memory base address of image"    specialObjectsOop _ self nextLongFrom: f swap: swapBytes.    lastHash _ self nextLongFrom: f swap: swapBytes.  "Should be loaded from, and saved to the image header"    savedWindowSize _ self nextLongFrom: f swap: swapBytes.    lastHash = 0 ifTrue: [lastHash _ 999].    "allocate interpreter memory"    memoryLimit _ endOfMemory + extraBytes.    "read in the image in bulk, then swap the bytes if necessary"    f position: headerSize.    memory _ Bitmap new: memoryLimit // 4.    count _ f readInto: memory startingAt: 1 count: endOfMemory // 4.    count ~= (endOfMemory // 4) ifTrue: [self halt].    f close.    swapBytes ifTrue: [Utilities informUser: 'Swapping bytes of foreign image...'                                during: [self reverseBytesInImage]].    self initialize.    bytesToShift _ 0 - oldBaseAddr.  "adjust pointers for zero base address"    endOfMemory _ endOfMemory.    Utilities informUser: 'Relocating object pointers...'                during: [self initializeInterpreter: bytesToShift].    checkAssertions _ false.! !!InterpreterSimulator methodsFor: 'initialization' stamp: 'di 10/2/97 00:32'!reverseBytesFrom: begin to: end    "Byte-swap the given range of memory (not inclusive!!)."    | wordAddr |    wordAddr _ begin.    memory swapBytesFrom: wordAddr // 4 + 1 to: end // 4! !!InterpreterSimulator methodsFor: 'initialization'!startOfMemory    "Return the start of object memory."    ^ 0! !!InterpreterSimulator methodsFor: 'testing' stamp: 'di 9/28/97 03:02'!findNewMethodInClass: class"    | cName |    traceOn ifTrue:        [cName _ (self sizeBitsOf: class) = 16r20            ifTrue: ['class ' , (self nameOfClass: (self fetchPointer: 6 ofObject: class))]            ifFalse: [(self nameOfClass: class)].        self cr; print: cName , '>>' , (self stringOf: messageSelector)].""(self stringOf: messageSelector) = 'raisedToInteger:' ifTrue: [self halt]."    sendCount _ sendCount + 1.(false "sendCount > 1090" "and: [sendCount\\10 = 0]") ifTrue:        [Transcript print: sendCount; space.        self validate].    super findNewMethodInClass: class.! !!InterpreterSimulator methodsFor: 'testing' stamp: 'di 10/1/97 23:36'!objectBefore: addr    | oop prev |    oop _ self firstObject.    [oop < endOfMemory] whileTrue: [        prev _ oop.  "look here if debugging prev obj overlapping this one"        oop _ self objectAfter: oop.        oop >= addr ifTrue: [^ prev]    ]! !!InterpreterSimulator methodsFor: 'testing'!profile: nBytecodes    "(InterpreterSimulator new openOn: 'clonex.image') profile: 60000"    Transcript clear.    byteCount _ 0.    MessageTally spyOn: [        self internalizeIPandSP.        [byteCount < nBytecodes] whileTrue: [            currentBytecode _ self fetchByte.            self dispatchOn: currentBytecode in: BytecodeTable.            byteCount _ byteCount + 1.        ].        self externalizeIPandSP.    ].! !!InterpreterSimulator methodsFor: 'testing'!profileSends: nBytecodes    "(InterpreterSimulator new openOn: 'clonex.image') profileSends: 5000"    Transcript clear.    byteCount _ 0.    MessageTally tallySendsTo: self inBlock: [        self internalizeIPandSP.        [byteCount < nBytecodes] whileTrue: [            currentBytecode _ self fetchByte.            self dispatchOn: currentBytecode in: BytecodeTable.            byteCount _ byteCount + 1.        ].        self externalizeIPandSP.    ] showTree: true.! !!InterpreterSimulator methodsFor: 'testing' stamp: 'di 9/11/97 21:02'!stats    | oop fieldAddr fieldOop last ints ints100 ints1000 fields ints10 spl v intsM100 intsM1000 rel100 rel1000 relM100 relM1000 d |    Transcript show: 'Taking stats...'.    ints _ fields _ 0.    ints10 _ ints100 _ ints1000 _ intsM100 _ intsM1000 _ 0.    rel100 _ rel1000 _ relM100 _ relM1000 _ 0.    spl _ Bag new.    oop _ self firstObject.    [oop < endOfMemory] whileTrue:        [(self isFreeObject: oop) ifFalse:            [fieldAddr _ oop + (self lastPointerOf: oop).            [fieldAddr > oop] whileTrue:                [fieldOop _ self longAt: fieldAddr.                fields _ fields + 1.                (self isIntegerObject: fieldOop)                    ifTrue: [v _ self integerValueOf: fieldOop.                            ints _ ints + 1.                            (v between: 0 and: 10) ifTrue: [ints10 _ ints10 + 1].                            (v between: 0 and: 100) ifTrue: [ints100 _ ints100 + 1].                            (v between: 0 and: 1000) ifTrue: [ints1000 _ ints1000 + 1].                            (v between: -100 and: -1) ifTrue: [intsM100 _ intsM100 + 1].                            (v between: -1000 and: -1) ifTrue: [intsM1000 _ intsM1000 + 1]]                    ifFalse: [fieldOop = nilObj ifTrue: [spl add: fieldOop].                            fieldOop = falseObj ifTrue: [spl add: fieldOop].                            fieldOop = trueObj ifTrue: [spl add: fieldOop].                            d _ fieldOop - oop.                            (d between: 0 and: 100) ifTrue: [rel100 _ rel100 + 1].                            (d between: 0 and: 1000) ifTrue: [rel1000 _ rel1000 + 1].                            (d between: -100 and: -1) ifTrue: [relM100 _ relM100 + 1].                            (d between: -1000 and: -1) ifTrue: [relM1000 _ relM1000 + 1]].                fieldAddr _ fieldAddr - 4]].        last _ oop.        oop _ self objectAfter: oop].    Transcript show: 'done.'; cr.    ^ (Array with: fields with: ints with: ints10) ,        (Array with: ints100 with: ints1000 with: intsM100 with: intsM1000) ,        (Array with: rel100 with: rel1000 with: relM100 with: relM1000) ,        (Array with: spl sortedElements)! !!InterpreterSimulator methodsFor: 'testing'!test    Transcript clear.    byteCount _ 0.    self internalizeIPandSP.    [true] whileTrue: [        currentBytecode _ self fetchByte.        self dispatchOn: currentBytecode in: BytecodeTable.        byteCount _ byteCount + 1.    ].    self externalizeIPandSP.! !!InterpreterSimulator methodsFor: 'testing'!testBecome    "Become some young things.  AA testBecome    "    | array list1 list2 p1 p2 p3 p4 |    array _ self splObj: ClassArray.    list1 _ self instantiateClass: array indexableSize: 2.    list2 _ self instantiateClass: array indexableSize: 2.    p1 _ self instantiateClass: (self splObj: ClassPoint) indexableSize: 0.    self push: p1.    self storePointer: 0 ofObject: list1 withValue: p1.    p2 _ self instantiateClass: (self splObj: ClassPoint) indexableSize: 0.    self push: p2.    self storePointer: 1 ofObject: list1 withValue: p2.    p3 _ self instantiateClass: (self splObj: ClassMessage) indexableSize: 0.    self push: p3.    self storePointer: 0 ofObject: list2 withValue: p3.    p4 _ self instantiateClass: (self splObj: ClassMessage) indexableSize: 0.    self push: p4.    self storePointer: 1 ofObject: list2 withValue: p4.    (self become: list1 with: list2) ifFalse: [self error: 'failed'].    self popStack = p2 ifFalse: [self halt].    self popStack = p1 ifFalse: [self halt].    self popStack = p4 ifFalse: [self halt].    self popStack = p3 ifFalse: [self halt].    (self fetchPointer: 0 ofObject: list1) = p3 ifFalse: [self halt].    (self fetchPointer: 1 ofObject: list1) = p4 ifFalse: [self halt].    (self fetchPointer: 0 ofObject: list2) = p1 ifFalse: [self halt].    (self fetchPointer: 1 ofObject: list2) = p2 ifFalse: [self halt].! !!InterpreterSimulator methodsFor: 'testing' stamp: 'di 9/11/97 16:02'!validate    | oop prev |    Transcript show: 'Validating...'.    oop _ self firstObject.    [oop < endOfMemory] whileTrue: [        self validate: oop.        prev _ oop.  "look here if debugging prev obj overlapping this one"        oop _ self objectAfter: oop.    ].    Transcript show: 'done.'; cr! !!InterpreterSimulator methodsFor: 'testing' stamp: 'di 9/11/97 15:58'!validate: oop    | header type cc sz fmt nextChunk |     header _ self longAt: oop.    type _ header bitAnd: 3.    type = 2 ifFalse: [type = (self rightType: header) ifFalse: [self halt]].    sz _ (header >> 2) bitAnd: 16r3F.    (self isFreeObject: oop)        ifTrue: [ nextChunk _ oop + (self sizeOfFree: oop) ]        ifFalse: [  nextChunk _ oop + (self sizeBitsOf: oop) ].    nextChunk > endOfMemory        ifTrue: [oop = endOfMemory ifFalse: [self halt]].    (self headerType: nextChunk) = 0 ifTrue: [        (self headerType: (nextChunk + 8)) = 0 ifFalse: [self halt]].    (self headerType: nextChunk) = 1 ifTrue: [        (self headerType: (nextChunk + 4)) = 1 ifFalse: [self halt]].    type = 2 ifTrue:        ["free block" ^ self].    fmt _ (header >> 8) bitAnd: 16rF.    cc _ (header >> 12) bitAnd: 31.    cc > 15 ifTrue: [self halt].    type = 0 ifTrue:        ["three-word header"        ((self longAt: oop-4) bitAnd: 3) = type ifFalse: [self halt].        ((self longAt: oop-8) bitAnd: 3) = type ifFalse: [self halt].        ((self longAt: oop-4) = type) ifTrue: [self halt].    "Class word is 0"        sz = 0 ifFalse: [self halt]].    type = 1 ifTrue:        ["two-word header"        ((self longAt: oop-4) bitAnd: 3) = type ifFalse: [self halt].        cc > 0 ifTrue: [sz = 1 ifFalse: [self halt]].        sz = 0 ifTrue: [self halt]].    type = 3 ifTrue:        ["one-word header"        cc = 0 ifTrue: [self halt]].    fmt = 4 ifTrue: [self halt].    fmt = 5 ifTrue: [self halt].    fmt = 7 ifTrue: [self halt].    fmt >= 12 ifTrue:        ["CompiledMethod -- check for integer header"        (self isIntegerObject: (self longAt: oop + 4)) ifFalse: [self halt]].! !!InterpreterSimulator methodsFor: 'testing'!validateActiveContext    self validateOopsIn: activeContext.    "debug -- test if messed up"! !!InterpreterSimulator methodsFor: 'testing'!validateOopsIn: object    | fieldPtr limit former header |     "for each oop in me see if it is legal"    fieldPtr _ object + BaseHeaderSize.    "first field"    limit _ object + (self lastPointerOf: object).    "a good field"    [fieldPtr > limit] whileFalse: [        former _ self longAt: fieldPtr.        self validOop: former.        fieldPtr _ fieldPtr + 4].    "class"    header _ self baseHeader: object.    (header bitAnd: 16r1F000 "compact class bits") = 0 ifTrue: [            former _ (self classHeader: object) bitAnd: 16rFFFFFFFC.        self validOop: former].! !!InterpreterSimulator methodsFor: 'testing'!validOop: oop    "halt if invalid active object"    (oop bitAnd: 1) = 1 ifTrue: [^ self].    (oop bitAnd: 3) = 0 ifFalse: [self halt].    oop >= endOfMemory ifTrue: [self halt].    "could test if within the first large freeblock"    (self longAt: oop) = 4 ifTrue: [self halt].    (self headerType: oop) = 2 ifTrue: [self halt].    "free object"! !!InterpreterSimulator methodsFor: 'debug printing'!cr    traceOn ifTrue: [ Transcript cr; endEntry ].! !!InterpreterSimulator methodsFor: 'debug printing'!print: s    traceOn ifTrue: [ Transcript show: s ]! !!InterpreterSimulator methodsFor: 'debug printing'!printChar: aByte    traceOn ifTrue: [ Transcript nextPut: aByte asCharacter ].! !!InterpreterSimulator methodsFor: 'debug printing'!printNum: anInteger    traceOn ifTrue: [ Transcript show: anInteger printString ].! !!InterpreterSimulator methodsFor: 'debug support'!charsOfLong: long    ^ (4 to: 1 by: -1) collect:        [:i | ((long digitAt: i) between: 14 and: 126)                    ifTrue: [(long digitAt: i) asCharacter]                    ifFalse: [$?]]! !!InterpreterSimulator methodsFor: 'debug support'!classAndSelectorOfMethod: meth forReceiver: rcvr    | mClass dict length methodArray |    mClass _ self fetchClassOf: rcvr.    [dict _ self fetchPointer: MessageDictionaryIndex ofObject: mClass.    length _ self fetchWordLengthOf: dict.    methodArray _ self fetchPointer: MethodArrayIndex ofObject: dict.    0 to: length-SelectorStart-1 do:         [:index |         meth = (self fetchPointer: index ofObject: methodArray)             ifTrue: [^ Array                with: mClass                with: (self fetchPointer: index + SelectorStart ofObject: dict)]].    mClass _ self fetchPointer: SuperclassIndex ofObject: mClass.    mClass = nilObj]        whileFalse: [].    ^ Array        with: (self fetchClassOf: rcvr)        with: (self splObj: SelectorDoesNotUnderstand)! !!InterpreterSimulator methodsFor: 'debug support'!compactClassAt: ccIndex    "Index must be between 1 and compactClassArray size. (A zero compact class index in the base header indicate that the class is in the class header word.)"    | classArray |    classArray _ self fetchPointer: CompactClasses ofObject: specialObjectsOop.    ^ self fetchPointer: (ccIndex - 1) ofObject: classArray! !!InterpreterSimulator methodsFor: 'debug support'!dumpHeader: hdr    | cc |    ^ String streamContents:        [:strm |        strm nextPutAll: '<cc=', (cc_ (hdr >> 12) bitAnd: 16r1F) hex.            cc > 0 ifTrue:                [strm nextPutAll: ':' , (self nameOfClass: (self compactClassAt: cc))].            strm nextPutAll: '>'.        strm nextPutAll: '<ft=', ((hdr bitShift: -8) bitAnd: 16rF) hex , '>'.        strm nextPutAll: '<sz=', (hdr bitAnd: 16rFC) hex , '>'.        strm nextPutAll: '<hdr=', (#(big class gcMark short) at: (hdr bitAnd: 3) +1) , '>'.        ]! !!InterpreterSimulator methodsFor: 'debug support'!dumpMethodHeader: hdr    ^ String streamContents:        [:strm |        strm nextPutAll: '<nArgs=', ((hdr >> 25) bitAnd: 16r1F) printString , '>'.        strm nextPutAll: '<nTemps=', ((hdr >> 19) bitAnd: 16r3F) printString , '>'.        strm nextPutAll: '<lgCtxt=', ((hdr >> 18) bitAnd: 16r1) printString , '>'.        strm nextPutAll: '<nLits=', ((hdr >> 10) bitAnd: 16rFF) printString , '>'.        strm nextPutAll: '<prim=', ((hdr >> 1) bitAnd: 16r1FF) printString , '>'.        ]! !!InterpreterSimulator methodsFor: 'debug support'!headerStart: oop    ^ (self extraHeaderBytes: oop) negated! !!InterpreterSimulator methodsFor: 'debug support'!hexDump100: oop    | byteSize val |    ^ String streamContents:        [:strm |        byteSize _ 256.        (self headerStart: oop) to: byteSize by: 4 do:            [:a | val _ self longAt: oop+a.            strm cr; nextPutAll: (oop+a) hex8; space; space;                 nextPutAll: (a<16 ifTrue: [' ', a hex] ifFalse: [a hex]);                 space; space; space; nextPutAll: val hex8;                space; space.            strm nextPutAll: (self charsOfLong: val).            strm space; space; nextPutAll: (oop+a) printString]]! !!InterpreterSimulator methodsFor: 'debug support'!hexDump: oop    | byteSize val |    (self isIntegerObject: oop) ifTrue: [^ self shortPrint: oop].    ^ String streamContents:        [:strm |        byteSize _ 256 min: (self sizeBitsOf: oop)-4.        (self headerStart: oop) to: byteSize by: 4 do:            [:a | val _ self longAt: oop+a.            strm cr; nextPutAll: (a<16 ifTrue: [' ', a hex] ifFalse: [a hex]);                 space; space; space; nextPutAll: val hex8;                space; space.            a=0                ifTrue: [strm nextPutAll: (self dumpHeader: val)]                ifFalse: [strm nextPutAll: (self charsOfLong: val)]]]! !!InterpreterSimulator methodsFor: 'debug support'!longPrint: oop    | lastPtr val lastLong hdrType prevVal |    (self isIntegerObject: oop) ifTrue: [^ self shortPrint: oop].    ^ String streamContents:        [:strm |        lastPtr _ 256 min: (self lastPointerOf: oop).        hdrType _ self headerType: oop.        hdrType = 2 ifTrue: [lastPtr _ 0].        prevVal _ 0.        (self headerStart: oop) to: lastPtr by: 4 do:            [:a | val _ self longAt: oop+a.            (a > 0 and: [(val = prevVal) & (a ~= lastPtr)])            ifTrue:            [prevVal = (self longAt: oop+a-8) ifFalse: [strm cr; nextPutAll: '        ...etc...']]            ifFalse:            [strm cr; nextPutAll: (a<16 ifTrue: [' ', a hex] ifFalse: [a hex]);                 space; space; space; nextPutAll: val hex8; space; space.            a=-8 ifTrue: [strm nextPutAll: 'size = ' , (val - hdrType) hex].            a=-4 ifTrue: [strm nextPutAll: '<' , (self nameOfClass: (val - hdrType)) , '>'].            a=0 ifTrue: [strm cr; tab; nextPutAll: (self dumpHeader: val)].            a>0 ifTrue: [strm nextPutAll: (self shortPrint: val)].            a=4 ifTrue: [(self fetchClassOf: oop) = (self splObj: ClassCompiledMethod) ifTrue:                            [strm cr; tab; nextPutAll: (self dumpMethodHeader: val)]]].            prevVal _ val].        lastLong _ 256 min: (self sizeBitsOf: oop) - 4.        hdrType = 2            ifTrue: ["free" strm cr; nextPutAll: (oop+(self longAt: oop)-2) hex;                space; space; nextPutAll: (oop+(self longAt: oop)-2) printString]            ifFalse: [lastPtr+4 to: lastLong by: 4 do:                [:a | val _ self longAt: oop+a.                strm cr; nextPutAll: (a<16 ifTrue: [' ', a hex] ifFalse: [a hex]);                     space; space; space.                strm nextPutAll: val hex8; space; space;                        nextPutAll: (self charsOfLong: val)]].    ]! !!InterpreterSimulator methodsFor: 'debug support'!nameOfClass: classOop    (self sizeBitsOf: classOop) = 16r20 ifTrue:        [^ (self nameOfClass:                (self fetchPointer: 6 "thisClass" ofObject: classOop)) , ' class'].    ^ self stringOf: (self fetchPointer: 6 "name" ofObject: classOop)! !!InterpreterSimulator methodsFor: 'debug support'!printStack    | ctxt classAndSel home |    ctxt _ activeContext.    ^ String streamContents:        [:strm |            [home _ (self fetchClassOf: ctxt) = (self splObj: ClassBlockContext)                ifTrue: [self fetchPointer: HomeIndex ofObject: ctxt]                ifFalse: [ctxt].            classAndSel _ self                classAndSelectorOfMethod: (self fetchPointer: MethodIndex ofObject: home)                forReceiver: (self fetchPointer: ReceiverIndex ofObject: home).            strm cr; nextPutAll: ctxt hex8.            ctxt = home ifFalse: [strm nextPutAll: ' [] in'].            strm space; nextPutAll: (self nameOfClass: classAndSel first).            strm nextPutAll: '>>'; nextPutAll: (self shortPrint: classAndSel last).            (ctxt _ (self fetchPointer: SenderIndex ofObject: ctxt)) = nilObj]                whileFalse: [].        ]! !!InterpreterSimulator methodsFor: 'debug support'!shortPrint: oop    | name classOop |    (self isIntegerObject: oop) ifTrue: [^ '=' , (self integerValueOf: oop) printString , ' (' , (self integerValueOf: oop) hex , ')'].    classOop _ self fetchClassOf: oop.    (self sizeBitsOf: classOop) =16r20 ifTrue: [^ 'class ' , (self nameOfClass: oop)].    name _ self nameOfClass: classOop.    name size = 0 ifTrue: [name _ '??'].    name = 'String' ifTrue: [^ (self stringOf: oop) printString].    name = 'Symbol' ifTrue: [^ '#' , (self stringOf: oop)].    name = 'Character' ifTrue: [^ '=' ,            (Character value: (self integerValueOf: (self fetchPointer: 0 ofObject: oop))) printString].    name = 'UndefinedObject' ifTrue: [^ 'nil'].    name = 'False' ifTrue: [^ 'false'].    name = 'True' ifTrue: [^ 'true'].    name = 'Float' ifTrue: [^ '=' , (self floatValueOf: oop) printString].    name = 'Association' ifTrue: [^ '(' ,                (self shortPrint: (self longAt: oop + BaseHeaderSize)) ,                ' -> ' ,                (self longAt: oop + BaseHeaderSize + 4) hex8 , ')'].    ('AEIOU' includes: name first)        ifTrue: [^ 'an ' , name]        ifFalse: [^ 'a ' , name]! !!InterpreterSimulator methodsFor: 'debug support'!stringOf: oop    | size long nLongs chars |    ^ String streamContents:        [:strm |        size _ 100 min: (self stSizeOf: oop).        nLongs _ size-1//4+1.        1 to: nLongs do:            [:i | long _ self longAt: oop + BaseHeaderSize + (i-1*4).            chars _ self charsOfLong: long.            strm nextPutAll: (i=nLongs                            ifTrue: [chars copyFrom: 1 to: size-1\\4+1]                            ifFalse: [chars])]]! !!InterpreterSimulator methodsFor: 'interpreter shell'!dispatchOn: anInteger in: selectorArray    "Simulate a case statement via selector table lookup.    The given integer must be between 0 and selectorArray size-1, inclusive.    For speed, no range test is done, since it is done by the at: operation."    "assert: (anInteger >= 0) | (anInteger < selectorArray size)""Transcript cr; show: anInteger hex , '  ' , (selectorArray at: (anInteger + 1)).Sensor waitButton.Sensor yellowButtonPressed ifTrue: [self halt]."    self perform: (selectorArray at: (anInteger + 1)).! !!InterpreterSimulator methodsFor: 'interpreter shell'!fetchByte    ^ self byteAt: (localIP _ localIP + 1).! !!InterpreterSimulator methodsFor: 'interpreter shell'!fetchIntegerOrTruncFloat: fieldIndex ofObject: objectPointer    "Overridden to support the simulator."    | intOrFloat |    intOrFloat _ self fetchPointer: fieldIndex ofObject: objectPointer.    (self isIntegerObject: intOrFloat) ifTrue: [^ self integerValueOf: intOrFloat].    self assertClassOf: intOrFloat is: (self splObj: ClassFloat).    successFlag ifTrue: [^ (self floatValueOf: intOrFloat) truncated].! !!InterpreterSimulator methodsFor: 'interpreter shell'!isIntegerValue: valueWord     ^ valueWord >= 16r-40000000 and: [valueWord <= 16r3FFFFFFF]! !!InterpreterSimulator methodsFor: 'I/O primitives'!ioProcessEvents! !!InterpreterSimulator methodsFor: 'I/O primitives'!primitiveBeCursor    "Take note of the current cursor"    | cursorObj bitsObj offsetObj ourCursor |    cursorObj _ self stackTop.    self success: ((self isPointers: cursorObj) and: [(self lengthOf: cursorObj) >= 4]).    successFlag ifTrue:        [bitsObj _ self fetchPointer: 0 ofObject: cursorObj.        offsetObj _ self fetchPointer: 4 ofObject: cursorObj.        ourCursor _ Cursor            extent: (self fetchInteger: 1 ofObject: cursorObj)@(self fetchInteger: 2 ofObject: cursorObj)            fromArray: ((1 to: 16) collect: [:i |                    ((self fetchWord: i-1 ofObject: bitsObj) >> 16) bitAnd: 16rFFFF])            offset: (self fetchInteger: 0 ofObject: offsetObj)@(self fetchInteger: 1 ofObject: offsetObj)].    successFlag        ifTrue: [ourCursor show]        ifFalse: [self primitiveFail].! !!InterpreterSimulator methodsFor: 'I/O primitives'!primitiveBeDisplay    "Extended to create a scratch Form for use by showDisplayBits."    | rcvr destWidth destHeight destDepth |    rcvr _ self stackTop.    self success: ((self isPointers: rcvr) and: [(self lengthOf: rcvr) >= 4]).    successFlag ifTrue: [        destWidth _ self fetchInteger: 1 ofObject: rcvr.        destHeight _ self fetchInteger: 2 ofObject: rcvr.        destDepth _ self fetchInteger: 3 ofObject: rcvr.    ].    successFlag ifTrue: [        "create a scratch form the same size as Smalltalk displayObj"        displayForm _ Form extent: destWidth @ destHeight                            depth: destDepth.    ].    super primitiveBeDisplay.! !!InterpreterSimulator methodsFor: 'I/O primitives' stamp: 'di 9/23/97 12:54'!primitiveKbdNext    self pop: 1.    Sensor keyboardPressed        ifTrue: [self pushInteger: Sensor primKbdNext]        ifFalse: [self push: nilObj]! !!InterpreterSimulator methodsFor: 'I/O primitives' stamp: 'di 9/23/97 12:54'!primitiveKbdPeek    self pop: 1.    Sensor keyboardPressed        ifTrue: [self pushInteger: Sensor primKbdPeek]        ifFalse: [self push: nilObj]! !!InterpreterSimulator methodsFor: 'I/O primitives' stamp: 'di 9/23/97 12:54'!primitiveMouseButtons    | buttons |    self pop: 1.    buttons _ Sensor primMouseButtons.    self pushInteger: buttons! !!InterpreterSimulator methodsFor: 'I/O primitives'!primitiveMousePoint    | relPt |    self pop: 1.    displayForm == nil        ifTrue: [self push: (self makePointwithxValue: 99 yValue: 66)]        ifFalse: [relPt _ Sensor cursorPoint - (Display extent - displayForm extent - (10@10)).                self push: (self makePointwithxValue: relPt x yValue: relPt y)]! !!InterpreterSimulator methodsFor: 'I/O primitives'!primitiveScreenSize  "Dummied for now"    self pop: 1.    self push: (self makePointwithxValue: 640 yValue: 480).! !!InterpreterSimulator methodsFor: 'I/O primitives' stamp: 'di 9/23/97 15:26'!showDisplayBits    | displayObj destBits raster destDepth pixPerWord simDisp realDisp top bottom rect |    displayObj _ self splObj: TheDisplay.    self targetForm = displayObj ifFalse: [^ self].    destBits _ self fetchPointer: 0 ofObject: displayObj.    destDepth _ self fetchInteger: 3 ofObject: displayObj.    pixPerWord _ 32 // destDepth.    raster _ displayForm width + (pixPerWord - 1) // pixPerWord.    simDisp _ Form new hackBits: memory.    realDisp _ Form new hackBits: displayForm bits.    top _ myBitBlt affectedTop.    bottom _ myBitBlt affectedBottom.    realDisp        copy: (0 @ (top * raster) extent: 4 @ (bottom - top * raster))        from: 0 @ (destBits + 4 // 4 + (top * raster))        in: simDisp        rule: Form over.    rect _ 0 @ top corner: displayForm width @ bottom.    Display        copy: (rect translateBy: self displayLocation)        from: rect topLeft        in: displayForm        rule: Form over! !!InterpreterSimulator methodsFor: 'I/O primitives support'!copyBits    ^ myBitBlt copyBits! !!InterpreterSimulator methodsFor: 'I/O primitives support'!displayLocation    ^ Display extent - displayForm extent - (10@10)! !!InterpreterSimulator methodsFor: 'I/O primitives support'!drawLoopX: xDelta Y: yDelta    ^ myBitBlt drawLoopX: xDelta Y: yDelta! !!InterpreterSimulator methodsFor: 'I/O primitives support' stamp: 'di 9/20/97 23:22'!ioMicroMSecs    "Return the value of the microsecond clock (dummied here)."    ^ 0! !!InterpreterSimulator methodsFor: 'I/O primitives support'!ioMSecs    "Return the value of the millisecond clock."    ^ Time millisecondClockValue! !!InterpreterSimulator methodsFor: 'I/O primitives support'!ioProcessEventsEveryMSecs: mSecs    "Noop during simulation."! !!InterpreterSimulator methodsFor: 'I/O primitives support' stamp: 'di 9/8/97 09:40'!ioScreenSize    "Return the screen extent packed into 32 bits."    ^ (displayForm width << 16) + displayForm height! !!InterpreterSimulator methodsFor: 'I/O primitives support' stamp: 'di 9/8/97 09:35'!ioSeconds    "Return the value of the second clock."    ^ Time primSecondsClock! !!InterpreterSimulator methodsFor: 'I/O primitives support'!loadBitBltFrom: bbObj    ^ myBitBlt loadBitBltFrom: bbObj! !!InterpreterSimulator methodsFor: 'I/O primitives support'!loadScannerFrom: bbObj    start: start stop: stop string: string rightX: rightX    stopArray: stopArray displayFlag: displayFlag    ^ myBitBlt loadScannerFrom: bbObj        start: start stop: stop string: string rightX: rightX        stopArray: stopArray displayFlag: displayFlag! !!InterpreterSimulator methodsFor: 'I/O primitives support' stamp: 'di 9/21/97 21:57'!primitiveRelinquishProcessor    "No-op in simulator"    ^ self! !!InterpreterSimulator methodsFor: 'I/O primitives support'!scanCharacters    ^ myBitBlt scanCharacters! !!InterpreterSimulator methodsFor: 'I/O primitives support'!stopReason    ^ myBitBlt stopReason! !!InterpreterSimulator methodsFor: 'I/O primitives support'!targetForm    ^ myBitBlt targetForm! !!InterpreterSimulator methodsFor: 'file primitives'!asciiDirectoryDelimiter    ^ FileDirectory pathNameDelimiter asciiValue! !!InterpreterSimulator methodsFor: 'file primitives'!fileValueOf: integerPointer    "Convert the (integer) fileID to the actual fileStream it uses"    self success: (self isIntegerObject: integerPointer).    successFlag        ifTrue: [^ filesOpen at: (self integerValueOf: integerPointer)]        ifFalse: [^ nil]! !!InterpreterSimulator methodsFor: 'file primitives'!primitiveFileDelete    | namePointer |    namePointer _ self stackTop.    self success: (self isBytes: namePointer).    self success: (FileDirectory includesKey: (self stringOf: namePointer)).    successFlag ifTrue: [        FileDirectory removeKey: (self stringOf: namePointer) ifAbsent: [].    ].    successFlag ifTrue: [        self pop: 1.  "fileName; leave rcvr on stack"    ].! !!InterpreterSimulator methodsFor: 'file primitives'!primitiveFileOpen    | namePointer writeFlag fileName |    writeFlag _ self booleanValueOf: self stackTop.    namePointer _ self stackValue: 1.    self success: (self isBytes: namePointer).    successFlag ifTrue:        [fileName _ self stringOf: namePointer.        filesOpen addLast: (writeFlag            ifTrue: [(FileStream fileNamed: fileName) binary]            ifFalse: [(FileDirectory default includesKey: fileName)                ifTrue: [(FileStream oldFileNamed: fileName) readOnly; binary]                ifFalse: [^ self primitiveFail]]).        self pop: 3.  "rcvr, name, write"        self pushInteger: filesOpen size]! !!InterpreterSimulator methodsFor: 'file primitives'!primitiveFileRename    | oldNamePointer newNamePointer f |    oldNamePointer _ self stackTop.    newNamePointer _ self stackValue: 1.    self success: (self isBytes: oldNamePointer).    self success: (self isBytes: newNamePointer).    self success: (FileDirectory includesKey: (self stringOf: oldNamePointer)).    self success: (FileDirectory includesKey: (self stringOf: newNamePointer)) not.    successFlag ifTrue: [        f _ FileStream oldFileNamed: (self stringOf: oldNamePointer).        f rename: (self stringOf: newNamePointer).        f close.    ].    successFlag ifTrue: [        self pop: 2.  "oldName, newName; leave rcvr on stack"    ].! !!InterpreterSimulator methodsFor: 'file primitives'!primitiveImageName    "Note: For now, this only implements getting, not setting, the image file name."    | result imageNameSize |    self pop: 1.    imageNameSize _ imageName size.    result _ self instantiateClass: (self splObj: ClassString)                   indexableSize: imageNameSize.    1 to: imageNameSize do:        [:i | self storeByte: i-1 ofObject: result            withValue: (imageName at: i) asciiValue].    self push: result.! !!InterpreterSimulator methodsFor: 'file primitives'!sqFile: file Read: count Into: byteArrayIndex At: startIndex    startIndex to: (startIndex + count - 1) do: [ :i |        file atEnd ifTrue: [ ^ i - startIndex ].        self byteAt: byteArrayIndex + i put: file next.    ].    ^ count! !!InterpreterSimulator methodsFor: 'file primitives'!sqFile: file SetPosition: newPosition    file position: newPosition.! !!InterpreterSimulator methodsFor: 'file primitives'!sqFile: file Write: count From: byteArrayIndex At: startIndex    startIndex to: (startIndex + count - 1) do: [ :i |        file nextPut: (self byteAt: byteArrayIndex + i).    ].    ^ count! !!InterpreterSimulator methodsFor: 'file primitives'!sqFileAtEnd: file    ^ file atEnd! !!InterpreterSimulator methodsFor: 'file primitives'!sqFileClose: file    file close.! !!InterpreterSimulator methodsFor: 'file primitives'!sqFileGetPosition: file    ^ file position! !!InterpreterSimulator methodsFor: 'file primitives'!sqFileSize: file    ^ file size! !!InterpreterSimulator methodsFor: 'file primitives'!vmPathGet: stringBase Length: stringSize    | pathName stringOop |    pathName _ Smalltalk vmPath.    stringOop _ stringBase - BaseHeaderSize. "Due to C call in Interp"    1 to: stringSize do:        [:i | self storeByte: i-1 ofObject: stringOop            withValue: (pathName at: i) asciiValue].! !!InterpreterSimulator methodsFor: 'file primitives'!vmPathSize    ^ Smalltalk vmPath size! !!InterpreterSimulator methodsFor: 'float primitives'!floatObjectOf: float    | result sign exponent mantissa mantSize long0 long1 |true ifTrue: [    "No conversion needed in Apple ST"    long0 _ float at: 1.    long1 _ float at: 2.] ifFalse: ["Following code useful when porting to different formats"    ((float at: 1) = 0 and: [(float at: 2) = 0])        ifTrue: [long0 _ 0. long1 _ 0]        ifFalse:     ["Read from the PPS 32-bit format"    sign _ ((float at: 1) bitAnd: 16r8000) bitShift: -15.                "1-bit sign"    exponent _ (((float at: 1) bitShift: -7) bitAnd: 16rFF) - 16r80.         "8-bit expt"    mantissa _ (((float at: 1) bitAnd: 16r7F) bitShift: 16) + (float at: 2).    "23 bit mantissa"    mantSize _ 23.    "Convert to first 32 bits of 64-bit IEEE format"    long0 _ (sign bitShift: 31)                                        "1-bit sign"            + (exponent + 16r400 bitShift: 20)                        "11-bit expt"            + ((mantissa bitShift: 20 - mantSize) bitAnd: 16rFFFFF).    "20 bit mantissa"    ]. ]. "end of porting code"    result _ self instantiateClass: (self splObj: ClassFloat) indexableSize: 2.    self storeWord: 0 ofObject: result withValue: long0.    self storeWord: 1 ofObject: result withValue: long1.    ^ result! !!InterpreterSimulator methodsFor: 'float primitives'!floatValueOf: objectPointer    | float len long0 long1 sign exponent mantissa mantSize |    (self isIntegerObject: objectPointer)        ifTrue: [^ (self integerValueOf: objectPointer) asFloat].    (self fetchClassOf: objectPointer) = (self splObj: ClassFloat)        ifFalse: [self success: false.  ^0.0].    len _ self fetchWordLengthOf: objectPointer.    (len between: 2 and: 3)        ifFalse: [self success: false.  ^0.0].    "FIRST convert image formats to sign/exponent/mantissa"    len = 2 ifTrue:          ["Normal 64-bit IEEE format"        long0 _ self fetchWord: 0 ofObject: objectPointer.        long1 _ self fetchWord: 1 ofObject: objectPointer.true ifTrue: [float _ Float new: 2.  "No conversion needed for AST"            float at: 1 put: long0.            float at: 2 put: long1.            ^ float].        long0 = 0 ifTrue: [^ 0.0].        sign _ (long0 bitAnd: 16r80000000) bitShift: -31.                "1-bit sign"        exponent _ ((long0 bitShift: -20) bitAnd: 16r7FF) - 16r400.        "11-bit exponent"        mantissa _ ((long0 bitAnd: 16rFFFFF) bitShift: 32) + long1.        "52-bit mantissa"        mantSize _ 52]        ifFalse:          ["Weird 80-bit Apple format -- will go away soon"        long0 _ self fetchWord: 0 ofObject: objectPointer.        long1 _ self fetchWord: 1 ofObject: objectPointer.        long0 = 0 ifTrue: [^ 0.0].        sign _ (long0 bitAnd: 16r80000000) bitShift: -31.                "1-bit sign"        exponent _ ((long0 bitShift: -16) bitAnd: 16r7FFF) - 16r4000.     "15-bit exponent"        "Note: drop the (redundant) high bit (16r8000) of mantissa"        mantissa _ ((long0 bitAnd: 16r7FFF) bitShift: 32) + long1.        "47-bit mantissa"        mantSize _ 47].    "THEN convert sign/exponent/mantissa to host format"    float _ Float new: 2.  "PPSST FP uses 2 16-bit words"    float at: 1 put: (sign bitShift: 15)                            "1-bit sign"                + (exponent + 16r80 bitShift: 7)                "8-bit expt"                + ((mantissa bitShift: 7 - mantSize) bitAnd: 16r7F).    "7 bits of mantissa"    float at: 2 put: ((mantissa bitShift: 16 - (mantSize - 7)) bitAnd: 16rFFFF).  "16 more bits of mantissa"    ^ float! !!InterpreterSimulator methodsFor: 'float primitives'!popFloat    ^ self floatValueOf: (self popStack)! !!InterpreterSimulator methodsFor: 'float primitives' stamp: 'ikp 8/8/97 14:46'!popFloatOnly    | number |    (self isIntegerObject: (number _ self popStack)) ifTrue: [        self success: false.        ^0.0.    ].    ^ self floatValueOf: number! !!InterpreterSimulator methodsFor: 'float primitives'!primitiveArctan    "Use host Smalltalk's native function."    | rcvr |    rcvr _ self popFloat.    successFlag        ifTrue: [self pushFloat: rcvr arcTan]        ifFalse: [self unPop: 1].! !!InterpreterSimulator methodsFor: 'float primitives'!primitiveAsFloat    "Use host Smalltalk's native function."    | arg |    arg _ self popInteger.    successFlag        ifTrue: [self pushFloat: arg asFloat]        ifFalse: [self unPop: 1].! !!InterpreterSimulator methodsFor: 'float primitives'!primitiveExp    "Use host Smalltalk's native function."    | rcvr |    rcvr _ self popFloat.    successFlag        ifTrue: [self pushFloat: rcvr exp]        ifFalse: [self unPop: 1].! !!InterpreterSimulator methodsFor: 'float primitives'!primitiveExponent    "Use host Smalltalk's native function."    | rcvr |    rcvr _ self popFloat.    successFlag        ifTrue: [self pushInteger: rcvr exponent]        ifFalse: [self unPop: 1].! !!InterpreterSimulator methodsFor: 'float primitives' stamp: 'ikp 8/8/97 14:42'!primitiveFloatAdd    "Use host Smalltalk's native function."    | rcvr arg |    arg _ self popFloatOnly.    rcvr _ self popFloatOnly.    successFlag        ifTrue: [self pushFloat: rcvr + arg]        ifFalse: [self unPop: 2].! !!InterpreterSimulator methodsFor: 'float primitives' stamp: 'ikp 8/8/97 14:43'!primitiveFloatDivide    "Note: This method overridden here because the translator (intentionally) doesn't translate the / operator (since the semantics of C / are the semantics of Smalltalk //). This allows the version of this method to be translated to express division as //, which translates to the float division operator /."    | rcvr arg |    arg _ self popFloatOnly.    rcvr _ self popFloatOnly.    successFlag ifTrue: [self success: arg ~= 0.0].    successFlag        ifTrue: [self pushFloat: rcvr / arg]        ifFalse: [self unPop: 2].! !!InterpreterSimulator methodsFor: 'float primitives' stamp: 'ikp 8/8/97 14:44'!primitiveFloatEqual    "Use host Smalltalk's native function."    | rcvr arg |    arg _ self popFloat.    rcvr _ self popFloat.    successFlag        ifTrue: [self pushBool: rcvr = arg]        ifFalse: [self unPop: 2].! !!InterpreterSimulator methodsFor: 'float primitives' stamp: 'ikp 8/8/97 14:44'!primitiveFloatGreaterOrEqual    "Use host Smalltalk's native function."    | rcvr arg |    arg _ self popFloat.    rcvr _ self popFloat.    successFlag        ifTrue: [self pushBool: rcvr >= arg]        ifFalse: [self unPop: 2].! !!InterpreterSimulator methodsFor: 'float primitives' stamp: 'ikp 8/8/97 14:43'!primitiveFloatGreaterThan    "Use host Smalltalk's native function."    | rcvr arg |    arg _ self popFloat.    rcvr _ self popFloat.    successFlag        ifTrue: [self pushBool: rcvr > arg]        ifFalse: [self unPop: 2].! !!InterpreterSimulator methodsFor: 'float primitives'!primitiveFloatLessOrEqual    "Use host Smalltalk's native function."    | rcvr arg |    arg _ self popFloat.    rcvr _ self popFloat.    successFlag        ifTrue: [self pushBool: rcvr <= arg]        ifFalse: [self unPop: 2].! !!InterpreterSimulator methodsFor: 'float primitives'!primitiveFloatLessThan    "Use host Smalltalk's native function."    | rcvr arg |    arg _ self popFloat.    rcvr _ self popFloat.    successFlag        ifTrue: [self pushBool: rcvr < arg]        ifFalse: [self unPop: 2].! !!InterpreterSimulator methodsFor: 'float primitives' stamp: 'ikp 8/8/97 14:44'!primitiveFloatMultiply    "Use host Smalltalk's native function."    | rcvr arg |    arg _ self popFloatOnly.    rcvr _ self popFloatOnly.    successFlag        ifTrue: [self pushFloat: rcvr * arg]        ifFalse: [self unPop: 2].! !!InterpreterSimulator methodsFor: 'float primitives'!primitiveFloatNotEqual    "Use host Smalltalk's native function."    | rcvr arg |    arg _ self popFloat.    rcvr _ self popFloat.    successFlag        ifTrue: [self pushBool: rcvr ~= arg]        ifFalse: [self unPop: 2].! !!InterpreterSimulator methodsFor: 'float primitives' stamp: 'ikp 8/8/97 14:44'!primitiveFloatSubtract    "Use host Smalltalk's native function."    | rcvr arg |    arg _ self popFloatOnly.    rcvr _ self popFloatOnly.    successFlag        ifTrue: [self pushFloat: rcvr - arg]        ifFalse: [self unPop: 2].! !!InterpreterSimulator methodsFor: 'float primitives' stamp: 'ikp 8/8/97 14:45'!primitiveFractionalPart    "Use host Smalltalk's native function."    | rcvr |    rcvr _ self popFloatOnly.    successFlag        ifTrue: [self pushFloat: rcvr fractionPart]        ifFalse: [self unPop: 1].! !!InterpreterSimulator methodsFor: 'float primitives'!primitiveLogN    "Use host Smalltalk's native function."    | rcvr |    rcvr _ self popFloat.    successFlag        ifTrue: [self pushFloat: rcvr ln]        ifFalse: [self unPop: 1].! !!InterpreterSimulator methodsFor: 'float primitives'!primitiveSine    "Use host Smalltalk's native function."    | rcvr |    rcvr _ self popFloat.    successFlag        ifTrue: [self pushFloat: rcvr sin]        ifFalse: [self unPop: 1].! !!InterpreterSimulator methodsFor: 'float primitives'!primitiveSquareRoot    "Use host Smalltalk's native function."    | rcvr |    rcvr _ self popFloat.    successFlag        ifTrue: [self pushFloat: rcvr sqrt]        ifFalse: [self unPop: 1].! !!InterpreterSimulator methodsFor: 'float primitives'!primitiveTimesTwoPower    "Use Smalltalk's native function (tho could just fail)"    | rcvr arg |    arg _ self popInteger.    rcvr _ self popFloat.    successFlag        ifTrue: [ self pushFloat: (rcvr timesTwoPower: arg) ]        ifFalse: [ self unPop: 2 ].! !!InterpreterSimulator methodsFor: 'float primitives'!primitiveTruncated    "Use host Smalltalk's native function."    | rcvr |    rcvr _ self popFloat.    successFlag        ifTrue: [self pushInteger: rcvr truncated]        ifFalse: [self unPop: 1].! !!InterpreterSimulator methodsFor: 'float primitives'!pushFloat: f    self push: (self floatObjectOf: f).! !!InterpreterSimulator methodsFor: 'memory access'!byteAt: byteAddress    | lowBits |    lowBits _ byteAddress bitAnd: 3.    ^((self longAt: byteAddress - lowBits)        bitShift: (lowBits - 3) * 8)        bitAnd: 16rFF! !!InterpreterSimulator methodsFor: 'memory access'!byteAt: byteAddress put: byte    | longWord shift lowBits |    lowBits _ byteAddress bitAnd: 3.    longWord _ self longAt: byteAddress - lowBits.    shift _ (3 - lowBits) * 8.    longWord _ longWord - (longWord bitAnd: (16rFF bitShift: shift)) + (byte bitShift: shift).    self longAt: byteAddress put: longWord! !!InterpreterSimulator methodsFor: 'memory access'!longAt: byteAddress    "Note: Adjusted for Smalltalk's 1-based array indexing."    ^memory at: (byteAddress // 4) + 1! !!InterpreterSimulator methodsFor: 'memory access'!longAt: byteAddress put: a32BitValue    "Note: Adjusted for Smalltalk's 1-based array indexing."    ^memory at: (byteAddress // 4) + 1 put: a32BitValue! !!InterpreterSimulator methodsFor: 'arithmetic'!bytecodePrimGreaterOrEqual    "Must be overridden from Interpreter because simulator doesn't have        32-bit signed ints to work with"    | rcvr arg |    rcvr _ self internalStackValue: 1.    arg _ self internalStackValue: 0.    (self areIntegers: rcvr and: arg)        ifTrue: [ ^ self booleanCheat:            (self integerValueOf: rcvr) >= (self integerValueOf: arg)].    ^ super bytecodePrimGreaterOrEqual! !!InterpreterSimulator methodsFor: 'arithmetic'!bytecodePrimGreaterThan    "Must be overridden from Interpreter because simulator doesn't have        32-bit signed ints to work with"    | rcvr arg |    rcvr _ self internalStackValue: 1.    arg _ self internalStackValue: 0.    (self areIntegers: rcvr and: arg)        ifTrue: [ ^ self booleanCheat:            (self integerValueOf: rcvr) > (self integerValueOf: arg)].    ^ super bytecodePrimGreaterThan! !!InterpreterSimulator methodsFor: 'arithmetic'!bytecodePrimLessOrEqual    "Must be overridden from Interpreter because simulator doesn't have        32-bit signed ints to work with"    | rcvr arg |    rcvr _ self internalStackValue: 1.    arg _ self internalStackValue: 0.    (self areIntegers: rcvr and: arg)        ifTrue: [ ^ self booleanCheat:            (self integerValueOf: rcvr) <= (self integerValueOf: arg)].    ^ super bytecodePrimLessOrEqual! !!InterpreterSimulator methodsFor: 'arithmetic'!bytecodePrimLessThan    "Must be overridden from Interpreter because simulator doesn't have        32-bit signed ints to work with"    | rcvr arg |    rcvr _ self internalStackValue: 1.    arg _ self internalStackValue: 0.    (self areIntegers: rcvr and: arg)        ifTrue: [ ^ self booleanCheat:            (self integerValueOf: rcvr) < (self integerValueOf: arg)].    ^ super bytecodePrimLessThan! !!InterpreterSimulator methodsFor: 'other primitives' stamp: 'tao 9/29/97 16:29'!primitiveGetAttribute    "return nil as if attribute isn't defined"        self pop: 2.  "rcvr, attr"        self push: (self splObj: NilObject).! !InterpreterSupportCode comment:'This class is a shell that includes all the ancillary C code for supporting Squeak in the Macintosh operating environment.  Executing    InterpreterSupportCode writeMacSourceFileswill cause the creation of a number of files in your working directory which, together with the one large interpreter file (see CCodeGenerator) should be adequate to compile a complete running interpreter.'!!InterpreterSupportCode class methodsFor: 'source file exporting'!archiveBinaryFileBytes    "Convert the binary archive date into a ByteArray."    | data b |    data _ self archiveBinaryFile.    b _ ByteArray new: data size.    1 to: data size do: [ :i | b at: i put: (data at: i)].    ^ b! !!InterpreterSupportCode class methodsFor: 'source file exporting'!compareWithFilesInFolder: folderName    "InterpreterSupportCode compareWithFilesInFolder: ''"    (FileStream readOnlyFileNamed: 'projectArchive.sit') binary contentsOfEntireFile =    InterpreterSupportCode archiveBinaryFileBytes        ifFalse: [ self inform: 'File projectArchive.sit differs from the version stored in this image.' ].    (FileStream readOnlyFileNamed: 'readme') contentsOfEntireFile =    InterpreterSupportCode readmeFile        ifFalse: [ self inform: 'File readme differs from the version stored in this image.' ].    (FileStream readOnlyFileNamed: 'sq.h') contentsOfEntireFile =    InterpreterSupportCode squeakHeaderFile        ifFalse: [ self inform: 'File sq.h differs from the version stored in this image.' ].    (FileStream readOnlyFileNamed: 'sqFilePrims.c') contentsOfEntireFile =    InterpreterSupportCode filePrimsFile        ifFalse: [ self inform: 'File sqFilePrims.c differs from the version stored in this image.' ].    (FileStream readOnlyFileNamed: 'sqMacDirectory.c') contentsOfEntireFile =    InterpreterSupportCode macDirectoryFile        ifFalse: [ self inform: 'File sqMacDirectory.c differs from the version stored in this image.' ].    (FileStream readOnlyFileNamed: 'sqMacJoystick.c') contentsOfEntireFile =    InterpreterSupportCode macJoystickFile        ifFalse: [ self inform: 'File sqMacJoystick.c differs from the version stored in this image.' ].    (FileStream readOnlyFileNamed: 'sqMacNetwork.c') contentsOfEntireFile =    InterpreterSupportCode macNetworkFile        ifFalse: [ self inform: 'File sqMacNetwork.c differs from the version stored in this image.' ].    (FileStream readOnlyFileNamed: 'sqMacSound.c') contentsOfEntireFile =    InterpreterSupportCode macSoundFile        ifFalse: [ self inform: 'File sqMacSound.c differs from the version stored in this image.' ].    (FileStream readOnlyFileNamed: 'sqMacWindow.c') contentsOfEntireFile =    InterpreterSupportCode macWindowFile        ifFalse: [ self inform: 'File sqMacWindow.c differs from the version stored in this image.' ].    (FileStream readOnlyFileNamed: 'MacTCP.h') contentsOfEntireFile =    InterpreterSupportCode macTCPFile        ifFalse: [ self inform: 'File MacTCP.h differs from the version stored in this image.' ].    (FileStream readOnlyFileNamed: 'AddressXlation.h') contentsOfEntireFile =    InterpreterSupportCode addressXlationFile        ifFalse: [ self inform: 'File AddressXlation.h differs from the version stored in this image.' ].    (FileStream readOnlyFileNamed: 'dnr.c') contentsOfEntireFile =    InterpreterSupportCode dnrFile        ifFalse: [ self inform: 'File dnr.c differs from the version stored in this image.' ].! !!InterpreterSupportCode class methodsFor: 'source file exporting'!storeProjectArchiveOnFileNamed: fileName    "Store into this image's folder a StuffIt archive file containing the CodeWarrier project files for the virtual machine. You will need to use a StuffIt unpacking utility such as StuffIt Expander to unpack the file. The result will be two project files for CodeWarrier, version 8."    | f |    f _ (FileStream newFileNamed: fileName) binary.    self archiveBinaryFile do: [ :byte | f nextPut: byte ].    f close.    FileDirectory default class setMacFileNamed: fileName type: 'SITD' creator: 'SIT!!'.! !!InterpreterSupportCode class methodsFor: 'source file exporting'!storeString: s onFileNamed: fileName    "Store the given string in a file of the given name."    | f |    f _ FileStream newFileNamed: fileName.    f nextPutAll: s.    f close.! !!InterpreterSupportCode class methodsFor: 'source file exporting'!writeMacSourceFiles    "Store into this image's folder the C sources files required to support the interpreter on the Macintosh. It also generates the code for the sound synthesis primitives. However, because generating code for the interpreter itself takes several minutes, that is not done automatically by this method. To generate that code, use the method 'translate:doInlining:' in Interpreter class."    "InterpreterSupportCode writeMacSourceFiles"    self storeString: self readmeFile            onFileNamed: 'readme'.    self storeString: self squeakHeaderFile    onFileNamed: 'sq.h'.    self storeString: self filePrimsFile        onFileNamed: 'sqFilePrims.c'.    self storeString: self macDirectoryFile    onFileNamed: 'sqMacDirectory.c'.    self storeString: self macJoystickFile        onFileNamed: 'sqMacJoystick.c'.    self storeString: self macNetworkFile        onFileNamed: 'sqMacNetwork.c'.    self storeString: self macSoundFile        onFileNamed: 'sqMacSound.c'.    self storeString: self macWindowFile        onFileNamed: 'sqMacWindow.c'.    self storeString: self macTCPFile            onFileNamed: 'MacTCP.h'.    self storeString: self addressXlationFile    onFileNamed: 'AddressXlation.h'.    self storeString: self dnrFile                onFileNamed: 'dnr.c'.    self storeProjectArchiveOnFileNamed: 'projectArchive.sit'.    self storeString: AbstractSound cCodeForSoundPrimitives                                            onFileNamed: 'sqSoundPrims.c'.    Smalltalk cleanOutUndeclared  "Right now this leaves junk in Undeclared"! !!InterpreterSupportCode class methodsFor: 'source files'!addressXlationFile    ^ '/*     File:        AddressXlation.h      Contains:    TCP Manager interfaces for dnr.c      Version:    Use with MacTCP 2.0.6 and Universal Interfaces 2.1b1                    in ╥MPW Prerelease╙ on ETO #17      Copyright:    ⌐ 1984-1995 by Apple Computer, Inc.                 All rights reserved.      Bugs?:        If you find a problem with this file, send the file and version                 information (from above) and the problem description to:                      Internet:    [e-mail]                     AppleLink:    APPLE.BUGS */#ifndef __ADDRESSXLATION__#define __ADDRESSXLATION__#ifndef __TYPES__#include <Types.h>#endif/*    #include <ConditionalMacros.h>                                */#ifndef __MACTCP__#include <MacTCP.h>#endif/*    #include <AppleTalk.h>                                        *//*        #include <OSUtils.h>                                    *//*            #include <MixedMode.h>                                *//*            #include <Memory.h>                                    */#ifdef __cplusplusextern "C" {#endif#if STRUCTALIGNMENTSUPPORTED#pragma options align=mac68k#endif#if PRAGMA_IMPORT_SUPPORTED#pragma import on#endif/*    Developer Notes:            When the various calls are made to the dnr code, you must set up             a NewRoutineDescriptor for every non-nil completion routine and/or             notifyProc parameter.  Otherwise, the 68K dnr code, will not             correctly call your routine.        1. For the call to EnumCache, use NewEnumResultProc to set up a             universal procptr to pass as the enumResultProc parameter.        2. For the calls to StrToAddr and AddrToName, use NewResultProc to             set up a ResultUPP universal procptr to pass as the ResultProc             parameter.        3. For the calls to HInfo and MXInfo, use NewResultProc2Proc to            set up a ResultProc2UPP universal procptr to pass as the ResultProc            parameter.        4. The DNR selector symbol HINFO has been changed to HXINFO due to            conflict with the same symbol in the AddressXLation.h header*/enum {    NUM_ALT_ADDRS                = 4};struct hostInfo {    long                            rtnCode;    char                            cname[255];    SInt8                            filler;                        /* Filler for proper byte alignment     */    unsigned long                    addr[NUM_ALT_ADDRS];};typedef struct hostInfo hostInfo;enum {    A                            = 1,    NS                            = 2,    CNAME                        = 5,    HINFO                        = 13,    MX                            = 15,    lastClass                    = 32767};typedef unsigned short AddrClasses;/* Domain Name Resolver code selectors */enum {    OPENRESOLVER                = 1,    CLOSERESOLVER                = 2,    STRTOADDR                    = 3,    ADDRTOSTR                    = 4,    ENUMCACHE                    = 5,    ADDRTONAME                    = 6,    HXINFO                        = 7,                            /* changed from HINFO due to symbol conflict*/    MXINFO                        = 8};struct HInfoRec {    char                            cpuType[30];    char                            osType[30];};typedef struct HInfoRec HInfoRec;struct MXRec {    unsigned short                    preference;    char                            exchange[255];};typedef struct MXRec MXRec;struct returnRec {    long                            rtnCode;    char                            cname[255];    SInt8                            filler;                        /* Filler for proper byte alignment     */    union {        unsigned long                    addr[NUM_ALT_ADDRS];        struct HInfoRec                    hinfo;        struct MXRec                    mx;    }                                rdata;};typedef struct returnRec returnRec;struct cacheEntryRecord {    char                            *cname;    unsigned short                    ctype;    unsigned short                    cacheClass;    unsigned long                    ttl;    union {        char                            *name;        ip_addr                            addr;    }                                rdata;};typedef struct cacheEntryRecord cacheEntryRecord;typedef pascal void (*EnumResultProcPtr)(struct cacheEntryRecord *cacheEntryRecordPtr, Ptr userDataPtr);typedef pascal void (*ResultProcPtr)(struct hostInfo *hostInfoPtr, Ptr userDataPtr);typedef pascal void (*ResultProc2ProcPtr)(struct returnRec *returnRecPtr, Ptr userDataPtr);#if GENERATINGCFMtypedef UniversalProcPtr EnumResultUPP;typedef UniversalProcPtr ResultUPP;typedef UniversalProcPtr ResultProc2UPP;#elsetypedef EnumResultProcPtr EnumResultUPP;typedef ResultProcPtr ResultUPP;typedef ResultProc2ProcPtr ResultProc2UPP;#endifenum {    uppEnumResultProcInfo = kPascalStackBased         | STACK_ROUTINE_PARAMETER(1, SIZE_CODE(sizeof(struct cacheEntryRecord*)))         | STACK_ROUTINE_PARAMETER(2, SIZE_CODE(sizeof(Ptr))),    uppResultProcInfo = kPascalStackBased         | STACK_ROUTINE_PARAMETER(1, SIZE_CODE(sizeof(struct hostInfo*)))         | STACK_ROUTINE_PARAMETER(2, SIZE_CODE(sizeof(Ptr))),    uppResultProc2ProcInfo = kPascalStackBased         | STACK_ROUTINE_PARAMETER(1, SIZE_CODE(sizeof(struct returnRec*)))         | STACK_ROUTINE_PARAMETER(2, SIZE_CODE(sizeof(Ptr)))};#if GENERATINGCFM#define NewEnumResultProc(userRoutine)        \        (EnumResultUPP) NewRoutineDescriptor((ProcPtr)(userRoutine), uppEnumResultProcInfo, GetCurrentArchitecture())#define NewResultProc(userRoutine)        \        (ResultUPP) NewRoutineDescriptor((ProcPtr)(userRoutine), uppResultProcInfo, GetCurrentArchitecture())#define NewResultProc2Proc(userRoutine)        \        (ResultProc2UPP) NewRoutineDescriptor((ProcPtr)(userRoutine), uppResultProc2ProcInfo, GetCurrentArchitecture())#else#define NewEnumResultProc(userRoutine)        \        ((EnumResultUPP) (userRoutine))#define NewResultProc(userRoutine)        \        ((ResultUPP) (userRoutine))#define NewResultProc2Proc(userRoutine)        \        ((ResultProc2UPP) (userRoutine))#endif#if GENERATINGCFM#define CallEnumResultProc(userRoutine, cacheEntryRecordPtr, userDataPtr)        \        CallUniversalProc((UniversalProcPtr)(userRoutine), uppEnumResultProcInfo, (cacheEntryRecordPtr), (userDataPtr))#define CallResultProc(userRoutine, hostInfoPtr, userDataPtr)        \        CallUniversalProc((UniversalProcPtr)(userRoutine), uppResultProcInfo, (hostInfoPtr), (userDataPtr))#define CallResultProc2Proc(userRoutine, returnRecPtr, userDataPtr)        \        CallUniversalProc((UniversalProcPtr)(userRoutine), uppResultProc2ProcInfo, (returnRecPtr), (userDataPtr))#else#define CallEnumResultProc(userRoutine, cacheEntryRecordPtr, userDataPtr)        \        (*(userRoutine))((cacheEntryRecordPtr), (userDataPtr))#define CallResultProc(userRoutine, hostInfoPtr, userDataPtr)        \        (*(userRoutine))((hostInfoPtr), (userDataPtr))#define CallResultProc2Proc(userRoutine, returnRecPtr, userDataPtr)        \        (*(userRoutine))((returnRecPtr), (userDataPtr))#endifextern OSErr OpenResolver(char *fileName);extern OSErr StrToAddr(char *hostName, struct hostInfo *hostInfoPtr, ResultUPP ResultProc, char *userDataPtr);extern OSErr AddrToStr(unsigned long addr, char *addrStr);extern OSErr EnumCache(EnumResultUPP enumResultProc, Ptr userDataPtr);extern OSErr AddrToName(ip_addr addr, struct hostInfo *hostInfoPtr, ResultUPP ResultProc, Ptr userDataPtr);extern OSErr HInfo(char *hostName, struct returnRec *returnRecPtr, ResultProc2UPP resultProc, Ptr userDataPtr);extern OSErr MXInfo(char *hostName, struct returnRec *returnRecPtr, ResultProc2UPP resultProc, Ptr userDataPtr);extern OSErr CloseResolver(void);/*    Universal ProcPtrs declaration for each of the dnr selector code calls.*/typedef OSErr (*OpenResolverProcPtr)(UInt32 selector, char *filename);typedef OSErr (*CloseResolverProcPtr)(UInt32 selector);typedef OSErr (*StrToAddrProcPtr)(UInt32 selector, char *hostName, struct hostInfo *rtnStruct, ResultUPP resultproc, Ptr userDataPtr);typedef OSErr (*AddrToStrProcPtr)(UInt32 selector, unsigned long addr, char *addrStr);typedef OSErr (*EnumCacheProcPtr)(UInt32 selector, EnumResultUPP resultproc, Ptr userDataPtr);typedef OSErr (*AddrToNameProcPtr)(UInt32 selector, UInt32 addr, struct hostInfo *rtnStruct, ResultUPP resultproc, Ptr userDataPtr);typedef OSErr (*HInfoProcPtr)(UInt32 selector, char *hostName, struct returnRec *returnRecPtr, ResultProc2UPP resultProc, Ptr userDataPtr);typedef OSErr (*MXInfoProcPtr)(UInt32 selector, char *hostName, struct returnRec *returnRecPtr, ResultProc2UPP resultProc, Ptr userDataPtr);#if GENERATINGCFMtypedef UniversalProcPtr OpenResolverUPP;typedef UniversalProcPtr CloseResolverUPP;typedef UniversalProcPtr StrToAddrUPP;typedef UniversalProcPtr AddrToStrUPP;typedef UniversalProcPtr EnumCacheUPP;typedef UniversalProcPtr AddrToNameUPP;typedef UniversalProcPtr HInfoUPP;typedef UniversalProcPtr MXInfoUPP;#elsetypedef OpenResolverProcPtr OpenResolverUPP;typedef CloseResolverProcPtr CloseResolverUPP;typedef StrToAddrProcPtr StrToAddrUPP;typedef AddrToStrProcPtr AddrToStrUPP;typedef EnumCacheProcPtr EnumCacheUPP;typedef AddrToNameProcPtr AddrToNameUPP;typedef HInfoProcPtr HInfoUPP;typedef MXInfoProcPtr MXInfoUPP;#endifenum {    uppOpenResolverProcInfo = kCStackBased         | RESULT_SIZE(SIZE_CODE(sizeof(OSErr)))         | STACK_ROUTINE_PARAMETER(1, SIZE_CODE(sizeof(UInt32)))         | STACK_ROUTINE_PARAMETER(2, SIZE_CODE(sizeof(char*))),    uppCloseResolverProcInfo = kCStackBased         | RESULT_SIZE(SIZE_CODE(sizeof(OSErr)))         | STACK_ROUTINE_PARAMETER(1, SIZE_CODE(sizeof(UInt32))),    uppStrToAddrProcInfo = kCStackBased         | RESULT_SIZE(SIZE_CODE(sizeof(OSErr)))         | STACK_ROUTINE_PARAMETER(1, SIZE_CODE(sizeof(UInt32)))         | STACK_ROUTINE_PARAMETER(2, SIZE_CODE(sizeof(char*)))         | STACK_ROUTINE_PARAMETER(3, SIZE_CODE(sizeof(struct hostInfo*)))         | STACK_ROUTINE_PARAMETER(4, SIZE_CODE(sizeof(ResultUPP)))         | STACK_ROUTINE_PARAMETER(5, SIZE_CODE(sizeof(Ptr))),    uppAddrToStrProcInfo = kCStackBased         | RESULT_SIZE(SIZE_CODE(sizeof(OSErr)))         | STACK_ROUTINE_PARAMETER(1, SIZE_CODE(sizeof(UInt32)))         | STACK_ROUTINE_PARAMETER(2, SIZE_CODE(sizeof(unsigned long)))         | STACK_ROUTINE_PARAMETER(3, SIZE_CODE(sizeof(char*))),    uppEnumCacheProcInfo = kCStackBased         | RESULT_SIZE(SIZE_CODE(sizeof(OSErr)))         | STACK_ROUTINE_PARAMETER(1, SIZE_CODE(sizeof(UInt32)))         | STACK_ROUTINE_PARAMETER(2, SIZE_CODE(sizeof(EnumResultUPP)))         | STACK_ROUTINE_PARAMETER(3, SIZE_CODE(sizeof(Ptr))),    uppAddrToNameProcInfo = kCStackBased         | RESULT_SIZE(SIZE_CODE(sizeof(OSErr)))         | STACK_ROUTINE_PARAMETER(1, SIZE_CODE(sizeof(UInt32)))         | STACK_ROUTINE_PARAMETER(2, SIZE_CODE(sizeof(UInt32)))         | STACK_ROUTINE_PARAMETER(3, SIZE_CODE(sizeof(struct hostInfo*)))         | STACK_ROUTINE_PARAMETER(4, SIZE_CODE(sizeof(ResultUPP)))         | STACK_ROUTINE_PARAMETER(5, SIZE_CODE(sizeof(Ptr))),    uppHInfoProcInfo = kCStackBased         | RESULT_SIZE(SIZE_CODE(sizeof(OSErr)))         | STACK_ROUTINE_PARAMETER(1, SIZE_CODE(sizeof(UInt32)))         | STACK_ROUTINE_PARAMETER(2, SIZE_CODE(sizeof(char*)))         | STACK_ROUTINE_PARAMETER(3, SIZE_CODE(sizeof(struct returnRec*)))         | STACK_ROUTINE_PARAMETER(4, SIZE_CODE(sizeof(ResultProc2UPP)))         | STACK_ROUTINE_PARAMETER(5, SIZE_CODE(sizeof(Ptr))),    uppMXInfoProcInfo = kCStackBased         | RESULT_SIZE(SIZE_CODE(sizeof(OSErr)))         | STACK_ROUTINE_PARAMETER(1, SIZE_CODE(sizeof(UInt32)))         | STACK_ROUTINE_PARAMETER(2, SIZE_CODE(sizeof(char*)))         | STACK_ROUTINE_PARAMETER(3, SIZE_CODE(sizeof(struct returnRec*)))         | STACK_ROUTINE_PARAMETER(4, SIZE_CODE(sizeof(ResultProc2UPP)))         | STACK_ROUTINE_PARAMETER(5, SIZE_CODE(sizeof(Ptr)))};#if GENERATINGCFM#define CallOpenResolverProc(userRoutine, selector, filename)        \        CallUniversalProc((UniversalProcPtr)(userRoutine), uppOpenResolverProcInfo, (selector), (filename))#define CallCloseResolverProc(userRoutine, selector)        \        CallUniversalProc((UniversalProcPtr)(userRoutine), uppCloseResolverProcInfo, (selector))#define CallStrToAddrProc(userRoutine, selector, hostName, rtnStruct, resultproc, userDataPtr)        \        CallUniversalProc((UniversalProcPtr)(userRoutine), uppStrToAddrProcInfo, (selector), (hostName), (rtnStruct), (resultproc), (userDataPtr))#define CallAddrToStrProc(userRoutine, selector, addr, addrStr)        \        CallUniversalProc((UniversalProcPtr)(userRoutine), uppAddrToStrProcInfo, (selector), (addr), (addrStr))#define CallEnumCacheProc(userRoutine, selector, resultproc, userDataPtr)        \        CallUniversalProc((UniversalProcPtr)(userRoutine), uppEnumCacheProcInfo, (selector), (resultproc), (userDataPtr))#define CallAddrToNameProc(userRoutine, selector, addr, rtnStruct, resultproc, userDataPtr)        \        CallUniversalProc((UniversalProcPtr)(userRoutine), uppAddrToNameProcInfo, (selector), (addr), (rtnStruct), (resultproc), (userDataPtr))#define CallHInfoProc(userRoutine, selector, hostName, returnRecPtr, resultProc, userDataPtr)        \        CallUniversalProc((UniversalProcPtr)(userRoutine), uppHInfoProcInfo, (selector), (hostName), (returnRecPtr), (resultProc), (userDataPtr))#define CallMXInfoProc(userRoutine, selector, hostName, returnRecPtr, resultProc, userDataPtr)        \        CallUniversalProc((UniversalProcPtr)(userRoutine), uppMXInfoProcInfo, (selector), (hostName), (returnRecPtr), (resultProc), (userDataPtr))#else#define CallOpenResolverProc(userRoutine, selector, filename)        \        (*(userRoutine))((selector), (filename))#define CallCloseResolverProc(userRoutine, selector)        \        (*(userRoutine))((selector))#define CallStrToAddrProc(userRoutine, selector, hostName, rtnStruct, resultproc, userDataPtr)        \        (*(userRoutine))((selector), (hostName), (rtnStruct), (resultproc), (userDataPtr))#define CallAddrToStrProc(userRoutine, selector, addr, addrStr)        \        (*(userRoutine))((selector), (addr), (addrStr))#define CallEnumCacheProc(userRoutine, selector, resultproc, userDataPtr)        \        (*(userRoutine))((selector), (resultproc), (userDataPtr))#define CallAddrToNameProc(userRoutine, selector, addr, rtnStruct, resultproc, userDataPtr)        \        (*(userRoutine))((selector), (addr), (rtnStruct), (resultproc), (userDataPtr))#define CallHInfoProc(userRoutine, selector, hostName, returnRecPtr, resultProc, userDataPtr)        \        (*(userRoutine))((selector), (hostName), (returnRecPtr), (resultProc), (userDataPtr))#define CallMXInfoProc(userRoutine, selector, hostName, returnRecPtr, resultProc, userDataPtr)        \        (*(userRoutine))((selector), (hostName), (returnRecPtr), (resultProc), (userDataPtr))#endif#if PRAGMA_IMPORT_SUPPORTED#pragma import off#endif#if STRUCTALIGNMENTSUPPORTED#pragma options align=reset#endif#ifdef __cplusplus}#endif#endif /* __ADDRESSXLATION__ */'.! !!InterpreterSupportCode class methodsFor: 'source files' stamp: 'jm 9/21/97 18:06'!archiveBinaryFile    ^ #(83 73 84 33 0 2 0 0 31 226 114 76 97 117 2 114 0 0 0 22 1 189 13 13 14 83 113 117 101 97 107 54 56 75 46 112 114 111 106 77 114 67 0 0 0 0 0 0 0 0 0 0 0 0 0 0 228 205 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 15 28 0 0 0 0 255 255 255 255 77 77 80 82 67 87 73 69 1 0 172 94 90 110 176 75 10 236 0 0 37 198 0 0 22 160 0 0 7 225 0 0 6 181 134 236 198 206 0 0 0 0 0 0 144 90 13 192 248 190 137 93 43 51 249 202 143 30 151 176 1 158 157 87 132 63 173 149 93 70 142 17 74 40 97 29 197 211 147 121 153 41 161 114 234 177 243 57 97 151 225 51 41 95 175 51 141 227 159 22 109 144 183 198 9 147 63 225 228 248 17 202 143 48 242 220 8 75 66 35 199 34 44 242 148 83 62 32 252 201 241 9 57 78 56 225 132 19 214 75 248 217 75 88 19 66 235 9 63 194 9 147 28 127 194 9 39 124 96 228 56 225 43 112 87 131 56 77 126 228 248 209 6 81 190 242 53 194 9 39 244 8 139 28 63 9 139 204 56 225 79 241 132 3 227 13 8 64 175 179 11 128 1 128 66 14 96 46 158 134 27 88 245 90 137 245 137 188 87 97 219 68 62 200 170 62 94 101 21 169 77 148 130 34 43 6 20 139 235 154 118 145 111 93 92 178 194 22 146 165 22 151 1 179 59 28 206 122 123 195 242 74 6 106 138 142 162 159 227 237 239 162 247 202 43 130 0 231 244 0 204 123 86 100 61 1 94 104 101 165 118 53 224 71 130 132 178 162 113 86 125 126 133 197 67 245 137 172 87 108 230 219 3 42 254 43 173 170 20 98 67 178 63 168 138 178 109 185 155 94 30 186 196 10 124 48 40 169 172 7 217 72 235 68 47 43 53 55 71 73 104 121 60 162 192 183 43 34 235 87 9 61 20 196 0 105 88 5 38 90 8 122 48 81 52 94 7 233 96 192 68 70 68 186 241 79 15 160 118 12 200 194 172 35 160 98 13 81 36 215 193 11 108 157 139 93 92 210 202 218 23 216 139 139 109 15 31 205 130 29 15 192 20 253 137 254 175 100 186 153 44 195 198 161 60 54 200 140 34 19 58 231 12 103 178 2 195 76 103 94 54 212 24 47 33 112 134 8 48 229 8 101 150 198 64 36 18 75 19 137 48 36 8 52 75 251 37 177 125 59 64 89 132 124 81 101 179 210 29 82 144 23 164 81 5 76 112 62 152 153 167 13 225 248 255 112 16 122 103 45 129 52 82 37 180 72 86 176 181 254 96 171 40 127 207 36 154 193 233 180 31 203 80 80 238 116 214 78 150 236 85 120 150 135 66 1 125 0 30 14 71 109 69 42 143 165 214 239 97 151 183 133 36 89 37 210 254 152 195 225 172 173 210 9 224 209 96 95 170 15 160 107 189 171 126 132 224 159 60 220 149 141 110 131 77 72 182 48 71 131 214 53 79 168 170 241 48 217 132 226 98 93 0 30 70 155 240 179 32 191 243 8 233 6 232 26 26 37 114 138 135 216 241 179 32 191 134 86 175 190 127 234 53 55 206 35 169 198 20 228 225 228 21 129 15 156 20 86 211 53 196 43 122 1 60 132 81 101 83 186 18 99 67 120 164 19 30 63 117 162 9 30 6 219 247 254 102 40 140 245 226 134 84 189 54 218 235 198 124 67 46 73 82 149 116 14 94 73 104 255 175 117 208 126 47 43 114 178 217 143 243 80 124 1 79 42 143 197 89 249 139 170 200 67 109 215 9 224 65 194 100 195 42 249 91 87 39 169 197 148 7 214 1 113 184 40 237 143 57 78 59 220 19 60 116 3 28 110 93 69 13 153 201 37 245 112 56 27 82 122 232 53 56 229 227 106 156 118 202 73 30 167 156 242 24 143 113 167 60 166 235 184 83 78 241 208 95 112 202 35 122 252 229 148 79 8 251 167 83 78 241 24 119 202 35 52 206 56 229 36 15 125 0 167 172 255 225 112 143 23 236 105 135 123 178 51 234 6 56 220 6 127 240 146 69 108 71 201 226 99 14 215 252 135 211 65 34 199 114 252 225 116 146 60 78 57 148 49 61 198 29 74 138 199 68 7 30 225 113 166 3 39 121 24 109 201 174 151 137 60 176 240 199 172 240 100 135 73 240 8 248 71 219 222 183 147 132 147 149 70 120 72 158 150 81 30 117 158 150 20 143 44 199 241 117 133 120 113 56 236 213 186 0 162 255 54 35 200 68 53 104 69 255 194 3 59 85 96 212 43 78 35 60 2 188 162 176 118 169 45 228 15 124 167 110 172 51 96 69 139 205 186 0 186 78 118 134 132 151 78 122 242 9 30 169 14 156 170 179 68 231 84 71 203 108 60 76 5 116 109 136 1 35 99 198 13 159 82 104 66 124 205 55 59 161 233 194 195 26 6 240 20 64 19 23 126 235 27 60 63 230 194 92 184 255 245 121 107 112 227 103 42 28 192 204 215 227 63 172 34 20 106 185 206 187 246 65 211 69 213 176 230 139 171 32 124 104 63 132 187 58 184 240 157 102 122 39 188 21 219 33 97 162 241 99 115 185 78 146 143 235 220 113 8 86 191 113 211 81 46 136 132 111 188 103 80 112 237 255 125 77 50 202 111 48 184 206 251 103 113 157 247 225 237 40 63 200 187 18 14 224 57 196 167 235 125 104 42 123 7 255 31 161 92 246 82 206 159 194 118 170 116 30 102 69 198 184 81 100 152 94 170 141 82 93 237 33 210 157 9 90 141 219 132 162 172 148 90 45 123 97 218 238 243 227 196 153 249 154 34 152 149 241 222 187 16 172 43 223 193 243 128 47 242 37 135 248 5 120 47 2 214 179 231 35 118 4 207 92 200 235 116 99 254 167 138 192 100 66 156 29 204 15 136 59 53 124 190 202 20 191 208 163 8 178 31 242 113 32 137 249 233 86 149 183 15 235 0 245 161 249 51 49 127 239 126 176 22 36 118 162 138 110 127 144 219 246 144 138 8 22 1 225 211 215 7 214 217 189 204 101 105 185 136 29 68 126 221 180 206 167 237 222 164 229 71 61 72 126 235 156 152 173 44 128 57 100 27 142 212 192 185 195 53 128 166 71 230 101 191 168 148 130 174 69 13 48 151 94 254 153 110 64 13 100 130 33 127 184 6 98 77 0 160 167 16 6 86 60 3 3 245 29 92 215 117 207 215 145 169 186 17 178 240 3 120 143 241 174 39 28 35 228 54 28 222 211 3 31 239 187 3 152 5 91 25 239 6 212 99 125 119 127 52 232 253 1 101 51 50 121 145 219 134 154 210 252 61 133 152 227 147 10 152 91 1 217 175 54 194 89 37 6 218 195 242 178 53 195 112 120 215 19 169 126 142 60 23 198 32 13 223 88 0 121 253 59 240 236 70 204 67 239 231 13 124 13 150 199 247 70 48 16 231 150 98 45 112 187 178 138 224 8 131 245 186 37 2 204 27 116 18 110 48 227 94 105 182 203 223 22 10 136 108 133 40 78 78 54 117 59 130 1 70 15 166 8 48 172 96 194 133 89 186 212 73 55 60 201 226 52 9 11 100 36 86 69 41 242 12 238 214 194 20 109 207 154 93 229 32 163 65 178 111 61 54 62 24 138 170 114 151 91 219 89 201 15 229 210 126 254 111 148 97 196 193 31 118 100 33 99 255 112 202 69 168 227 153 189 96 115 188 50 72 61 28 164 27 198 195 13 69 15 40 214 174 85 84 94 38 86 79 199 33 172 212 41 98 49 15 215 51 118 63 61 128 118 85 166 3 161 47 99 37 175 10 232 210 196 99 100 194 148 218 204 39 110 67 115 47 12 153 89 224 73 118 245 27 117 1 124 76 170 108 7 125 206 15 46 71 243 38 102 237 177 128 104 74 60 19 239 103 48 111 190 196 205 177 224 149 25 76 16 12 161 85 116 62 59 61 36 227 48 54 31 206 115 185 235 11 49 227 208 198 93 97 63 29 110 162 231 195 45 150 15 97 38 222 39 249 161 254 57 192 185 13 67 135 219 203 110 129 18 196 232 123 5 213 78 192 113 62 67 38 126 16 122 5 234 144 245 92 130 181 109 129 181 136 185 9 118 1 7 248 56 128 193 75 176 22 27 108 70 108 19 193 86 191 13 93 136 245 17 172 238 16 220 140 216 215 148 199 121 112 27 190 201 177 132 230 168 130 157 40 89 35 193 50 102 194 221 40 37 29 36 95 236 131 7 16 67 46 0 194 187 128 179 148 25 100 86 3 150 213 176 23 96 38 205 119 206 237 240 26 98 183 18 44 109 15 124 128 216 14 130 85 246 194 71 0 179 215 17 108 222 163 240 21 98 52 71 253 101 248 238 6 176 116 200 184 242 73 38 7 96 14 190 13 130 129 211 21 172 168 69 4 50 126 66 49 172 5 128 169 78 124 115 68 20 84 22 235 74 241 75 193 28 220 48 138 15 194 45 116 211 33 14 103 147 93 23 187 228 21 151 137 65 115 98 239 133 94 139 210 152 26 221 186 138 165 140 225 13 188 28 244 7 175 86 44 49 186 149 29 170 204 43 233 149 94 191 42 201 166 42 41 168 166 187 121 249 106 81 205 41 23 4 17 135 241 78 94 245 225 125 154 38 155 154 245 40 241 196 74 41 189 22 37 100 209 150 59 226 202 105 112 140 118 186 189 202 129 201 178 201 131 11 49 30 137 199 23 50 8 132 155 67 244 122 148 207 255 0 12 0 197 76 47 59 175 235 236 236 236 236 109 230 117 29 109 98 102 3 187 181 76 217 217 41 187 149 223 90 29 229 132 147 99 143 103 235 201 30 79 168 105 225 159 118 30 97 228 184 43 97 29 121 62 32 199 9 39 156 112 242 156 12 248 72 194 143 48 194 162 178 40 97 100 200 200 113 194 79 194 200 148 123 13 60 194 207 200 113 194 200 128 19 46 57 78 158 147 227 132 147 227 18 70 24 225 20 184 183 149 89 226 171 143 166 223 117 43 31 24 141 48 130 2 78 38 156 12 56 158 224 129 11 11 216 1 64 65 77 11 19 66 36 120 151 17 82 82 13 111 63 156 209 119 14 188 95 39 99 200 98 98 35 21 246 128 214 169 7 21 131 72 231 191 36 7 73 227 190 190 95 60 196 14 4 250 56 112 166 143 141 243 92 62 57 88 222 172 238 214 101 93 5 234 70 198 203 69 134 224 242 135 241 220 245 91 3 77 215 128 135 50 60 186 99 5 33 213 189 196 185 163 136 72 223 188 70 200 161 62 233 233 113 151 200 114 226 135 249 232 111 40 186 3 227 225 67 245 99 243 162 151 108 110 146 35 5 39 180 90 219 17 91 157 109 221 161 62 242 3 104 79 236 39 136 155 108 98 14 161 30 233 127 28 77 17 83 209 163 85 193 36 62 249 120 112 142 145 195 204 43 214 30 46 163 195 171 134 21 191 174 182 27 35 203 44 196 217 25 119 22 239 128 45 10 96 222 9 179 11 103 55 204 187 96 46 196 243 124 152 101 152 243 122 189 231 14 194 252 50 121 133 188 74 249 73 5 138 140 14 112 235 6 85 87 130 166 166 119 167 69 16 62 47 138 75 239 189 5 91 140 139 231 151 126 14 243 191 138 188 73 222 38 239 194 62 5 73 69 10 153 34 155 181 110 195 84 131 109 25 87 136 132 152 208 51 51 118 10 182 24 15 243 39 253 138 76 196 239 178 202 20 247 168 63 255 116 75 161 143 200 199 228 20 85 60 169 144 155 41 180 85 49 15 104 250 176 64 164 74 164 28 42 81 130 243 144 135 150 140 42 54 19 57 66 177 25 31 156 252 113 49 204 211 62 252 246 88 231 53 5 165 181 146 71 90 15 251 151 39 21 44 96 10 66 172 71 66 119 51 236 17 156 151 227 198 211 113 94 134 179 240 222 42 156 215 224 92 131 115 153 165 252 212 248 149 175 190 235 87 124 10 126 183 26 103 225 217 90 156 75 113 94 129 179 112 200 36 156 39 227 188 180 231 137 250 73 48 87 99 6 12 57 168 14 121 73 239 175 180 28 37 50 224 125 114 148 28 163 65 125 43 185 193 65 79 170 145 144 118 96 196 66 143 222 203 77 161 240 186 158 171 151 14 255 229 253 181 168 112 82 169 103 134 58 6 164 21 51 250 31 37 99 209 127 29 67 202 149 28 146 19 248 165 73 5 198 134 34 250 159 85 169 191 235 137 148 17 233 50 148 34 149 120 62 7 231 217 56 207 66 143 44 192 243 10 156 69 218 136 148 17 222 75 166 73 57 206 243 113 158 135 243 92 156 69 254 138 244 72 230 175 23 90 227 230 49 223 195 137 237 90 247 164 67 137 79 54 247 65 209 173 169 221 82 94 81 173 46 170 13 85 86 193 241 77 39 208 254 77 159 212 38 121 144 62 219 2 85 225 219 112 171 47 223 219 164 36 170 107 123 160 132 234 53 181 109 21 129 118 57 28 174 28 92 11 26 177 181 137 248 2 55 113 5 154 182 109 111 173 2 113 7 69 189 65 27 222 164 132 221 8 160 67 202 27 210 43 141 189 177 151 7 246 112 188 145 213 33 158 95 246 188 20 243 249 155 189 244 132 216 24 245 133 172 163 226 249 149 167 5 181 242 52 25 195 168 207 101 221 3 169 126 146 83 233 9 201 97 212 88 54 7 96 67 79 98 87 15 25 203 168 7 179 174 136 187 92 95 35 21 78 160 31 131 211 93 151 179 125 250 248 185 179 207 74 177 150 198 214 22 122 2 25 12 84 247 228 108 102 211 196 227 84 150 125 14 190 107 246 54 225 248 167 87 42 113 87 56 33 121 212 237 174 203 57 70 71 213 190 76 92 208 126 193 169 172 105 56 61 144 142 246 23 115 219 193 67 25 46 107 49 140 202 78 242 57 213 222 189 95 14 27 105 44 235 52 130 42 147 2 164 26 102 72 213 70 168 59 19 212 157 196 197 169 14 160 66 22 164 176 22 213 157 160 234 106 100 239 48 117 87 130 186 139 20 162 27 76 181 93 185 235 134 235 187 22 121 192 175 142 119 10 192 173 155 20 57 164 232 131 150 96 157 149 83 233 201 56 78 165 247 123 72 133 8 186 157 148 208 112 99 62 95 195 38 118 50 158 41 116 62 111 131 98 180 173 239 76 121 143 117 54 182 43 59 41 230 84 123 75 119 84 201 248 149 53 48 78 165 39 19 56 181 184 65 139 132 84 83 213 34 114 24 196 210 53 107 3 214 223 196 174 167 200 68 78 205 247 169 93 74 200 167 133 238 24 201 162 150 112 170 163 113 191 18 49 211 18 89 212 73 184 235 99 157 144 198 33 93 62 112 127 215 201 156 90 152 160 182 40 93 230 77 178 69 45 69 231 109 11 108 55 213 116 234 89 212 41 168 171 79 105 167 25 62 170 235 84 244 43 189 207 28 206 87 218 220 121 162 208 147 50 225 33 93 215 238 100 208 173 93 167 241 142 226 0 107 183 52 248 83 84 218 198 121 111 96 189 124 58 58 175 62 26 13 43 45 114 184 237 190 243 102 240 93 139 234 67 33 93 49 140 214 102 153 198 202 0 218 234 67 229 184 235 227 138 193 239 206 239 239 58 83 100 158 46 71 135 51 239 6 117 22 167 22 108 84 12 83 14 155 141 29 157 191 163 173 124 157 141 217 128 212 209 108 152 131 84 175 22 78 149 134 155 212 185 232 134 22 248 225 32 147 68 22 117 158 160 66 212 61 164 206 199 68 9 4 117 53 154 146 53 73 173 192 124 133 123 253 112 198 179 22 181 82 184 65 237 162 133 126 212 13 11 208 229 77 65 45 242 208 229 11 121 195 206 254 49 208 107 127 170 25 187 50 156 192 253 45 163 102 239 123 161 87 31 73 52 236 35 112 103 41 118 29 185 227 236 245 94 148 4 245 162 4 183 221 140 154 189 29 239 173 251 245 18 82 225 4 110 29 5 117 228 150 178 119 11 177 35 21 78 200 226 68 167 220 175 166 210 117 192 67 75 48 81 252 186 6 80 99 52 149 151 162 95 185 125 210 126 165 55 208 156 74 79 150 97 42 55 104 237 81 45 146 106 136 214 174 213 72 101 187 54 69 162 157 131 9 102 101 249 114 78 117 177 102 147 174 163 214 174 53 156 154 219 232 247 55 100 110 14 44 234 10 84 8 160 52 206 119 107 93 127 235 90 203 169 238 173 154 169 238 81 131 131 29 106 128 186 18 93 206 35 232 129 203 87 113 170 19 238 0 76 93 75 213 94 139 186 26 93 238 83 34 233 59 138 1 234 26 145 67 170 28 214 246 62 80 168 14 21 162 205 166 17 238 41 254 81 104 173 104 135 112 211 163 143 40 116 61 27 214 49 234 23 78 113 79 57 180 43 253 251 128 83 233 137 135 167 114 246 63 167 222 45 142 51 34 149 29 103 248 55 18 252 75 70 108 254 128 178 183 175 47 1 130 111 36 66 191 129 145 72 23 206 94 133 105 58 232 114 194 223 108 152 140 122 225 51 208 201 113 22 182 142 249 189 97 131 126 243 63 0 0 13 13 14 83 113 117 101 97 107 80 80 67 46 112 114 111 106 77 114 67 0 0 0 0 0 0 0 0 0 0 0 0 0 0 60 229 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 22 0 0 0 0 0 0 0 0 255 255 255 255 77 77 80 82 67 87 73 69 1 0 172 94 103 33 176 75 11 18 0 0 42 109 0 0 23 186 0 0 9 113 0 0 6 229 211 112 192 247 0 0 0 0 0 0 204 71 13 192 213 101 47 91 187 188 110 93 100 114 9 91 88 107 156 94 131 142 118 43 59 194 234 24 97 123 37 155 109 138 167 103 207 105 110 106 103 103 157 201 207 201 154 225 57 61 59 243 247 250 17 102 155 117 238 181 174 129 145 219 100 211 219 18 70 110 31 43 59 66 9 39 188 35 236 9 235 233 62 194 250 142 237 147 108 70 246 73 246 209 125 118 100 51 242 140 48 194 63 41 39 108 147 227 132 109 37 252 105 71 24 225 231 166 228 105 183 2 95 53 168 243 234 124 55 251 104 43 91 219 71 182 52 194 54 185 173 155 109 50 219 100 191 120 178 129 241 6 4 160 215 217 5 192 0 96 206 167 1 102 227 169 250 172 59 244 238 210 251 24 132 78 120 97 190 24 26 192 115 176 174 115 129 49 244 182 252 87 145 110 251 98 155 100 111 177 90 205 70 175 207 211 108 19 64 0 139 197 90 109 174 93 86 204 160 44 119 24 125 55 136 228 70 98 247 154 198 108 128 105 123 1 238 104 205 201 55 134 14 239 124 172 172 248 94 205 242 206 157 207 152 110 69 100 122 169 59 212 189 192 8 25 120 234 240 76 169 216 123 82 83 121 20 50 214 233 150 119 210 93 175 102 87 117 77 229 194 164 242 254 25 3 33 111 197 154 138 182 133 0 73 156 91 18 255 212 49 178 36 238 112 168 147 48 160 98 5 64 233 31 88 214 108 188 33 240 228 106 252 231 247 65 165 127 30 255 155 195 56 222 79 246 218 29 45 246 70 233 3 45 229 152 20 190 111 244 111 104 61 127 63 205 182 193 31 144 90 205 46 187 223 47 249 47 80 200 61 167 212 249 208 128 128 137 84 136 116 225 223 71 57 199 66 64 22 90 5 0 22 145 40 35 69 50 44 118 135 161 210 102 192 22 97 48 47 48 231 229 25 159 29 206 34 202 101 38 255 132 255 151 179 46 150 42 108 60 147 71 11 12 233 224 201 101 38 52 6 27 121 117 82 243 153 8 166 86 4 168 22 101 144 192 134 26 41 137 137 140 186 145 76 122 44 194 124 118 68 168 23 78 64 57 64 50 246 197 180 1 206 44 9 141 67 40 146 38 20 194 130 165 146 5 152 41 255 82 108 223 14 144 31 162 47 220 47 82 53 22 143 219 238 240 140 41 160 134 185 160 101 63 21 130 209 255 179 213 77 178 172 130 36 234 61 225 214 83 238 116 183 72 190 247 153 140 103 152 94 96 181 162 170 255 137 117 120 22 120 189 46 101 0 30 22 75 121 97 34 79 122 185 179 222 176 172 213 235 241 5 72 218 11 57 44 214 242 18 133 0 30 181 230 34 101 0 93 171 109 213 163 4 63 230 81 83 188 178 70 101 172 111 114 244 245 245 1 251 249 54 126 241 173 71 3 244 43 62 220 252 6 218 165 34 93 161 221 229 242 120 220 134 82 201 229 165 139 83 151 8 240 86 103 15 116 207 89 2 59 77 251 233 10 241 16 140 142 120 43 180 212 202 158 230 82 117 200 60 212 70 71 94 158 34 0 15 149 209 113 69 144 191 241 224 178 43 2 232 234 29 35 114 157 135 212 126 69 144 191 132 92 175 77 255 174 215 140 40 143 184 26 105 200 195 106 247 59 236 174 203 194 202 186 122 237 163 6 255 31 60 28 99 202 38 116 37 131 68 60 52 196 227 195 78 116 141 135 96 124 223 39 157 9 85 181 244 165 143 234 213 127 165 79 107 80 134 2 127 43 239 211 252 254 185 62 189 210 92 57 238 99 50 40 73 73 220 201 52 120 28 109 255 109 65 220 127 248 252 190 184 105 152 224 225 111 114 213 39 242 164 91 139 175 170 138 60 2 109 10 1 60 40 212 70 172 146 127 233 106 165 90 148 29 247 226 37 95 80 46 113 220 40 237 133 28 55 28 247 37 30 138 1 142 187 178 176 204 48 174 135 197 90 155 208 67 233 195 185 95 84 245 134 115 143 243 184 238 220 199 121 76 56 247 113 93 39 156 123 130 135 242 130 115 31 213 227 159 206 253 146 176 31 59 247 4 143 9 231 62 74 227 166 115 143 243 80 14 112 238 106 163 95 106 252 176 79 3 116 223 126 10 167 241 115 161 48 23 251 243 190 225 62 93 194 251 180 242 135 227 190 88 248 55 28 247 229 14 171 24 224 184 107 157 238 59 23 25 218 151 44 254 147 227 214 254 221 49 33 145 43 157 225 154 99 138 243 184 238 116 198 245 152 112 58 9 30 215 58 249 40 143 155 157 60 206 67 101 140 119 189 20 228 129 133 63 110 205 63 233 48 49 30 46 231 88 219 59 61 217 184 92 105 196 195 83 223 60 198 163 178 190 57 193 35 213 114 113 157 35 90 28 22 115 169 34 128 232 127 157 53 164 160 26 188 162 175 242 192 78 229 26 243 156 153 196 131 150 198 12 102 79 171 215 233 58 171 110 164 51 96 69 75 247 42 2 232 250 73 103 136 121 242 184 183 191 198 35 209 129 19 117 22 235 156 129 177 50 155 8 141 129 47 171 9 160 102 180 139 102 130 58 196 87 159 250 54 212 221 241 166 140 1 236 3 168 19 131 191 59 133 103 191 24 20 131 125 47 207 90 141 27 81 147 225 0 102 222 140 255 128 123 135 192 202 197 142 111 253 26 234 230 151 194 234 19 235 32 248 250 126 8 62 216 46 6 31 211 242 59 193 7 176 29 18 19 153 159 33 67 236 160 124 98 199 227 175 195 170 87 182 14 115 65 36 248 240 142 33 193 229 127 244 228 24 152 31 249 13 133 216 209 51 83 236 120 6 111 135 249 193 148 53 112 0 207 51 124 30 124 3 234 242 15 225 255 115 156 75 47 231 124 28 182 115 165 167 96 86 100 204 112 251 80 48 153 182 136 91 94 92 25 38 199 64 53 179 136 185 107 30 194 19 153 38 159 54 97 243 121 2 249 238 227 32 28 125 153 112 131 90 196 252 6 189 184 101 151 60 183 77 93 212 195 26 191 41 107 71 249 170 126 216 46 110 217 81 2 218 226 61 48 248 189 131 172 234 23 189 152 107 19 36 183 124 5 30 121 111 144 85 61 223 133 35 9 30 152 227 16 75 250 218 163 112 242 158 29 226 67 199 43 184 250 240 196 58 154 73 0 123 165 136 85 253 0 132 198 172 219 96 240 55 51 100 118 235 95 224 154 141 197 224 73 106 69 188 248 163 26 115 93 126 130 219 171 155 118 177 215 64 200 53 201 227 109 91 155 151 28 138 169 84 178 55 72 62 191 169 160 194 182 12 103 150 50 136 83 146 31 157 162 147 45 125 233 16 107 232 9 224 57 151 45 165 242 154 122 144 51 106 120 202 90 8 41 58 208 229 232 163 236 245 5 175 37 122 18 251 220 134 55 57 208 16 230 65 56 42 78 124 216 231 167 254 121 26 126 24 252 48 0 189 152 107 27 213 11 107 120 122 43 105 130 249 123 248 125 221 109 91 33 243 235 59 114 33 69 205 245 120 130 101 242 83 142 44 200 198 130 16 166 143 212 0 162 17 229 245 233 189 144 249 228 220 152 96 243 34 213 45 176 230 119 22 130 126 249 33 60 15 52 133 254 40 34 126 59 222 11 129 254 255 230 33 54 128 103 6 76 233 168 193 252 251 114 65 173 70 220 48 148 31 16 183 202 248 188 0 203 123 169 219 239 240 57 97 26 14 162 48 63 223 62 108 238 199 126 136 250 240 252 41 152 255 237 253 160 207 138 237 14 230 28 223 44 110 219 67 83 44 108 134 196 167 255 105 208 223 186 155 21 233 172 136 29 68 126 93 188 226 51 159 188 79 206 143 122 80 126 125 118 164 179 161 254 180 139 75 53 112 203 72 13 160 249 245 217 125 78 9 139 95 241 161 6 196 109 151 107 128 181 252 254 199 74 2 53 48 121 164 6 104 23 84 68 78 196 89 25 165 15 160 152 218 240 34 186 210 75 132 87 182 21 96 66 143 179 130 104 73 12 69 58 36 99 137 240 35 124 243 69 114 152 227 155 243 87 35 31 67 222 165 98 193 149 231 94 94 184 17 196 39 10 158 223 208 71 158 35 41 23 161 142 55 107 95 139 46 32 186 44 206 14 202 189 116 184 161 40 1 197 218 181 254 128 221 199 151 54 148 27 66 15 42 33 252 168 67 236 69 0 12 222 253 148 64 244 101 122 133 24 247 247 65 236 165 217 82 154 252 114 140 97 133 133 12 14 189 32 131 239 199 12 37 41 41 176 213 200 238 101 26 250 234 100 218 24 234 70 79 196 61 185 210 65 217 14 249 156 243 46 71 126 99 68 123 246 89 153 216 155 57 236 213 223 138 6 154 151 205 96 207 129 224 93 193 231 244 211 189 62 28 202 255 63 204 182 213 84 231 96 198 175 158 166 148 90 192 135 220 188 235 221 253 51 160 121 71 58 97 85 27 193 132 191 159 34 172 236 17 122 93 3 30 32 172 237 22 184 7 127 119 19 150 86 3 141 248 75 195 67 200 158 5 200 149 149 17 102 155 7 155 16 251 6 97 139 125 208 137 216 119 9 43 248 62 213 17 219 67 216 170 76 120 10 177 195 132 37 31 195 186 4 161 159 176 251 251 224 87 168 36 223 14 205 91 5 175 34 134 111 234 96 142 251 225 8 98 124 115 98 237 34 56 134 24 223 22 203 253 12 188 135 88 47 97 70 19 12 226 8 132 207 118 166 45 102 169 248 220 7 233 6 107 222 97 168 177 225 110 194 74 191 195 112 234 106 224 251 11 27 127 201 230 32 198 117 253 242 17 118 39 170 200 243 101 31 101 184 117 155 189 153 107 214 197 170 16 163 185 11 172 63 194 112 194 156 195 91 197 204 23 88 3 98 60 199 93 235 25 62 26 146 203 181 47 126 150 173 7 152 37 175 163 244 210 220 105 54 189 236 3 170 99 28 227 186 78 182 98 191 145 28 1 3 214 167 223 233 113 103 89 236 141 78 135 193 108 247 142 44 89 160 13 143 92 148 119 74 50 99 23 194 28 210 249 162 77 52 227 36 90 181 50 123 26 164 187 36 183 54 182 118 197 175 133 51 102 208 254 115 145 211 143 68 165 214 122 98 73 46 255 244 5 157 188 251 142 91 134 110 201 165 195 181 188 40 189 201 225 197 195 179 120 173 221 231 118 186 27 253 233 17 101 139 219 3 62 187 95 83 220 224 12 120 124 234 18 143 59 160 169 177 251 26 165 128 174 192 225 144 80 98 171 61 208 132 247 121 154 73 164 72 68 180 216 118 54 191 22 145 89 222 75 138 240 14 195 17 218 26 115 137 5 147 77 226 227 138 48 143 216 187 42 201 4 225 210 27 191 30 230 243 63 0 0 0 12 0 197 58 234 49 223 62 175 247 59 123 203 94 155 152 33 192 110 61 182 50 47 143 211 179 86 174 178 55 114 156 112 197 83 79 246 120 78 77 11 255 177 243 56 37 199 90 9 127 50 224 71 56 225 132 147 17 39 3 110 3 194 9 139 112 194 245 186 149 140 57 57 78 184 145 9 35 156 60 247 34 140 176 8 39 156 60 39 140 12 56 225 70 248 145 227 228 216 69 158 17 150 132 29 112 111 43 243 8 199 87 71 184 158 215 160 149 155 23 45 9 10 56 153 112 114 156 112 60 193 3 133 199 2 62 175 195 7 52 45 68 8 145 224 93 70 72 113 19 188 159 131 154 15 222 143 192 251 20 168 42 98 131 111 141 246 114 198 56 49 243 60 104 66 142 95 222 197 244 205 135 242 42 254 3 129 71 36 195 182 237 84 156 72 191 250 165 28 178 6 190 155 78 10 9 177 149 92 11 146 162 126 218 69 120 115 94 171 173 229 8 231 205 32 141 140 7 28 233 243 179 43 201 212 27 56 219 36 120 87 219 54 191 112 157 252 72 160 230 104 37 5 164 142 57 132 122 164 255 113 212 135 77 69 143 84 6 134 198 148 120 182 160 62 76 98 20 155 236 195 105 116 214 170 33 197 167 171 29 198 88 51 143 161 174 232 203 46 122 22 186 88 8 122 47 232 69 168 23 131 110 5 189 4 235 11 64 203 160 231 199 107 207 245 128 126 157 188 1 244 236 100 255 5 70 167 87 14 108 85 117 37 96 106 122 119 122 4 212 159 244 169 236 147 142 190 3 93 44 237 203 41 189 0 250 159 121 188 77 222 133 110 114 147 243 200 103 243 120 74 235 54 76 53 208 62 226 136 185 168 39 247 206 141 125 6 93 84 129 62 217 63 143 108 252 46 51 23 71 175 250 203 197 91 243 249 132 124 74 237 145 156 79 30 155 79 147 98 30 210 244 209 241 144 39 80 47 195 57 228 160 30 246 207 242 137 121 77 71 142 152 215 212 99 31 255 92 5 186 240 196 183 31 69 111 204 79 218 36 185 152 107 173 249 229 178 249 53 107 209 112 112 60 187 230 161 94 141 253 22 161 94 137 90 248 110 3 234 106 212 107 80 79 177 230 94 208 119 229 235 239 250 231 157 143 223 109 68 45 252 186 14 117 30 234 181 168 133 63 114 81 59 81 175 232 221 229 46 6 189 10 253 63 236 159 77 200 75 250 126 189 229 39 225 255 15 200 135 52 158 111 229 53 248 103 183 26 14 106 135 198 12 244 248 157 188 20 243 117 245 94 189 240 226 159 190 223 140 243 77 206 105 104 175 128 156 98 38 255 99 177 120 242 223 189 66 202 146 28 64 47 77 246 255 104 48 172 223 93 142 224 177 163 22 249 34 114 101 56 63 102 99 189 20 117 9 234 98 244 199 28 172 207 66 45 114 70 228 139 240 93 50 71 166 161 46 67 61 19 245 12 212 34 119 69 110 36 115 183 150 212 77 250 30 180 45 49 89 230 136 60 119 83 115 125 185 167 210 231 243 84 54 170 109 105 31 8 255 12 245 225 108 174 223 190 179 229 110 27 228 81 171 15 216 98 7 250 200 101 123 235 62 57 160 140 183 145 232 127 168 143 252 136 174 237 131 197 85 167 19 9 141 180 146 53 222 135 221 43 155 7 238 140 130 61 130 59 212 71 158 119 183 103 71 52 108 170 29 202 184 65 232 93 131 62 144 155 172 15 81 23 249 222 220 25 85 228 246 242 93 222 242 213 107 27 70 230 225 22 5 204 77 200 75 233 82 57 191 94 192 149 66 186 52 239 12 203 205 74 158 155 240 173 143 229 102 5 230 54 159 28 189 49 244 100 50 162 207 217 240 188 20 243 250 26 107 105 5 156 73 169 175 100 156 220 187 253 168 75 138 25 7 66 109 180 2 76 74 141 101 252 118 236 173 61 148 106 70 219 104 5 220 65 169 175 101 220 213 55 165 177 16 39 4 21 200 32 74 61 146 201 172 190 156 178 55 145 10 21 72 10 74 125 57 147 44 189 87 127 88 204 169 180 2 251 3 36 85 94 73 102 223 160 105 45 197 252 53 45 126 150 219 14 23 228 164 253 43 187 191 59 162 24 149 7 134 169 44 235 25 149 85 38 115 106 145 71 11 7 85 83 213 194 114 8 150 65 93 179 58 96 155 2 167 210 74 54 167 230 120 213 46 37 232 213 130 202 237 126 45 106 14 167 58 106 14 42 97 51 61 34 139 154 139 189 62 29 133 235 73 80 151 15 221 239 213 201 169 249 9 170 95 233 50 111 146 45 106 30 167 78 222 222 188 211 84 67 169 17 89 212 124 156 171 87 233 160 247 166 137 185 22 160 95 233 173 108 196 175 108 71 100 84 86 153 34 60 164 235 154 254 183 135 10 121 162 56 192 218 126 143 47 69 165 123 31 79 20 182 1 22 161 243 220 145 72 72 241 203 161 246 251 206 155 202 123 45 112 7 131 186 98 24 45 141 50 141 149 65 180 149 94 211 176 215 29 138 161 69 245 192 176 35 172 94 167 139 204 211 229 200 104 230 253 70 45 230 212 220 109 138 97 202 33 179 166 51 250 59 154 109 223 130 122 146 148 96 54 32 117 34 27 74 145 90 171 133 130 74 218 176 22 117 6 186 193 15 199 236 145 36 178 168 51 5 21 162 238 33 181 12 19 165 57 160 171 145 212 88 147 212 89 152 175 176 177 133 70 60 107 81 103 11 55 168 93 116 105 155 112 195 28 116 121 125 64 11 63 116 121 57 205 33 231 229 204 53 248 248 23 87 22 240 28 162 21 184 193 50 106 230 102 123 252 220 153 151 144 10 21 184 100 51 106 230 242 29 183 239 105 228 84 90 129 123 36 163 102 238 151 176 93 191 143 84 168 192 21 78 244 58 118 181 139 215 158 151 4 245 188 4 183 91 70 205 220 122 227 213 215 46 32 21 42 112 73 19 212 177 203 91 188 129 216 145 10 21 50 159 222 2 156 151 31 49 58 211 102 229 115 237 73 204 181 135 84 184 160 87 251 171 89 29 35 193 64 247 33 122 155 224 251 16 173 44 224 84 123 247 65 57 189 175 49 170 156 160 202 100 33 82 13 51 168 106 99 212 189 9 234 94 178 136 83 29 64 133 37 62 133 181 168 139 19 84 93 13 239 31 165 182 38 168 173 100 9 186 129 221 39 198 220 48 208 107 165 139 222 27 222 203 5 143 215 41 114 106 225 96 247 91 78 165 149 165 156 234 188 65 133 59 197 45 42 189 246 198 188 94 79 29 171 84 97 150 111 85 140 246 45 209 209 205 102 96 139 90 150 160 30 84 83 91 222 96 150 47 199 205 198 167 107 0 53 38 182 195 21 184 55 240 104 77 239 13 244 218 206 169 180 178 18 183 67 143 214 17 209 194 169 75 133 213 235 42 164 178 94 235 195 145 232 237 77 202 114 195 106 78 117 178 13 59 125 22 177 122 93 195 169 89 53 244 156 148 206 6 139 186 22 39 4 80 186 86 182 105 93 247 230 186 142 83 243 154 52 83 221 167 6 110 239 242 131 212 245 232 114 190 158 60 112 249 6 78 205 134 91 148 169 107 169 56 183 168 27 209 229 94 37 156 78 161 65 106 181 200 33 85 14 105 251 31 76 104 19 78 136 110 216 53 112 47 251 107 66 155 197 149 2 178 92 31 155 208 64 54 184 24 245 108 182 184 29 14 247 74 255 181 224 84 90 113 243 43 247 189 155 175 20 115 251 124 244 191 49 250 71 23 219 243 50 127 128 197 27 28 167 197 158 231 56 141 93 192 95 118 196 230 107 86 246 95 191 158 0 193 55 18 161 223 208 77 80 250 230 75 19 212 108 250 239 153 175 209 128 26 251 230 25 248 209 233 48 116 253 147 175 54 100 208 111 254 7)! !!InterpreterSupportCode class methodsFor: 'source files'!dnrFile    ^ '/*         File:        DNR.c         Contains:    DNR library for MPW      Copyright:    ⌐ 1989-1995 by Apple Computer, Inc., all rights reserved    Version:    Technology:            Networking                Package:            Use with MacTCP 2.0.6 and the Universal                                    Interfaces 2.1b1                Change History (most recent first):        <3>     1/23/95    rrk      implemented use of universal procptrs                                 Changed selector name HINFO to HXINFO                                 due to conflict of name in MacTCP header                                 Removed use of TrapAvailable and exchanged                                 for the TrapExists call.                                Changed symbol codeHandle to gDNRCodeHndl                                Changed symbol dnr to gDNRCodePtr    Further modifications by Steve Falkenburg, Apple MacDTS 8/91    Modifications by Jim Matthews, Dartmouth College, 5/91    */#ifndef __OSUTILS__#include <OSUtils.h>#endif#ifndef __ERRORS__#include <Errors.h>#endif#ifndef __FILES__#include <Files.h>#endif#ifndef __RESOURCES__#include <Resources.h>#endif#ifndef __MEMORY__#include <Memory.h>#endif#ifndef __TRAPS__#include <Traps.h>#endif#ifndef __GESTALTEQU__#include <GestaltEqu.h>#endif#ifndef __FOLDERS__#include <Folders.h>#endif#ifndef __TOOLUTILS__#include <ToolUtils.h>#endif#ifndef __MACTCP__#include "MacTCP.h"#endif#ifndef __ADDRESSXLATION__#include "AddressXlation.h"#endif// think C compatibility stuff#ifndef    _GestaltDispatch#define    _GestaltDispatch    _Gestalt#endif/* RRK Modification 1/95 - commenting out the following defines as they are    defined in the DNRCalls.h header file*/void GetSystemFolder(short *vRefNumP, long *dirIDP);void GetCPanelFolder(short *vRefNumP, long *dirIDP);short SearchFolderForDNRP(long targetType, long targetCreator, short vRefNum, long dirID);short OpenOurRF(void);short    NumToolboxTraps(void);TrapType    GetTrapType(short theTrap);Boolean TrapExists(short theTrap);static Handle             gDNRCodeHndl = nil;static ProcPtr            gDNRCodePtr = nil;/*    Check the bits of a trap number to determine its type. *//* InitGraf is always implemented (trap $A86E).  If the trap table is big** enough, trap $AA6E will always point to either Unimplemented or some other** trap, but will never be the same as InitGraf.  Thus, you can check the size** of the trap table by asking if the address of trap $A86E is the same as** $AA6E. */#pragma segment UtilMainshort    NumToolboxTraps(void){    if (NGetTrapAddress(_InitGraf, ToolTrap) == NGetTrapAddress(0xAA6E, ToolTrap))        return(0x200);    else        return(0x400);}#pragma segment UtilMainTrapType    GetTrapType(short theTrap){    /* OS traps start with A0, Tool with A8 or AA. */    if ((theTrap & 0x0800) == 0)                    /* per D.A. */        return(OSTrap);    else        return(ToolTrap);}Boolean TrapExists(short theTrap){    TrapType    theTrapType;    theTrapType = GetTrapType(theTrap);    if ((theTrapType == ToolTrap) && ((theTrap &= 0x07FF) >= NumToolboxTraps()))        theTrap = _Unimplemented;    return(NGetTrapAddress(_Unimplemented, ToolTrap) !!= NGetTrapAddress(theTrap, theTrapType));}void GetSystemFolder(short *vRefNumP, long *dirIDP){    SysEnvRec info;    long wdProcID;        SysEnvirons(1, &info);    if (GetWDInfo(info.sysVRefNum, vRefNumP, dirIDP, &wdProcID) !!= noErr)     {        *vRefNumP = 0;        *dirIDP = 0;    }}void GetCPanelFolder(short *vRefNumP, long *dirIDP){    Boolean hasFolderMgr = false;    long feature;        if (TrapExists(_GestaltDispatch)) if (Gestalt(gestaltFindFolderAttr, &feature) == noErr) hasFolderMgr = true;    if (!!hasFolderMgr)     {        GetSystemFolder(vRefNumP, dirIDP);        return;    }    else     {        if (FindFolder(kOnSystemDisk, kControlPanelFolderType, kDontCreateFolder, vRefNumP, dirIDP) !!= noErr)         {            *vRefNumP = 0;            *dirIDP = 0;        }    }}    /* SearchFolderForDNRP is called to search a folder for files that might     contain the ''dnrp'' resource */short SearchFolderForDNRP(long targetType, long targetCreator, short vRefNum, long dirID){    HParamBlockRec fi;    Str255 filename;    short refnum;        fi.fileParam.ioCompletion = nil;    fi.fileParam.ioNamePtr = filename;    fi.fileParam.ioVRefNum = vRefNum;    fi.fileParam.ioDirID = dirID;    fi.fileParam.ioFDirIndex = 1;        while (PBHGetFInfo(&fi, false) == noErr)     {        /* scan system folder for driver resource files of specific type & creator */        if (fi.fileParam.ioFlFndrInfo.fdType == targetType &&            fi.fileParam.ioFlFndrInfo.fdCreator == targetCreator)         {            /* found the MacTCP driver file? */            refnum = HOpenResFile(vRefNum, dirID, filename, fsRdPerm);            if (GetIndResource(''dnrp'', 1) == NULL)                CloseResFile(refnum);            else                return refnum;        }        /* check next file in system folder */        fi.fileParam.ioFDirIndex++;        fi.fileParam.ioDirID = dirID;    /* PBHGetFInfo() clobbers ioDirID */    }    return(-1);}    /* OpenOurRF is called to open the MacTCP driver resources */short OpenOurRF(void){    short refnum;    short vRefNum;    long dirID;        /* first search Control Panels for MacTCP 1.1 */    GetCPanelFolder(&vRefNum, &dirID);    refnum = SearchFolderForDNRP(''cdev'', ''ztcp'', vRefNum, dirID);    if (refnum !!= -1) return(refnum);            /* next search System Folder for MacTCP 1.0.x */    GetSystemFolder(&vRefNum, &dirID);    refnum = SearchFolderForDNRP(''cdev'', ''mtcp'', vRefNum, dirID);    if (refnum !!= -1) return(refnum);            /* finally, search Control Panels for MacTCP 1.0.x */    GetCPanelFolder(&vRefNum, &dirID);    refnum = SearchFolderForDNRP(''cdev'', ''mtcp'', vRefNum, dirID);    if (refnum !!= -1) return(refnum);            return -1;}    OSErr OpenResolver(char *fileName){    short             refnum;    OSErr             rc;        if (gDNRCodePtr !!= nil)        /* resolver already loaded in */        return(noErr);            /* open the MacTCP driver to get DNR resources. Search for it based on       creator & type rather than simply file name */        refnum = OpenOurRF();    /* ignore failures since the resource may have been installed in the        System file if running on a Mac 512Ke */           /* load in the DNR resource package */    gDNRCodeHndl = GetIndResource(''dnrp'', 1);    if (gDNRCodeHndl == nil)    {        /* can''t open DNR */        return(ResError());    }        DetachResource(gDNRCodeHndl);    if (refnum !!= -1)     {        CloseResFile(refnum);    }            /* lock the DNR resource since it cannot be reloated while opened */    MoveHHi(gDNRCodeHndl);    HLock(gDNRCodeHndl);        gDNRCodePtr = (ProcPtr)*gDNRCodeHndl;        /* call open resolver */    // RRK modification 1/95 use CallOpenResolverProc define to call UPP        rc = CallOpenResolverProc(gDNRCodePtr, OPENRESOLVER, fileName);    if (rc !!= noErr)     {        /* problem with open resolver, flush it */        HUnlock(gDNRCodeHndl);        DisposeHandle(gDNRCodeHndl);        gDNRCodePtr = nil;    }    return(rc);}OSErr CloseResolver(void){        if (gDNRCodePtr == nil)        /* resolver not loaded error */        return(notOpenErr);            /* call close resolver */    // RRK modification 1/95 use CallCloseResolverProc define to call UPP    // (void) (*dnr)(CLOSERESOLVER);    CallCloseResolverProc(gDNRCodePtr, CLOSERESOLVER);        /* release the DNR resource package */    HUnlock(gDNRCodeHndl);    DisposeHandle(gDNRCodeHndl);    gDNRCodePtr = nil;    return(noErr);}    // RRK modification 1/95 declare parameter resultProc to be of type     // ResultProcUPP instead of a long    OSErr StrToAddr(char *hostName, struct hostInfo *rtnStruct,             ResultUPP resultproc, Ptr userDataPtr){    if (gDNRCodePtr == nil)        /* resolver not loaded error */        return(notOpenErr);            // RRK modification 1/95 use CallStrToAddrProc define to call UPP    // return((*dnr)(STRTOADDR, hostName, rtnStruct, resultproc, userDataPtr));                return (CallStrToAddrProc(gDNRCodePtr, STRTOADDR, hostName, rtnStruct, resultproc, userDataPtr));}    OSErr AddrToStr(unsigned long addr, char *addrStr){    OSErr    err;    if (gDNRCodePtr == nil)        /* resolver not loaded error */        return(notOpenErr);            // RRK modification 1/95 use CallAddrToStrProc define to call UPP    // (*dnr)(ADDRTOSTR, addr, addrStr);        err = CallAddrToStrProc(gDNRCodePtr, ADDRTOSTR, addr, addrStr);    return(noErr);}    OSErr EnumCache(EnumResultUPP resultproc, Ptr userDataPtr){    if (gDNRCodePtr == nil)        /* resolver not loaded error */        return(notOpenErr);            // RRK modification 1/95 use CallEnumCacheProc define to call UPP    // return((*dnr)(ENUMCACHE, resultproc, userDataPtr));    return (CallEnumCacheProc(gDNRCodePtr, ENUMCACHE, resultproc, userDataPtr));}        OSErr AddrToName(unsigned long addr, struct hostInfo *rtnStruct,             ResultUPP resultproc, Ptr userDataPtr){    if (gDNRCodePtr == nil)        /* resolver not loaded error */        return(notOpenErr);            // RRK modification 1/95 use CallAddrToNameProc define to call UPP    // return((*dnr)(ADDRTONAME, addr, rtnStruct, resultproc, userDataPtr));    return(CallAddrToNameProc(gDNRCodePtr, ADDRTONAME, addr, rtnStruct, resultproc, userDataPtr));}extern OSErr HInfo(char *hostName, struct returnRec *returnRecPtr,             ResultProc2UPP resultProc, Ptr userDataPtr){    if (gDNRCodePtr == nil)        /* resolver not loaded error */        return(notOpenErr);            // RRK modification 1/95 use CallHInfoProc define to call UPP    // return((*dnr)(HINFO, hostName, returnRecPtr, resultProc, userDataPtr));    return(CallHInfoProc(gDNRCodePtr, HXINFO, hostName, returnRecPtr, resultProc, userDataPtr));}    extern OSErr MXInfo(char *hostName, struct returnRec *returnRecPtr,             ResultProc2UPP resultProc, Ptr userDataPtr){    if (gDNRCodePtr == nil)        /* resolver not loaded error */        return(notOpenErr);            // RRK modification 1/95 use CallHInfoProc define to call UPP    // return((*dnr)(MXINFO, hostName, returnRecPtr, resultProc, userDataPtr));    return(CallMXInfoProc(gDNRCodePtr, MXINFO, hostName, returnRecPtr, resultProc, userDataPtr));}    /* removed ; (causes syntax err in Think C 5.0 */    '.! !!InterpreterSupportCode class methodsFor: 'source files' stamp: 'jm 9/21/97 18:08'!filePrimsFile    ^ '#include "sq.h"/***    The state of a file is kept in the following structure,    which is stored directly in a Squeak bytes object.    NOTE: The Squeak side is responsible for creating an    object with enough room to store sizeof(SQFile) bytes.    The session ID is used to detect stale file objects--    files that were still open when an image was written.    The file pointer of such files is meaningless.    Files are always opened in binary mode; Smalltalk code    does (or someday will do) line-end conversion if needed.    Writeable files are opened read/write. The stdio spec    requires that a positioning operation be done when    switching between reading and writing of a read/write    filestream. The lastOp field records whether the last    operation was a read or write operation, allowing this    positioning operation to be done automatically if needed.    typedef struct {        File    *file;        int        sessionID;        int        writable;        int        fileSize;        int        lastOp;  // 0 = uncommitted, 1 = read, 2 = write //    } SQFile;***//*** Constants ***/#define UNCOMMITTED    0#define READ_OP        1#define WRITE_OP    2#ifndef SEEK_SET#define SEEK_SET    0#define SEEK_CUR    1#define SEEK_END    2#endif/*** Variables ***/int thisSession = 0;int sqFileAtEnd(SQFile *f) {    /* Return true if the file''s read/write head is at the end of the file. */    if (!!sqFileValid(f)) return success(false);    return ftell(f->file) == f->fileSize;}int sqFileClose(SQFile *f) {    /* Close the given file. */    if (!!sqFileValid(f)) return success(false);    fclose(f->file);    f->file = NULL;    f->sessionID = 0;    f->writable = false;    f->fileSize = 0;    f->lastOp = UNCOMMITTED;}int sqFileDeleteNameSize(int sqFileNameIndex, int sqFileNameSize) {    char cFileName[1000];    int i, err;    if (sqFileNameSize >= 1000) {        return success(false);    }    /* copy the file name into a null-terminated C string */    for (i = 0; i < sqFileNameSize; i++) {        cFileName[i] = *((char *) (sqFileNameIndex + i));    }    cFileName[sqFileNameSize] = 0;    err = remove(cFileName);    if (err) {        return success(false);    }}int sqFileGetPosition(SQFile *f) {    /* Return the current position of the file''s read/write head. */    int position;    if (!!sqFileValid(f)) return success(false);    position = ftell(f->file);    if (position < 0) return success(false);    return position;}int sqFileInit(void) {    /* Create a session ID that is unlikely to be repeated.       Zero is never used for a valid session number.       Should be called once at startup time.    */    thisSession = clock() + time(NULL);    if (thisSession == 0) thisSession = 1;    /* don''t use 0 */}int sqFileOpen(SQFile *f, int sqFileNameIndex, int sqFileNameSize, int writeFlag) {    /* Opens the given file using the supplied sqFile structure       to record its state. Fails with no side effects if f is       already open. Files are always opened in binary mode;       Squeak must take care of any line-end character mapping.    */    char cFileName[1001];    int i;    /* don''t open an already open file */    if (sqFileValid(f)) return success(false);    /* copy the file name into a null-terminated C string */    if (sqFileNameSize > 1000) {        return success(false);    }    for (i = 0; i < sqFileNameSize; i++) {        cFileName[i] = *((char *) (sqFileNameIndex + i));    }    cFileName[sqFileNameSize] = 0;    if (writeFlag) {        /* First try to open an existing file read/write: */        f->file = fopen(cFileName, "r+b");        if (f->file == NULL) {            /* Previous call fails if file does not exist. In that case,               try opening it in write mode to create a new, empty file.            */            f->file = fopen(cFileName, "w+b");            if (f->file !!= NULL) {                /* set the type and creator of newly created Mac files */                dir_SetMacFileTypeAndCreator(cFileName, strlen(cFileName), "TEXT", "R*ch");                }        }        f->writable = true;    } else {        f->file = fopen(cFileName, "rb");        f->writable = false;    }    if (f->file == NULL) {        f->sessionID = 0;        f->fileSize = 0;        return success(false);    } else {        f->sessionID = thisSession;        /* compute and cache file size */        fseek(f->file, 0, SEEK_END);        f->fileSize = ftell(f->file);        fseek(f->file, 0, SEEK_SET);    }    f->lastOp = UNCOMMITTED;}int sqFileReadIntoAt(SQFile *f, int count, int byteArrayIndex, int startIndex) {    /* Read count bytes from the given file into byteArray starting at       startIndex. byteArray is the address of the first byte of a       Squeak bytes object (e.g. String or ByteArray). startIndex       is a zero-based index; that is a startIndex of 0 starts writing       at the first byte of byteArray.    */    char *dst;    int bytesRead;    if (!!sqFileValid(f)) return success(false);    if (f->writable && (f->lastOp == WRITE_OP)) fseek(f->file, 0, SEEK_CUR);  /* seek between writing and reading */    dst = (char *) (byteArrayIndex + startIndex);    bytesRead = fread(dst, 1, count, f->file);    f->lastOp = READ_OP;    return bytesRead;}int sqFileRenameOldSizeNewSize(int oldNameIndex, int oldNameSize, int newNameIndex, int newNameSize) {    char cOldName[1000], cNewName[1000];    int i, err;    if ((oldNameSize >= 1000) || (newNameSize >= 1000)) {        return success(false);    }    /* copy the file names into null-terminated C strings */    for (i = 0; i < oldNameSize; i++) {        cOldName[i] = *((char *) (oldNameIndex + i));    }    cOldName[oldNameSize] = 0;    for (i = 0; i < newNameSize; i++) {        cNewName[i] = *((char *) (newNameIndex + i));    }    cNewName[newNameSize] = 0;    err = rename(cOldName, cNewName);    if (err) {        return success(false);    }}int sqFileSetPosition(SQFile *f, int position) {    /* Set the file''s read/write head to the given position. */    if (!!sqFileValid(f)) return success(false);    fseek(f->file, position, SEEK_SET);    f->lastOp = UNCOMMITTED;}int sqFileSize(SQFile *f) {    /* Return the length of the given file. */    if (!!sqFileValid(f)) return success(false);    return f->fileSize;}int sqFileValid(SQFile *f) {    return (        (f !!= NULL) &&        (f->file !!= NULL) &&        (f->sessionID == thisSession));}int sqFileWriteFromAt(SQFile *f, int count, int byteArrayIndex, int startIndex) {    /* Write count bytes to the given writable file starting at startIndex       in the given byteArray. (See comment in sqFileReadIntoAt for interpretation       of byteArray and startIndex).    */    char *src;    int bytesWritten, position;    if (!!(sqFileValid(f) && f->writable)) return success(false);    if (f->lastOp == READ_OP) fseek(f->file, 0, SEEK_CUR);  /* seek between reading and writing */    src = (char *) (byteArrayIndex + startIndex);    bytesWritten = fwrite(src, 1, count, f->file);    position = ftell(f->file);    if (position > f->fileSize) {        f->fileSize = position;  /* update file size */    }    if (bytesWritten !!= count) {        success(false);    }    f->lastOp = WRITE_OP;    return bytesWritten;}'! !!InterpreterSupportCode class methodsFor: 'source files'!macDirectoryFile    ^ '#include <MacHeaders.h>#include "sq.h"/***    The interface to the directory primitive is path based.    That is, the client supplies a Squeak string describing    the path to the directory on every call. To avoid traversing    this path on every call, a cache is maintained of the last    path seen, along with the Mac volume and folder reference    numbers corresponding to that path.***//*** Constants ***/#define ENTRY_FOUND     0#define NO_MORE_ENTRIES 1#define BAD_PATH        2#define DELIMITOR '':''#define MAX_PATH 2000/*** Variables ***/char lastPath[MAX_PATH + 1];int  lastPathValid = false;int  lastRefNum = 0;int  lastVolNum = 0;/*** Functions ***/int convertToSqueakTime(int macTime);int equalsLastPath(char *pathString, int pathStringLength);int lookupDirectory(int volRefNum, int folderRefNum, char *name, int *refNumPtr);int lookupPath(char *pathString, int pathStringLength, int *refNumPtr, int *volNumPtr);int lookupVolume(char *volName, int *refNumPtr);int prefixPathWith(char *pathName, int pathNameSize, int pathNameMax, char *prefix);int recordPath(char *pathString, int pathStringLength, int refNum, int volNum);int convertToSqueakTime(int macTime) {    /* Squeak epoch is Jan 1, 1901, 3 non-leap years earlier than Mac one */    return macTime + (3 * 365 * 24 * 60 * 60);}int dir_Create(char *pathString, int pathStringLength) {    /* Create a new directory with the given path. By default, this       directory is created in the current directory. Use       a full path name such as "MyDisk:Working:New Folder" to       create folders elsewhere. */    Str255 name;    HParamBlockRec pb;    int i;    for (i = 0; i < pathStringLength; i++) {        name[i] = pathString[i];    }    name[i] = 0; /* string terminator */    c2pstr((char *) name);    pb.fileParam.ioNamePtr = name;    pb.fileParam.ioVRefNum = 0;    pb.fileParam.ioDirID = 0;    return PBDirCreateSync(&pb) == noErr;}int dir_Delimitor(void) {    return DELIMITOR;}int dir_Lookup(char *pathString, int pathStringLength, int index,  /* outputs: */  char *name, int *nameLength, int *creationDate, int *modificationDate,  int *isDirectory, int *sizeIfFile) {    /* Lookup the index-th entry of the directory with the given path, starting       at the root of the file system. Set the name, name length, creation date,       creation time, directory flag, and file size (if the entry is a file).       Return:    0     if a entry is found at the given index                   1    if the directory has fewer than index entries                   2    if the given path has bad syntax or does not reach a directory    */    int okay, newRefNum, newVolNum;    HVolumeParam volumeParams;    CInfoPBRec dirParams;    /* default return values */    *name             = 0;    *nameLength       = 0;    *creationDate     = 0;    *modificationDate = 0;    *isDirectory      = false;    *sizeIfFile       = 0;    if ((pathStringLength == 0)) {        /* get volume info */        volumeParams.ioNamePtr = (unsigned char *) name;        volumeParams.ioVRefNum = 0;        volumeParams.ioVolIndex = index;        okay = PBHGetVInfoSync((HParmBlkPtr) &volumeParams) == noErr;        if (okay) {            p2cstr((unsigned char *) name);            *nameLength       = strlen(name);            *creationDate     = convertToSqueakTime(volumeParams.ioVCrDate);            *modificationDate = convertToSqueakTime(volumeParams.ioVLsMod);            *isDirectory      = true;            *sizeIfFile       = 0;            return ENTRY_FOUND;        } else {            return NO_MORE_ENTRIES;        }    } else {        /* get file or directory info */        if (!!equalsLastPath(pathString, pathStringLength)) {            /* lookup and cache the refNum for this path */            okay = lookupPath(pathString, pathStringLength, &newRefNum, &newVolNum);            if (okay) {                recordPath(pathString, pathStringLength, newRefNum, newVolNum);            } else {                return BAD_PATH;            }        }        dirParams.hFileInfo.ioNamePtr = (unsigned char *) name;        dirParams.hFileInfo.ioFVersNum = 0;        dirParams.hFileInfo.ioFDirIndex = index;        if (lastRefNum < 0) {            dirParams.hFileInfo.ioVRefNum = lastRefNum;            dirParams.hFileInfo.ioDirID = 0;        } else {            dirParams.hFileInfo.ioVRefNum = lastVolNum;            dirParams.hFileInfo.ioDirID = lastRefNum;        }        okay = PBGetCatInfoSync(&dirParams) == noErr;        if (okay) {            p2cstr((unsigned char *) name);            *nameLength       = strlen(name);            *creationDate     = convertToSqueakTime(dirParams.hFileInfo.ioFlCrDat);            *modificationDate = convertToSqueakTime(dirParams.hFileInfo.ioFlMdDat);            if ((dirParams.hFileInfo.ioFlAttrib & 16) !!= 0) {                *isDirectory  = true;                *sizeIfFile   = 0;            } else {                *isDirectory  = false;                *sizeIfFile   = dirParams.hFileInfo.ioFlLgLen;            }            return ENTRY_FOUND;        } else {            return NO_MORE_ENTRIES;        }    }}int dir_PathToWorkingDir(char *pathName, int pathNameMax) {    /* Fill in the given string with the full path from a root volume to       to current working directory. (At startup time, the working directory       is set to the application''s directory. Fails if the given string is not       long enough to hold the entire path. (Use at least 1000 characters to       be safe.)    */    char thisName[256];    CInfoPBRec pb;    int nextDirRefNum, pathLen;    /* initialize string copying state */    pathName[0] = 0;    pathLen = 0;    /* get refNum of working directory */    strcpy(thisName, ":");    pb.hFileInfo.ioNamePtr = c2pstr(thisName);    pb.hFileInfo.ioVRefNum = 0;    pb.hFileInfo.ioFDirIndex = 0;    pb.hFileInfo.ioDirID = 0;    if (PBGetCatInfoSync(&pb) !!= noErr) {        nextDirRefNum = 0;    }    nextDirRefNum = pb.hFileInfo.ioDirID;    while (true) {        thisName[0] = 0;        pb.hFileInfo.ioFDirIndex = -1; /* map ioDirID -> name */        pb.hFileInfo.ioVRefNum = 0;        pb.hFileInfo.ioDirID = nextDirRefNum;        if (PBGetCatInfoSync(&pb) !!= noErr) {            break;  /* we''ve reached the root */        }        p2cstr((unsigned char *) thisName);        pathLen = prefixPathWith(pathName, pathLen, pathNameMax, thisName);        nextDirRefNum = pb.dirInfo.ioDrParID;    }    return pathLen;}dir_SetMacFileTypeAndCreator(char *filename, int filenameSize, char *fType, char *fCreator) {    /* Set the Macintosh type and creator of the given file. */    /* Note: On other platforms, this is just a noop. */    Str255 name;    FInfo finderInfo;    int i;    /* copy file name into a Pascal string */    if (filenameSize > 255) return false;    name[0] = filenameSize;    for (i = 1; i <= filenameSize; i++) {        name[i] = filename[i - 1];    }    if (GetFInfo(name, 0, &finderInfo) !!= noErr) return false;    finderInfo.fdType = *((int *) fType);    finderInfo.fdCreator = *((int *) fCreator);    if (SetFInfo(name, 0, &finderInfo) !!= noErr) return false;    return true;}int equalsLastPath(char *pathString, int pathStringLength) {    /* Return true if the lastPath cache is valid and the       given Squeak string equals it. */    int i, ch;    if (!!lastPathValid ||        (pathStringLength > MAX_PATH)) {            return false;    }    for (i = 0; i < pathStringLength; i++) {        ch = lastPath[i];        if ((ch == 0) || (ch !!= pathString[i])) return false;    }    return lastPath[i] == 0;}int lookupDirectory(int volRefNum, int folderRefNum, char *name, int *refNumPtr) {    /* Look up the next directory in a path starting from the folder and volume       with the given reference numbers and setting *refNumPtr to the reference       number of the resulting folder. Return true if this succeeds. */    CInfoPBRec pb;    c2pstr((char *) name);    pb.hFileInfo.ioNamePtr = (unsigned char *) name;    pb.hFileInfo.ioFVersNum = 0;    pb.hFileInfo.ioFDirIndex = 0;    pb.hFileInfo.ioVRefNum = volRefNum;    pb.hFileInfo.ioDirID = folderRefNum;    if (PBGetCatInfoSync(&pb) == noErr) {        p2cstr((unsigned char *) name);        *refNumPtr = pb.hFileInfo.ioDirID;        return true;    }    p2cstr((unsigned char *) name);    return false;}int lookupPath(char *pathString, int pathStringLength, int *refNumPtr, int *volNumPtr) {    /* Resolve the given path and return the resulting folder or volume       reference number in *refNumPtr. Return false if the path is bad. */    char chunk[100];    int stIndex, chunkIndex, ch;    int okay, thisVolNum = 0, thisRefNum = 0;    int firstChunk = true, hasLeadingDelimitors = false;    stIndex = 0;    while (stIndex < pathStringLength) {        chunkIndex = 0;        while ((stIndex < pathStringLength) && (pathString[stIndex] == DELIMITOR)) {            /* copy any leading delimitors */            chunk[chunkIndex++] = pathString[stIndex++];            hasLeadingDelimitors = true;        }        while ((stIndex < pathStringLength) && (pathString[stIndex] !!= DELIMITOR)) {            /* copy up to the next delimitor */            ch = chunk[chunkIndex++] = pathString[stIndex++];        }        if (firstChunk && (chunk[chunkIndex] !!= DELIMITOR)) {            /* Add a trailing delimiter to the first chunk of the               path to indicate that it is a volume name. If the               path starts with an initial delimitor, it will be               interpreted as a path relative to the current working               directory even with a trailing delimitor, which is               exactly the behavior we want. */            chunk[chunkIndex++] = DELIMITOR;            if ((stIndex < pathStringLength) && (pathString[stIndex] == DELIMITOR)) {                stIndex++;            }            firstChunk = false;        }        chunk[chunkIndex] = 0;  /* terminate this chunk */        if ((thisVolNum == 0) && !!hasLeadingDelimitors) {            okay = lookupVolume(chunk, &thisVolNum);            thisRefNum = 0;        } else {            okay = lookupDirectory(thisVolNum, thisRefNum, chunk, &thisRefNum);        }        if (!!okay) {            *refNumPtr = 0;            *volNumPtr = 0;            return false;        }    }    *refNumPtr = thisRefNum;    *volNumPtr = thisVolNum;    return true;}int lookupVolume(char *volName, int *refNumPtr) {    /* Look up the volume with the given name and set *refNumPtr       to the reference number of the resulting volume.       Return true if this succeeds. */    int okay;    HVolumeParam volumeParams;    volumeParams.ioNamePtr = c2pstr(volName);    volumeParams.ioVRefNum = 0;    volumeParams.ioVolIndex = -1;    okay = PBHGetVInfoSync((HParmBlkPtr) &volumeParams) == noErr;    p2cstr((unsigned char *) volName);    if (okay) {        *refNumPtr = volumeParams.ioVRefNum;        return true;    }    return false;}int prefixPathWith(char *pathName, int pathNameSize, int pathNameMax, char *prefix) {    /* Insert the given prefix C string plus a delimitor character at the       beginning of the given C string. Return the new pathName size. Fails       if pathName is does not have sufficient space for the result.       Assume: pathName is null terminated.    */    int offset, i;    offset = strlen(prefix) + 1;    if ((pathNameSize + offset) > pathNameMax) {        error("path name to working directory is too long for available space");    }    for (i = pathNameSize; i >= 0; i--) {        /* make room in pathName for prefix (moving string terminator, too) */        pathName[i + offset] = pathName[i];    }    for (i = 0; i < offset; i++) {        /* make room in pathName for prefix */        pathName[i] = prefix[i];    }    pathName[offset - 1] = DELIMITOR;  /* insert delimitor */    return pathNameSize + offset;}int recordPath(char *pathString, int pathStringLength, int refNum, int volNum) {    /* Copy the given Squeak string into the lastPath cache. */    int i;    if (pathStringLength > MAX_PATH) {        lastPath[0] = 0; /* set to empty string */        lastPathValid = false;        lastRefNum = 0;        lastVolNum = 0;        return;    }    for (i = 0; i < pathStringLength; i++) {        lastPath[i] = pathString[i];    }    lastPath[i] = 0; /* string terminator */    lastPathValid = true;    lastRefNum = refNum;    lastVolNum = volNum;}'! !!InterpreterSupportCode class methodsFor: 'source files'!macJoystickFile    ^ '#include <DeskBus.h>#include "sq.h"#define MOUSESTICK_SIGNATURE 0x4A656666#define MAX_STICKS 4typedef struct {    short            rawX;                /* absolute stick position */    short            rawY;    unsigned char    buttons;    char            private1;    short            cursorX;            /* cursor position */    short            cursorY;    char            oldStickType;    char            private2;    char            stickOn;            /* true if stick is connected */    char            private3;    char            stickControlsCursor;    char            applicationAware;    /* settings change with application changes */    char            private4[152];} MouseStickRec;typedef struct {    long            signature;    char            private1[18];    short            stickCount;    char            private2[22];    MouseStickRec    stick[MAX_STICKS];} MouseStickSetRec, *MouseStickSetPtr;/*** Variables ***/MouseStickSetPtr joySticks = nil;  /* pointer to a joystick set or nil */int joystickInit(void) {    /* If a joystick is plugged in and its control panel is installed,       initialize the global pointer ''joySticks'' to the joystick set       data structure. Otherwise, set it to nil.    */    ADBDataBlock adbGetInfo;    MouseStickSetPtr sticks;    int count, i;    joySticks = nil;  /* set to nil in case we don''t find any joysticks */    count = CountADBs();    for (i = 1; i <= count; i++) {        GetADBInfo(&adbGetInfo, GetIndADB(&adbGetInfo, i));        sticks = (MouseStickSetPtr) adbGetInfo.dbDataAreaAddr;        if ((sticks !!= nil) && (sticks->signature == MOUSESTICK_SIGNATURE)) {            joySticks = sticks;            return;        }    }}int joystickRead(int stickIndex) {    /* Return input word for the joystick with the given index (in range [1..2]       on the Macintosh; other platforms may vary). This word is encoded as follows:        <onFlag (1 bit)><buttonFlags (5 bits)><x-value (11 bits)><y-value (11 bits)>       The highest four bits of the input word are zero. If the onFlag bit is zero,       there is no joystick at the given index. This may be because no joystick       is connected or the joystick control panel is not installed. In such,       cases, the entire word will be zero. A maximum of two joysticks are supported       by Gravis''s current version of the control panel. The x and y values are       11-bit signed values in the range [-1024..1023] representing the raw (unencoded)       joystick position. The MouseStick II only uses the approximate range [-650..650].       The range and center values of poorly adjusted joysticks may vary; the client       software should provide a way to adjust the center and scaling to correct.    */    MouseStickRec stickData;    int buttons, xBits, yBits;    if ((joySticks == nil) || (stickIndex < 1) || (stickIndex > 2) ||        (stickIndex > joySticks->stickCount)) {            return 0;  /* no joystick at the given index */    }    stickData = joySticks->stick[stickIndex - 1];  /* 1-based index */    buttons = ~stickData.buttons & 0x1F;    xBits = (0x400 + stickData.rawX) & 0x7FF;    yBits = (0x400 + stickData.rawY) & 0x7FF;    return (1 << 27) | (buttons << 22) | (yBits << 11) | xBits;}'! !!InterpreterSupportCode class methodsFor: 'source files' stamp: 'jm 10/3/97 14:54'!macNetworkFile    ^ '#include <MacHeaders.h>#include "sq.h"#include <stdio.h>#include <stdlib.h>#include <string.h>#include <time.h>#include <Events.h>#include <Devices.h>#include <Processes.h>#include <Traps.h>#include "MacTCP.h"#include "AddressXLation.h"/*** Socket TYpe Constants ***/#define TCPSocketType 0#define UDPSocketType 1/*** Resolver Status Constants ***/#define RESOLVER_UNINITIALIZED    0#define RESOLVER_SUCCESS        1#define RESOLVER_BUSY            2#define RESOLVER_ERROR            3/* Resolver State */typedef struct {    int                semaIndex;    int                status;    int                error;    int                localAddress;    int                remoteAddress;    struct hostInfo    hostInfo;} ResolverStatusRec, *ResolverStatusPtr;/*** TCP Socket Status Constants ***/#define Unconnected                0#define WaitingForConnection    1#define Connected                2#define OtherEndClosed            3#define ThisEndClosed            4/*** TCP Socket State ***/#define SendBufferSize    ( 8 * 1024)#define RecvBufferSize    (16 * 1024)typedef struct {    TCPiopb        tcpPB;                /* TCP parameter block for open/send (must be first) */    TCPiopb        closePB;            /* TCP parameter block for close */    StreamPtr    tcpStream;            /* TCP stream */    void *        next;                /* next socket in a linked list of sockets */    int            semaIndex;    int            connectStatus;    int            dataAvailable;        /* suggests that data may be available */    int            sendInProgress;    int            lastError;//xxx    char        sendBuf[SendBufferSize];    char        rcvBuf[1];            /* must be last; length set when allocated */} TCPSockRec, *TCPSockPtr;typedef struct {    TCPiopb        tcpPB;    TCPSockPtr    mySocket;    struct wdsEntry wds[2];    char        data[SendBufferSize];} TCPSendBuf, *TCPSendBufPtr;#define SendBufCount 2TCPSendBuf sendBufPool[SendBufCount];int nextSendBuf = 0;/*** UDP Socket Status Constants ***/#define UnknowRemoteAddrAndPort    0#define Ready                    1/*** UDP Socket State ***/typedef struct {    void *        next;                /* next socket in a linked list of sockets */    int            remoteAddress;    int            remotePort;    int            semaIndex;    int            connectStatus;    int            dataAvailable;        /* suggests that data may be available */    int            sendInProgress;    int            lastError;    char        sendBuf[SendBufferSize];    char        rcvBuf[1];            /* must be last; length set when allocated */} UDPSockRec, *UDPSockPtr;/*** Variables ***/short                macTCPRefNum = 0;int                    mtuSize = 1024;TCPSockPtr             openTCPSockets = nil;UDPSockPtr            openUDPSockets = nil;ResolverStatusRec     resolver = {0, 0, 0, 0, 0, 0, 0};UniversalProcPtr    myExitHandlerProc = nil;UniversalProcPtr    oldExitHandlerProc = nil;ResultUPP            resolverDoneProc = nil;TCPIOCompletionUPP    tcpCloseDoneProc = nil;TCPIOCompletionUPP    tcpConnectDoneProc = nil;TCPNotifyUPP        tcpNotifyProc = nil;TCPIOCompletionUPP    tcpSendDoneProc = nil;UDPNotifyUPP        udpNotifyProc = nil;UDPIOCompletionUPP    udpSendDoneProc = nil;int                    thisNetSession = 0;/*** Private TCP Socket Functions ***/void *        TCPSockCreate(void);void        TCPSockDestroy(TCPSockPtr s);void        TCPSockRemoveFromOpenList(TCPSockPtr s);int            TCPSockLocalAddress(TCPSockPtr s);int            TCPSockLocalPort(TCPSockPtr s);int            TCPSockRemoteAddress(TCPSockPtr s);int            TCPSockRemotePort(TCPSockPtr s);void        TCPSockConnectTo(TCPSockPtr s, int addr, int port);void        TCPSockListenOn(TCPSockPtr s, int port);void        TCPSockAbortConnection(TCPSockPtr s);void        TCPSockCloseConnection(TCPSockPtr s);int            TCPSockDataAvailable(TCPSockPtr s);int            TCPSockRecvData(TCPSockPtr s, char *buf, int bufSize);int            TCPSockSendData(TCPSockPtr s, char *buf, int bufSize);/*** Private UDP Socket Functions ***/void *        UDPSockCreate(void);void        UDPSockDestroy(UDPSockPtr s);void        UDPSockRemoveFromOpenList(UDPSockPtr s);int            UDPSockLocalAddress(UDPSockPtr s);int            UDPSockLocalPort(UDPSockPtr s);int            UDPSockRemoteAddress(UDPSockPtr s);int            UDPSockRemotePort(UDPSockPtr s);void        UDPSockConnectTo(UDPSockPtr s, int addr, int port);void        UDPSockListenOn(UDPSockPtr s, int port);int            UDPSockRecvData(UDPSockPtr s, char *buf, int bufSize);int            UDPSockSendData(UDPSockPtr s, char *buf, int bufSize);/*** Other Private Functions ***/void        DestroyAllOpenSockets(void);void        InitTCPCmd(int cmd, StreamPtr tcpStream, TCPiopb *paramBlkPtr);void        InstallExitHandler(void);void        MyExitHandler(void);int            PortNumberValid(int port);pascal void    ResolverCompletionRoutine(struct hostInfo *hostInfoPtr, char *userDataPtr);int            ResolverInitialize(int resolverSemaIndex);void        ResolverTerminate(void);int            SocketValid(SocketPtr s);void        TCPCloseCompletionRoutine(struct TCPiopb *s);void        TCPConnectCompletionRoutine(struct TCPiopb *s);pascal void    TCPNotificationRoutine(    StreamPtr s, unsigned short eventCode, Ptr userDataPtr,    unsigned short terminReason, struct ICMPReport *icmpMsg);void        TCPSendCompletionRoutine(struct TCPiopb *s);/*** Network Functions ***/int sqNetworkInit(int resolverSemaIndex) {    /* initialize the network and return 0 if successful */    int localAddr;    UDPiopb paramBlock;    OSErr err = noErr;    if (thisNetSession !!= 0) return 0;  /* noop if network is already initialized */    /* Create a session ID that is unlikely to be repeated.       Zero is never used for a valid session number.       Should be called once at startup time.    */    /* open resolver */    err = ResolverInitialize(resolverSemaIndex);    if (err !!= noErr) {        return -1;    }    /* get local address */    localAddr = sqResolverLocalAddress();    if (sqResolverError() !!= noErr) {        ResolverTerminate();        return -1;    }    /* compute MTU (maximum transfer unit) size */    memset(¶mBlock, 0, sizeof(paramBlock));    paramBlock.csCode = UDPMaxMTUSize;    paramBlock.csParam.mtu.remoteHost = localAddr;    paramBlock.ioCRefNum = macTCPRefNum;    err = PBControlSync((ParmBlkPtr) ¶mBlock);    if (err == noErr) {        mtuSize = paramBlock.csParam.mtu.mtuSize;        } else {        mtuSize = 1024;  /* guess */        return -1;    }    resolverDoneProc    = NewResultProc(ResolverCompletionRoutine);    tcpCloseDoneProc     = NewTCPIOCompletionProc(TCPCloseCompletionRoutine);    tcpConnectDoneProc    = NewTCPIOCompletionProc(TCPConnectCompletionRoutine);    tcpNotifyProc        = NewTCPNotifyProc(TCPNotificationRoutine);    tcpSendDoneProc        = NewTCPIOCompletionProc(TCPSendCompletionRoutine);    InstallExitHandler();    /* success!! */    thisNetSession = clock() + time(NULL);    if (thisNetSession == 0) thisNetSession = 1;  /* don''t use 0 */    return 0;}void sqNetworkShutdown(void) {    /* shut down the network */    if (thisNetSession == 0) return;  /* noop if network is already shut down */    ResolverTerminate();    DestroyAllOpenSockets();    thisNetSession = 0;}/*** Squeak Generic Socket Functions ***/void sqSocketAbortConnection(SocketPtr s) {    if (!!SocketValid(s)) return;    if (s->socketType == TCPSocketType) {        TCPSockAbortConnection((TCPSockPtr) s->privateSocketPtr);    } else {        success(false);    }}void sqSocketCloseConnection(SocketPtr s) {    if (!!SocketValid(s)) return;    if (s->socketType == TCPSocketType) {        TCPSockCloseConnection((TCPSockPtr) s->privateSocketPtr);    } else {        success(false);    }}int sqSocketConnectionStatus(SocketPtr s) {    if (!!SocketValid(s)) return -1;    if (s->socketType == TCPSocketType) {        return ((TCPSockPtr) s->privateSocketPtr)->connectStatus;    } else {        return ((UDPSockPtr) s->privateSocketPtr)->connectStatus;    }}void sqSocketConnectToPort(SocketPtr s, int addr, int port) {    if (!!SocketValid(s)) return;    if (!!PortNumberValid(port)) return;    if (s->socketType == TCPSocketType) {        TCPSockConnectTo((TCPSockPtr) s->privateSocketPtr, addr, port);    } else {        UDPSockConnectTo((UDPSockPtr) s->privateSocketPtr, addr, port);    }}void sqSocketCreateNetTypeSocketTypeRecvBytesSendBytesSemaID(            SocketPtr s, int netType, int socketType,            int recvBufSize, int sendBufSize, int semaIndex) {    TCPSockPtr tcpSock = nil;    UDPSockPtr udpSock = nil;    /* reference args to suppress compiler warnings about unused variables */    s; netType; recvBufSize; sendBufSize;    s->sessionID = 0;    if (socketType == TCPSocketType) {        tcpSock = TCPSockCreate();        if (tcpSock == nil) {            success(false);        } else {            tcpSock->semaIndex = semaIndex;            tcpSock->next = openTCPSockets;            openTCPSockets = tcpSock;            s->sessionID = thisNetSession;            s->socketType = TCPSocketType;            s->privateSocketPtr = tcpSock;        }    } else {        udpSock = UDPSockCreate();        if (udpSock == nil) {            success(false);        } else {            udpSock->semaIndex = semaIndex;            udpSock->next = openUDPSockets;            openUDPSockets = udpSock;            s->sessionID = thisNetSession;            s->socketType = UDPSocketType;            s->privateSocketPtr = udpSock;        }    }}void sqSocketDestroy(SocketPtr s) {    if (!!SocketValid(s)) return;    if (s->socketType == TCPSocketType) {        TCPSockDestroy((TCPSockPtr) s->privateSocketPtr);    } else {        UDPSockDestroy((UDPSockPtr) s->privateSocketPtr);    }    s->sessionID = 0;    s->socketType = -1;    s->privateSocketPtr = nil;}int sqSocketError(SocketPtr s) {    if (!!SocketValid(s)) return -1;    if (s->socketType == TCPSocketType) {        return ((TCPSockPtr) s->privateSocketPtr)->lastError;    } else {        return ((UDPSockPtr) s->privateSocketPtr)->lastError;    }}void sqSocketListenOnPort(SocketPtr s, int port) {    if (!!SocketValid(s)) return;    if (!!PortNumberValid(port)) return;    if (s->socketType == TCPSocketType) {        TCPSockListenOn((TCPSockPtr) s->privateSocketPtr, port);    } else {        UDPSockListenOn((UDPSockPtr) s->privateSocketPtr, port);    }}int sqSocketLocalAddress(SocketPtr s) {    if (!!SocketValid(s)) return -1;    if (s->socketType == TCPSocketType) {        return TCPSockLocalAddress((TCPSockPtr) s->privateSocketPtr);    } else {        return UDPSockLocalAddress((UDPSockPtr) s->privateSocketPtr);    }}int sqSocketLocalPort(SocketPtr s) {    if (!!SocketValid(s)) return -1;    if (s->socketType == TCPSocketType) {        return TCPSockLocalPort((TCPSockPtr) s->privateSocketPtr);    } else {        return UDPSockLocalPort((UDPSockPtr) s->privateSocketPtr);    }}int sqSocketReceiveDataAvailable(SocketPtr s) {    if (!!SocketValid(s)) return 0;    if (s->socketType == TCPSocketType) {        return TCPSockDataAvailable((TCPSockPtr) s->privateSocketPtr);    } else {        return ((UDPSockPtr) s->privateSocketPtr)->dataAvailable;    }}int sqSocketReceiveDataBufCount(SocketPtr s, int buf, int bufSize) {    int adjustedBufSize = bufSize > 0xFFFF ? 0xFFFF : bufSize;    if (!!SocketValid(s)) return -1;    if (s->socketType == TCPSocketType) {        return TCPSockRecvData((TCPSockPtr) s->privateSocketPtr, (char *) buf, adjustedBufSize);    } else {        return UDPSockRecvData((UDPSockPtr) s->privateSocketPtr, (char *) buf, adjustedBufSize);    }}int sqSocketRemoteAddress(SocketPtr s) {    if (!!SocketValid(s)) return -1;    if (s->socketType == TCPSocketType) {        return TCPSockRemoteAddress((TCPSockPtr) s->privateSocketPtr);    } else {        return UDPSockRemoteAddress((UDPSockPtr) s->privateSocketPtr);    }}int sqSocketRemotePort(SocketPtr s) {    if (!!SocketValid(s)) return -1;    if (s->socketType == TCPSocketType) {        return TCPSockRemotePort((TCPSockPtr) s->privateSocketPtr);    } else {        return UDPSockRemotePort((UDPSockPtr) s->privateSocketPtr);    }}int sqSocketSendDataBufCount(SocketPtr s, int buf, int bufSize) {    int adjustedBufSize = bufSize > 0xFFFF ? 0xFFFF : bufSize;    if (!!SocketValid(s)) return -1;    if (s->socketType == TCPSocketType) {        return TCPSockSendData((TCPSockPtr) s->privateSocketPtr, (char *) buf, adjustedBufSize);    } else {        return UDPSockSendData((UDPSockPtr) s->privateSocketPtr, (char *) buf, adjustedBufSize);    }}int sqSocketSendDone(SocketPtr s) {    if (!!SocketValid(s)) return 1;    if (s->socketType == TCPSocketType) {        return !!((TCPSockPtr) s->privateSocketPtr)->sendInProgress;    } else {        return !!((UDPSockPtr) s->privateSocketPtr)->sendInProgress;    }}/*** Resolver Functions ***/void sqResolverAbort(void) {    int semaIndex;    /* abort the current request */    if (resolver.status == RESOLVER_BUSY) {        semaIndex = resolver.semaIndex;        ResolverTerminate();        ResolverInitialize(semaIndex);    }}void sqResolverAddrLookupResult(char *nameForAddress, int nameSize) {    /* copy the name found by the last address lookup into the given string */    memcpy(nameForAddress, resolver.hostInfo.cname, nameSize);}int sqResolverAddrLookupResultSize(void) {    return strlen(resolver.hostInfo.cname);}int sqResolverError(void) {    return resolver.error;}int sqResolverLocalAddress(void) {    struct GetAddrParamBlock paramBlock;    OSErr err = noErr;    if (resolver.localAddress == 0) {        resolver.remoteAddress = 0;        memset(¶mBlock, 0, sizeof(struct GetAddrParamBlock));        paramBlock.ioResult = 1;        paramBlock.csCode = ipctlGetAddr;        paramBlock.ioCRefNum = macTCPRefNum;        PBControlSync((ParmBlkPtr) ¶mBlock);        if (paramBlock.ioResult == noErr) {            resolver.status = RESOLVER_SUCCESS;            resolver.localAddress = paramBlock.ourAddress;            resolver.error = noErr;        } else {            resolver.status = RESOLVER_ERROR;            resolver.error = paramBlock.ioResult;        }    }    return resolver.localAddress;}int sqResolverNameLookupResult(void) {    /* return the result of the last successful lookup */    return resolver.remoteAddress;}void sqResolverStartAddrLookup(int address) {    OSErr err;    resolver.status = RESOLVER_BUSY;    memset(&resolver.hostInfo, 0, sizeof(hostInfo));    err = AddrToName(address, &resolver.hostInfo, resolverDoneProc, (char *) &resolver);    if (err == noErr) {        /* address was in cache; lookup is already done */        resolver.status = RESOLVER_SUCCESS;    } else {        if (err !!= cacheFault) {            /* unexpected error */            resolver.status = RESOLVER_ERROR;            resolver.error = err;        }    }}void sqResolverStartNameLookup(char *hostName, int nameSize) {    char name[501];    int len;     OSErr err;    len = ((nameSize <= 500) ? nameSize : 500);    memcpy(name, hostName, len);    name[len] = ''\0'';    resolver.status = RESOLVER_BUSY;    memset(&resolver.hostInfo, 0, sizeof(hostInfo));    err = StrToAddr(name, &resolver.hostInfo, resolverDoneProc, (char *) &resolver);    if (err == noErr) {        /* address was in cache; lookup is already done */        resolver.status = RESOLVER_SUCCESS;        resolver.remoteAddress = resolver.hostInfo.addr[0];    } else {        if (err !!= cacheFault) {            /* unexpected error */            resolver.status = RESOLVER_ERROR;            resolver.error = err;        }    }}int sqResolverStatus(void) {    return resolver.status;}/*** Private Resolver Functions ***/int ResolverInitialize(int resolverSemaIndex) {    OSErr err = noErr;    if (resolver.status !!= RESOLVER_UNINITIALIZED) {        ResolverTerminate();    }    memset(&resolver, 0, sizeof(ResolverStatusRec));    resolver.status = RESOLVER_UNINITIALIZED;//xxx move to network init:    macTCPRefNum = 0;    err = OpenDriver("\p.IPP", &macTCPRefNum);    if (err !!= noErr) {        resolver.error = err;        resolver.status = RESOLVER_ERROR;        return err;    }    err = OpenResolver(nil);    if (err !!= noErr) {        resolver.error = err;        resolver.status = RESOLVER_ERROR;        return err;    }    resolver.semaIndex = resolverSemaIndex;    resolver.status = RESOLVER_SUCCESS;    return noErr;}static pascal void ResolverCompletionRoutine(struct hostInfo *hostInfoPtr, char *userDataPtr) {    ResolverStatusPtr r = (ResolverStatusPtr) userDataPtr;    /* completion routine */    if (r->hostInfo.rtnCode == noErr) {        r->status = RESOLVER_SUCCESS;        r->remoteAddress = hostInfoPtr->addr[0];    } else {        r->status = RESOLVER_ERROR;        r->error = hostInfoPtr->rtnCode;    }    signalSemaphoreWithIndex(r->semaIndex);}void ResolverTerminate(void) {    CloseResolver();    memset(&resolver, 0, sizeof(ResolverStatusRec));    resolver.status = RESOLVER_UNINITIALIZED;}/*** Private TCP Socket Functions ***/void * TCPSockCreate(void) {    TCPiopb paramBlock;    TCPSockPtr s = nil;    int minRcvBufSize, rcvBufSize;    OSErr err = noErr;    rcvBufSize = RecvBufferSize;    minRcvBufSize = (4 * mtuSize) + 1024;    if (rcvBufSize < minRcvBufSize) rcvBufSize = minRcvBufSize;        s = (TCPSockPtr) malloc(sizeof(TCPSockRec) + rcvBufSize);    if (s == nil) return nil;  /* allocation failed */    memset(s, 0, sizeof(TCPSockRec) + rcvBufSize);    InitTCPCmd(TCPCreate, nil, ¶mBlock);    paramBlock.csParam.create.rcvBuff = s->rcvBuf;    paramBlock.csParam.create.rcvBuffLen = rcvBufSize;    paramBlock.csParam.create.notifyProc = tcpNotifyProc;    paramBlock.csParam.create.userDataPtr = (Ptr) s;    err = PBControlSync((ParmBlkPtr) ¶mBlock);    if (err !!= noErr) {        free(s);        return nil;    }    s->tcpStream = paramBlock.tcpStream;    return s;}int TCPSockDataAvailable(TCPSockPtr s) {    TCPiopb paramBlock;    OSErr err = noErr;    if ((s == nil) || (s->tcpStream == nil)) {        return false;  /* already destroyed */    }    InitTCPCmd(TCPStatus, s->tcpStream, ¶mBlock);    err = PBControlSync((ParmBlkPtr) ¶mBlock);    if (err !!= noErr) {        return 0;    }    return paramBlock.csParam.status.amtUnreadData > 0;}void TCPSockDestroy(TCPSockPtr s) {    TCPiopb paramBlock;    OSErr err = noErr;    if ((s == nil) || (s->tcpStream == nil)) {        return;  /* already destroyed */    }    InitTCPCmd(TCPRelease, s->tcpStream, ¶mBlock);    err = PBControlSync((ParmBlkPtr) ¶mBlock);    TCPSockRemoveFromOpenList(s);    s->tcpStream = nil;    free(s);}int TCPSockLocalAddress(TCPSockPtr s) {    TCPiopb paramBlock;    OSErr err = noErr;    if ((s == nil) || (s->tcpStream == nil)) {        return 0;  /* already destroyed */    }    InitTCPCmd(TCPStatus, s->tcpStream, ¶mBlock);    err = PBControlSync((ParmBlkPtr) ¶mBlock);    if (err !!= noErr) {        return 0;    }    return paramBlock.csParam.status.localHost;}int TCPSockLocalPort(TCPSockPtr s) {    TCPiopb paramBlock;    OSErr err = noErr;    if ((s == nil) || (s->tcpStream == nil)) {        return 0;  /* already destroyed */    }    InitTCPCmd(TCPStatus, s->tcpStream, ¶mBlock);    err = PBControlSync((ParmBlkPtr) ¶mBlock);    if (err !!= noErr) {        return 0;    }    return paramBlock.csParam.status.localPort;}int TCPSockRemoteAddress(TCPSockPtr s) {    TCPiopb paramBlock;    OSErr err = noErr;    if ((s == nil) || (s->tcpStream == nil)) {        return 0;  /* already destroyed */    }    InitTCPCmd(TCPStatus, s->tcpStream, ¶mBlock);    err = PBControlSync((ParmBlkPtr) ¶mBlock);    if (err !!= noErr) {        return 0;    }    return paramBlock.csParam.status.remoteHost;}int TCPSockRemotePort(TCPSockPtr s) {    TCPiopb paramBlock;    OSErr err = noErr;    if ((s == nil) || (s->tcpStream == nil)) {        return 0;  /* already destroyed */    }    InitTCPCmd(TCPStatus, s->tcpStream, ¶mBlock);    err = PBControlSync((ParmBlkPtr) ¶mBlock);    if (err !!= noErr) {        return 0;    }    return paramBlock.csParam.status.remotePort;}void TCPSockRemoveFromOpenList(TCPSockPtr s) {    TCPSockPtr thisSock, nextSock, previousSock;    previousSock = nil;    for (thisSock = openTCPSockets; thisSock !!= nil; thisSock = nextSock) {        nextSock = thisSock->next;        if (thisSock == s) {            if (previousSock == nil) {                openTCPSockets = nextSock;            } else {                previousSock->next = nextSock;            }            break;        }        previousSock = thisSock;    }}void TCPSockConnectTo(TCPSockPtr s, int addr, int port) {    OSErr err = noErr;    if ((s == nil) || (s->tcpStream == nil)) return;  /* socket destroyed */    InitTCPCmd(TCPActiveOpen, s->tcpStream, &s->tcpPB);    s->tcpPB.csParam.open.remoteHost = addr;    s->tcpPB.csParam.open.remotePort = port;    s->connectStatus = WaitingForConnection;    s->tcpPB.ioCompletion = tcpConnectDoneProc;    err = PBControlAsync((ParmBlkPtr) &s->tcpPB);    if (err !!= noErr) {        s->connectStatus = Unconnected;        s->lastError = err;    }}void TCPSockListenOn(TCPSockPtr s, int port) {    OSErr err = noErr;    if ((s == nil) || (s->tcpStream == nil)) return;  /* socket destroyed */    InitTCPCmd(TCPPassiveOpen, s->tcpStream, &s->tcpPB);    s->tcpPB.csParam.open.localPort = port;    s->connectStatus = WaitingForConnection;    s->tcpPB.ioCompletion = tcpConnectDoneProc;    err = PBControlAsync((ParmBlkPtr) &s->tcpPB);    if (err !!= noErr) {        s->connectStatus = Unconnected;        s->lastError = err;    }}void TCPSockCloseConnection(TCPSockPtr s) {    /* Note: This operation uses a dedicated parameter block so that it       can be invoked even in the previous send is not yet complete.       It will eventually use a completion routine to delete the       socket automatically. For now, this is the client''s responsibility.    */    if ((s == nil) || (s->tcpStream == nil)) return;  /* socket destroyed */    InitTCPCmd(TCPClose, s->tcpStream, &s->closePB);//    s->closePB.ioCompletion = tcpCloseDoneProc;    s->connectStatus = ThisEndClosed; // xxx remove when making this async    s->lastError = PBControlSync((ParmBlkPtr) &s->closePB);}void TCPSockAbortConnection(TCPSockPtr s) {    TCPiopb paramBlock;    if ((s == nil) || (s->tcpStream == nil)) return;  /* socket destroyed */    InitTCPCmd(TCPAbort, s->tcpStream, ¶mBlock);    s->lastError = PBControlSync((ParmBlkPtr) ¶mBlock);    s->connectStatus = Unconnected;}int TCPSockRecvData(TCPSockPtr s, char *buf, int bufSize) {    TCPiopb paramBlock;  /* use local parameter block since send may be using one in socket */    OSErr err = noErr;    int bytesRead;    if (!!TCPSockDataAvailable(s)) return 0;  /* no data available */    InitTCPCmd(TCPRcv, s->tcpStream, ¶mBlock);    paramBlock.csParam.receive.commandTimeoutValue = 1; /* finish in one second, data or not */    paramBlock.csParam.receive.rcvBuff = buf;    paramBlock.csParam.receive.rcvBuffLen = bufSize;    err = PBControlSync((ParmBlkPtr) ¶mBlock);  /* synchronous */    if (err == noErr) {        bytesRead = paramBlock.csParam.receive.rcvBuffLen;    } else {        /* if err == commandTimeout, no data was available */        bytesRead = 0;        if (!!((err == commandTimeout) || (err == connectionClosing))) {            s->lastError = err;        }    }    s->dataAvailable = (bytesRead !!= 0);  /* if we got data, there may be more */    return bytesRead;}int xxxGOODTCPSockSendData(TCPSockPtr s, char *buf, int bufSize);int xxxGOODTCPSockSendData(TCPSockPtr s, char *buf, int bufSize) {    int sendCount;    OSErr err = noErr;    struct wdsEntry wds[2];    buf;  /* xxx avoid compiler complaint about unreferenced vars */    /* copy client data into sendBuf to allow asynchronous send */    sendCount = (bufSize <= SendBufferSize) ? bufSize : SendBufferSize;//xxx    memcpy(s->sendBuf, buf, sendCount);    /* set up WDS entry; zero length marks end of chunk list */    wds[0].length = sendCount;//xxx        wds[0].ptr = s->sendBuf;    wds[1].length = 0;    InitTCPCmd(TCPSend, s->tcpStream, &s->tcpPB);    s->tcpPB.csParam.send.wdsPtr = (Ptr) &wds;    s->tcpPB.csParam.send.pushFlag = true;    s->sendInProgress = true;    s->tcpPB.ioCompletion = tcpSendDoneProc;    err = PBControlAsync((ParmBlkPtr) &s->tcpPB);    if (err !!= noErr) {        s->sendInProgress = false;        s->lastError = err;        return 0;    }    return sendCount;}int TCPSockSendData(TCPSockPtr s, char *buf, int bufSize) {    TCPSendBufPtr sendBuf;    OSErr err = noErr;    int sendCount;    sendBuf = &sendBufPool[nextSendBuf++];    if (nextSendBuf >= SendBufCount) nextSendBuf = 0;    sendBuf->mySocket = s;        /* copy client data into sendBuf to allow asynchronous send */    sendCount = (bufSize <= SendBufferSize) ? bufSize : SendBufferSize;    memcpy(sendBuf->data, buf, sendCount);    /* set up WDS entry; zero length marks end of chunk list */    sendBuf->wds[0].length = sendCount;    sendBuf->wds[0].ptr = sendBuf->data;    sendBuf->wds[1].length = 0;    InitTCPCmd(TCPSend, s->tcpStream, &sendBuf->tcpPB);    sendBuf->tcpPB.csParam.send.wdsPtr = (Ptr) &sendBuf->wds;    sendBuf->tcpPB.csParam.send.pushFlag = true;    sendBuf->tcpPB.ioCompletion = tcpSendDoneProc;    s->sendInProgress = true;    err = PBControlAsync((ParmBlkPtr) &sendBuf->tcpPB);    if (err !!= noErr) {        s->sendInProgress = false;        s->lastError = err;        return 0;    }    return sendCount;}/*** Private General Utilities ***/void DestroyAllOpenSockets(void) {    while (openTCPSockets !!= nil) {        TCPSockDestroy(openTCPSockets);  /* removes socket from the list */    }    while (openUDPSockets !!= nil) {        UDPSockDestroy(openUDPSockets);  /* removes socket from the list */    }}void InstallExitHandler(void) {    /* Install a handler to release all open sockets when terminating this       application. The handler will be called even if you type ''es'' to       MacsBug or use Command-Option-Escape for force the program to exit.       The handler is only installed the first time the network is initialized.    */    if (oldExitHandlerProc == nil) {        oldExitHandlerProc = GetToolTrapAddress(_ExitToShell);        myExitHandlerProc =             NewRoutineDescriptor((ProcPtr) MyExitHandler, kPascalStackBased, GetCurrentISA());        SetToolTrapAddress(myExitHandlerProc, _ExitToShell);    }}void MyExitHandler(void) {    SetCurrentA5();    SetToolTrapAddress(oldExitHandlerProc, _ExitToShell);    DestroyAllOpenSockets();    ExitToShell();}int PortNumberValid(int port) {    if (port < 0xFFFF) {        return true;    }    success(false);    return false;}int SocketValid(SocketPtr s) {    if ((s !!= NULL) &&        (s->privateSocketPtr !!= NULL) &&        (s->sessionID == thisNetSession)) {            if (s->socketType == TCPSocketType) {                if (((TCPSockPtr) s->privateSocketPtr)->tcpStream !!= nil) {                    return true;                }            }    }    success(false);    return false;}/*** Private TCP Utilities ***/void InitTCPCmd(int cmd, StreamPtr tcpStream, TCPiopb *paramBlkPtr) {    memset(paramBlkPtr, 0, sizeof(TCPiopb));    paramBlkPtr->csCode = cmd;    paramBlkPtr->tcpStream = tcpStream;    paramBlkPtr->ioCRefNum = macTCPRefNum;    paramBlkPtr->ioResult = 1;}void TCPCloseCompletionRoutine(struct TCPiopb *pbPtr) {    TCPSockPtr s = (TCPSockPtr) pbPtr;    s->lastError = s->tcpPB.ioResult;    if (s->lastError == noErr) {        if (s->connectStatus == OtherEndClosed) {            s->connectStatus = Unconnected;        } else {            s->connectStatus = ThisEndClosed;        }    }    signalSemaphoreWithIndex(s->semaIndex);}void TCPConnectCompletionRoutine(struct TCPiopb *pbPtr) {    TCPSockPtr s = (TCPSockPtr) pbPtr;    s->lastError = s->tcpPB.ioResult;    if (s->lastError == noErr) {        s->connectStatus = Connected;    } else {        s->connectStatus = Unconnected;    }    signalSemaphoreWithIndex(s->semaIndex);}pascal void TCPNotificationRoutine(    StreamPtr s, unsigned short eventCode, Ptr userDataPtr,    unsigned short terminReason, struct ICMPReport *icmpMsg) {    /* called when data arrives or stream status changes */    /* reference args to suppress compiler warnings about unused variables */    s; terminReason; icmpMsg;        if (eventCode == TCPDataArrival) {        TCPSockPtr tcpSock = (TCPSockPtr) userDataPtr;        tcpSock->dataAvailable = true;        signalSemaphoreWithIndex(tcpSock->semaIndex);        return;    }    if (eventCode == TCPClosing) {        TCPSockPtr tcpSock = (TCPSockPtr) userDataPtr;        if (tcpSock->connectStatus == ThisEndClosed) {            tcpSock->connectStatus = Unconnected;        } else {            tcpSock->connectStatus = OtherEndClosed;        }        signalSemaphoreWithIndex(tcpSock->semaIndex);        return;    }    if (eventCode == TCPTerminate) {        TCPSockPtr tcpSock = (TCPSockPtr) userDataPtr;        tcpSock->connectStatus = Unconnected;        signalSemaphoreWithIndex(tcpSock->semaIndex);        return;    }}void TCPSendCompletionRoutine(struct TCPiopb *pbPtr) {//xxx    TCPSockPtr s = (TCPSockPtr) pbPtr;TCPSockPtr s = ((TCPSendBufPtr) pbPtr)->mySocket;        s->lastError = s->tcpPB.ioResult;    s->sendInProgress = false;    signalSemaphoreWithIndex(s->semaIndex);}/*** Private UDP Socket Functions ***/void *        UDPSockCreate(void) {    // xxx    return nil;}void        UDPSockDestroy(UDPSockPtr s) {    // xxx    s;}int            UDPSockLocalAddress(UDPSockPtr s) {    // xxx    s;}int            UDPSockLocalPort(UDPSockPtr s) {    // xxx    s;}int            UDPSockRemoteAddress(UDPSockPtr s) {    // xxx    s;}int            UDPSockRemotePort(UDPSockPtr s) {    // xxx    s;}void        UDPSockConnectTo(UDPSockPtr s, int addr, int port) {    // xxx    s; addr; port;}void        UDPSockListenOn(UDPSockPtr s, int port) {    // xxx    s; port;}int            UDPSockRecvData(UDPSockPtr s, char *buf, int bufSize) {    // xxx    s; buf; bufSize;}int            UDPSockSendData(UDPSockPtr s, char *buf, int bufSize) {    // xxx    s; buf; bufSize;}'! !!InterpreterSupportCode class methodsFor: 'source files' stamp: 'jm 9/21/97 18:08'!macSoundFile    ^ '#include "sq.h"#include <Sound.h>#include <SoundInput.h>/******  Mac Sound Output Notes:    On Macs that support it (all PPC Macs, I believe), 16-bit sound should    be used. I measured a slight increase in overhead for background sound    generation (5% to 7.5% for 16-bit sound version 2.5% to 5% for 8-bit).    The cost of copying the larger buffer in snd_PlaySamplesFromAtLength    was too small to easily measure in both 8-bit and 16-bits. On the other    hand, 16-bits yields far, far superiour sound quality.    My understanding is that SoundManager 3.0 or later supports the 16-bit    sound interface an all Macs, even if the hardware only supports 8-bits.    If this is not true, however, change BYTES_PER_SAMPLE to 1. Then, either    the Squeak code will need to be changed to use 8-bit sound buffers,    or (preferrably) snd_PlaySamplesFromAtLength will need to do the conversion    from 16 to 8 bits. I plan to cross that bridge if and when we need to.    The code as currently written was to support Squeak code that generated    8-bit sound buffers.    Here are the various possible sound buffer formats:        1. mono,    8-bits -- packed array of bytes (not currently used)        2. stereo,  8-bits -- as above, with L and R channels in alternate bytes (not currently used)        3. mono,   16-bits -- array of 32-bit words, samples in low-order 16 bits (high bits ignored)        4. stereo, 16-bits -- array of 32-bit words; with L and R channels in high and low half-words    Note:  8-bit samples are encoded with 0x80 as the center (zero) value    Note: 16-bit samples are encoded as standard, signed integers (i.e., 2''s-complement)    -- John Maloney, July 28, 1996  Mac Sound Input Notes:    Squeak sound input is currently defined to provide a single (mono) stream    of signed 16-bit samples for all platforms. Platforms that only support    8-bit sound input should convert samples to signed 16 bit values, leaving    the low order bits zero. Since the available sampling rates differ from    platform to platform, the client may not get the requested sampling rate;    however, the call snd_GetRecordingSampleRate returns the sampling rate.    On many platforms, simultaneous record and playback is permitted only if    the input and output sampling rates are the same.    -- John Maloney, Aug 22, 1997******/#define BYTES_PER_SAMPLE 2/*** double-buffer state record ***/typedef struct {    int open;    int stereo;    int frameCount;    int sampleRate;    int lastFlipTime;    int playSemaIndex;    int bufSizeInBytes;    int bufState0;    int bufState1;    int done;} PlayStateRec;/*** possible buffer states ***/#define BUF_EMPTY    0#define BUF_FULL    1#define BUF_PLAYING    2/*** record buffer state record ***//* Note: RECORD_BUFFER_SIZE should be a multiple of 4096 bytes to avoid clicking.   (The clicking was observed on a Mac 8100; the behavior of other Macs could differ.)*/#define RECORD_BUFFER_SIZE (4096 * 1)typedef struct {    SPB paramBlock;    int stereo;    int bytesPerSample;    int recordSemaIndex;    int readIndex;  /* index of the next sample to read */    char samples[RECORD_BUFFER_SIZE];} RecordBufferRec, *RecordBuffer;/*** sound output variables ***/SndChannelPtr chan;PlayStateRec bufState = {false, false, 0, 0, NULL, NULL, true, 0};SndDoubleBufferHeader dblBufHeader;/*** sound input variables ***/RecordBufferRec recordBuffer1, recordBuffer2;int recordingInProgress;long soundInputRefNum;/*** local functions ***/pascal void DoubleBack(SndChannelPtr chan, SndDoubleBufferPtr buf);int FillBufferWithSilence(SndDoubleBufferPtr buf);pascal void FlipRecordBuffers(SPBPtr pb);int MixInSamples(int count, char *srcBufPtr, int srcStartIndex, char *dstBufPtr, int dstStartIndex);pascal void DoubleBack(SndChannelPtr chan, SndDoubleBufferPtr buf) {    PlayStateRec *state;    chan;  /* reference argument to avoid compiler warnings */    /* insert a click to help user detect failure to fill buffer in time */    *(unsigned int *) &buf->dbSoundData[0] = 0;    *(unsigned int *) &buf->dbSoundData[4] = 0xFFFFFFFF;    state = (PlayStateRec *) buf->dbUserInfo[0];    if (buf->dbUserInfo[1] == 0) {        state->bufState0 = BUF_EMPTY;        state->bufState1 = BUF_PLAYING;    } else {        state->bufState0 = BUF_PLAYING;        state->bufState1 = BUF_EMPTY;    }    buf->dbNumFrames = state->frameCount;    buf->dbFlags = buf->dbFlags | dbBufferReady;    if (state->done) {        FillBufferWithSilence(buf);        buf->dbFlags = buf->dbFlags | dbLastBuffer;    } else {        signalSemaphoreWithIndex(state->playSemaIndex);    }    state->lastFlipTime = ioMicroMSecs();}int FillBufferWithSilence(SndDoubleBufferPtr buf) {    unsigned int *sample, *lastSample;    sample        = (unsigned int *) &buf->dbSoundData[0];    lastSample    = (unsigned int *) &buf->dbSoundData[bufState.bufSizeInBytes];    /* word-fill buffer with silence */    if (BYTES_PER_SAMPLE == 1) {        while (sample < lastSample) {            *sample++ = 0x80808080;  /* Note: 0x80 is zero value for 8-bit samples */        }    } else {        while (sample < lastSample) {            *sample++ = 0;        }    }}pascal void FlipRecordBuffers(SPBPtr pb) {    /* called at interrupt time to exchange the active and inactive record buffers */    RecordBuffer thisBuffer = (RecordBuffer) pb;    RecordBuffer nextBuffer = (RecordBuffer) pb->userLong;    if (pb->error == 0) {        /* restart recording using the other buffer */        SPBRecord(&nextBuffer->paramBlock, true);        /* reset the read pointer for the buffer that has just been filled */        thisBuffer->readIndex = 0;        signalSemaphoreWithIndex(nextBuffer->recordSemaIndex);    }}/*** exported sound output functions ***/int snd_AvailableSpace(void) {    if (!!bufState.open) return -1;    if ((bufState.bufState0 == BUF_EMPTY) ||        (bufState.bufState1 == BUF_EMPTY)) {            return bufState.bufSizeInBytes;    }    return 0;}int snd_PlaySamplesFromAtLength(int frameCount, int arrayIndex, int startIndex) {    SndDoubleBufferPtr buf;    int framesWritten;    if (!!bufState.open) return -1;    if (bufState.bufState0 == BUF_EMPTY) {        buf = dblBufHeader.dbhBufferPtr[0];        bufState.bufState0 = BUF_FULL;    } else {        if (bufState.bufState1 == BUF_EMPTY) {            buf = dblBufHeader.dbhBufferPtr[1];            bufState.bufState1 = BUF_FULL;        } else {            return 0;  /* neither buffer is available */        }    }    if (bufState.frameCount < frameCount) {        framesWritten = bufState.frameCount;    } else {        framesWritten = frameCount;    }    if (BYTES_PER_SAMPLE == 1) {  /* 8-bit samples */        unsigned char *src, *dst, *end;        src = (unsigned char *) (arrayIndex + startIndex);        end = (unsigned char *) src + (framesWritten * (bufState.stereo ? 2 : 1));        dst = (unsigned char *) &buf->dbSoundData[0];        while (src < end) {            *dst++ = *src++;        }    } else {  /* 16-bit samples */        short int *src, *dst, *end;        src = (short int *) (arrayIndex + (startIndex * 4));        end = (short int *) (arrayIndex + ((startIndex + framesWritten) * 4));        dst = (short int *) &buf->dbSoundData[0];        if (bufState.stereo) {  /* stereo */            while (src < end) {                *dst++ = *src++;            }        } else {  /* mono */            /* if mono, skip every other frame of the source */            while (src < end) {                src++;  /* skip high word */                *dst++ = *src++;            }        }    }    return framesWritten;}int MixInSamples(int count, char *srcBufPtr, int srcStartIndex, char *dstBufPtr, int dstStartIndex) {    int sample;    if (BYTES_PER_SAMPLE == 1) {  /* 8-bit samples */        unsigned char *src, *dst, *end;        src = (unsigned char *) srcBufPtr + srcStartIndex;        end = (unsigned char *) srcBufPtr + (count * (bufState.stereo ? 2 : 1));        dst = (unsigned char *) dstBufPtr + dstStartIndex;        while (src < end) {            sample = *dst + (*src++ - 128);            if (sample > 255) sample = 255;            if (sample < 0) sample = 0;            *dst++ = sample;        }    } else {  /* 16-bit samples */        short int *src, *dst, *end;        src = (short int *) (srcBufPtr + (srcStartIndex * 4));        end = (short int *) (srcBufPtr + ((srcStartIndex + count) * 4));        if (bufState.stereo) {  /* stereo */            dst = (short int *) (dstBufPtr + (dstStartIndex * 4));            while (src < end) {                sample = *dst + *src++;                if (sample > 32767) sample = 32767;                if (sample < -32767) sample = -32767;                *dst++ = sample;            }        } else {  /* mono */            /* if mono, skip every other frame of the source */            dst = (short int *) (dstBufPtr + (dstStartIndex * 2));            while (src < end) {                src++;  /* skip high word */                sample = *dst + *src++;                if (sample > 32767) sample = 32767;                if (sample < -32767) sample = -32767;                *dst++ = sample;            }        }    }}int snd_InsertSamplesFromLeadTime(int frameCount, int srcBufPtr, int samplesOfLeadTime) {    SndDoubleBufferPtr bufPlaying, otherBuf;    int samplesInserted, startSample, count;    if (!!bufState.open) return -1;    if (bufState.bufState0 == BUF_PLAYING) {        bufPlaying = dblBufHeader.dbhBufferPtr[0];        otherBuf = dblBufHeader.dbhBufferPtr[1];    } else {        bufPlaying = dblBufHeader.dbhBufferPtr[1];        otherBuf = dblBufHeader.dbhBufferPtr[0];    }    samplesInserted = 0;    /* mix as many samples as can fit into the remainder of the currently playing buffer */    startSample =        ((bufState.sampleRate * (ioMicroMSecs() - bufState.lastFlipTime)) / 1000) + samplesOfLeadTime;    if (startSample < bufState.frameCount) {        count = bufState.frameCount - startSample;        if (count > frameCount) count = frameCount;        MixInSamples(count, (char *) srcBufPtr, 0, &bufPlaying->dbSoundData[0], startSample);        samplesInserted = count;    }    /* mix remaining samples into the inactive buffer */    count = bufState.frameCount;    if (count > (frameCount - samplesInserted)) {        count = frameCount - samplesInserted;    }    MixInSamples(count, (char *) srcBufPtr, samplesInserted, &otherBuf->dbSoundData[0], 0);    return samplesInserted + count;}int snd_PlaySilence(void) {    if (!!bufState.open) return -1;    if (bufState.bufState0 == BUF_EMPTY) {        FillBufferWithSilence(dblBufHeader.dbhBufferPtr[0]);        bufState.bufState0 = BUF_FULL;    } else {        if (bufState.bufState1 == BUF_EMPTY) {            FillBufferWithSilence(dblBufHeader.dbhBufferPtr[1]);            bufState.bufState1 = BUF_FULL;        } else {            return 0;  /* neither buffer is available */        }    }    return bufState.bufSizeInBytes;}int snd_Start(int frameCount, int samplesPerSec, int stereo, int semaIndex) {    OSErr                err;    SndDoubleBufferPtr    buffer;    int                    bytesPerFrame, bufferBytes, i;    bytesPerFrame            = stereo ? 2 * BYTES_PER_SAMPLE : BYTES_PER_SAMPLE;    bufferBytes                = ((frameCount * bytesPerFrame) / 8) * 8;        /* Note: Must round bufferBytes down to an 8-byte boundary to avoid clicking!!!!!! */    if (bufState.open) {        /* still open from last time; clean up before continuing */        snd_Stop();    }    bufState.open            = false;  /* set to true if successful */    bufState.stereo            = stereo;    bufState.frameCount        = bufferBytes / bytesPerFrame;    bufState.sampleRate        = samplesPerSec;    bufState.lastFlipTime    = ioMicroMSecs();    bufState.playSemaIndex    = semaIndex;    bufState.bufSizeInBytes    = bufferBytes;    bufState.bufState0        = BUF_EMPTY;    bufState.bufState1        = BUF_EMPTY;    bufState.done            = false;    dblBufHeader.dbhNumChannels        = stereo ? 2 : 1;    dblBufHeader.dbhSampleSize        = BYTES_PER_SAMPLE * 8;    dblBufHeader.dbhCompressionID    = 0;    dblBufHeader.dbhPacketSize        = 0;    dblBufHeader.dbhSampleRate        = samplesPerSec << 16; /* convert to fixed point */    dblBufHeader.dbhDoubleBack        = NewSndDoubleBackProc(DoubleBack);    chan = NULL;    err = SndNewChannel(&chan, sampledSynth, 0, NULL);    if (err !!= noErr) return false; /* could not open sound channel */    for (i = 0; i < 2; i++) {        buffer = (SndDoubleBufferPtr) NewPtrClear(sizeof(SndDoubleBuffer) + bufState.bufSizeInBytes);        if (buffer == NULL) return false; /* could not allocate memory for a buffer */        buffer->dbNumFrames        = bufState.frameCount;        buffer->dbFlags            = dbBufferReady;        buffer->dbUserInfo[0]    = (long) &bufState;        buffer->dbUserInfo[1]    = i;        FillBufferWithSilence(buffer);        dblBufHeader.dbhBufferPtr[i] = buffer;    }    err = SndPlayDoubleBuffer(chan, &dblBufHeader);    if (err !!= noErr) return false; /* could not play double buffer */    bufState.open = true;    return true;}int snd_Stop(void) {    OSErr                err;    SndDoubleBufferPtr    buffer;    SCStatus            status;    long                i, junk;    if (!!bufState.open) return;    bufState.open = false;    bufState.done = true;    while (true) {        err = SndChannelStatus(chan, sizeof(status), &status);        if (err !!= noErr) break; /* could not get channel status */        if (!!status.scChannelBusy) break;        Delay(1, &junk);    }    SndDisposeChannel(chan, true);    DisposeRoutineDescriptor(dblBufHeader.dbhDoubleBack);    for (i = 0; i < 2; i++) {        buffer = dblBufHeader.dbhBufferPtr[i];        if (buffer !!= NULL) {            DisposePtr((char *) buffer);        }        dblBufHeader.dbhBufferPtr[i] = NULL;    }    bufState.open = false;}/*** exported sound input functions ***/int snd_SetRecordLevel(int level) {    /* set the recording level to a value between 0 (minimum gain) and 1000. */    Fixed inputGainArg;    int err;    if (!!recordingInProgress || (level < 0) || (level > 1000)) {        success(false);        return;  /* noop if not recording */    }    inputGainArg = ((500 + level) << 16) / 1000;  /* gain is Fixed between 0.5 and 1.5 */    err = SPBSetDeviceInfo(soundInputRefNum, siInputGain, &inputGainArg);    /* don''t fail on error; hardware may not support setting the gain */}int snd_StartRecording(int desiredSamplesPerSec, int stereo, int semaIndex) {    /* turn on sound recording, trying to use a sampling rate close to       the one specified. semaIndex is the index in the exportedObject       array of a semaphore to be signalled when input data is available. */    Str255 deviceName = "";    short automaticGainControlArg;    Fixed inputGainArg;    long  compressionTypeArg;    short continuousArg;    short sampleSizeArg;    short channelCountArg;    UnsignedFixed sampleRateArg;    int err;    err = SPBOpenDevice(deviceName, siWritePermission, &soundInputRefNum);    if (err !!= noErr) {        success(false);        return;    }    /* try to initialize some optional parameters, but don''t fail if we can''t */    automaticGainControlArg = false;    SPBSetDeviceInfo(soundInputRefNum, siAGCOnOff, &automaticGainControlArg);    inputGainArg = 1 << 16;  /* 1.0 in Fixed */    SPBSetDeviceInfo(soundInputRefNum, siInputGain, &inputGainArg);    compressionTypeArg = ''NONE'';    SPBSetDeviceInfo(soundInputRefNum, siCompressionType, &compressionTypeArg);    continuousArg = true;    err = SPBSetDeviceInfo(soundInputRefNum, siContinuous, &continuousArg);    if (err !!= noErr) {        success(false);        SPBCloseDevice(soundInputRefNum);        return;    }    sampleSizeArg = 16;    err = SPBSetDeviceInfo(soundInputRefNum, siSampleSize, &sampleSizeArg);    if (err !!= noErr) {        /* use 8-bit samples */        sampleSizeArg = 8;        err = SPBSetDeviceInfo(soundInputRefNum, siSampleSize, &sampleSizeArg);        if (err !!= noErr) {            success(false);            SPBCloseDevice(soundInputRefNum);            return;        }    }    channelCountArg = stereo ? 2 : 1;    err = SPBSetDeviceInfo(soundInputRefNum, siNumberChannels, &channelCountArg);    if (err !!= noErr) {        success(false);        SPBCloseDevice(soundInputRefNum);        return;    }    /* try to set the client''s desired sample rate */    sampleRateArg = desiredSamplesPerSec << 16;    err = SPBSetDeviceInfo(soundInputRefNum, siSampleRate, &sampleRateArg);    if (err !!= noErr) {        /* if client''s rate fails, try the nearest common sampling rates in {11025, 22050, 44100} */        if (desiredSamplesPerSec <= 16538) {            sampleRateArg = 11025 << 16;        } else {            if (desiredSamplesPerSec <= 33075) {                sampleRateArg = 22050 << 16;            } else {                sampleRateArg = 44100 << 16;            }        }        /* even if following fails, recording can go on at the default sample rate */        SPBSetDeviceInfo(soundInputRefNum, siSampleRate, &sampleRateArg);    }    recordBuffer1.paramBlock.inRefNum = soundInputRefNum;    recordBuffer1.paramBlock.count = RECORD_BUFFER_SIZE;    recordBuffer1.paramBlock.milliseconds = 0;    recordBuffer1.paramBlock.bufferLength = RECORD_BUFFER_SIZE;    recordBuffer1.paramBlock.bufferPtr = recordBuffer1.samples;    recordBuffer1.paramBlock.completionRoutine = NewSICompletionProc(FlipRecordBuffers);    recordBuffer1.paramBlock.interruptRoutine = nil;    recordBuffer1.paramBlock.userLong = (long) &recordBuffer2;  /* pointer to other buffer */    recordBuffer1.paramBlock.error = noErr;    recordBuffer1.paramBlock.unused1 = 0;    recordBuffer1.stereo = stereo;    recordBuffer1.bytesPerSample = sampleSizeArg == 8 ? 1 : 2;    recordBuffer1.recordSemaIndex = semaIndex;    recordBuffer1.readIndex = RECORD_BUFFER_SIZE;    recordBuffer2.paramBlock.inRefNum = soundInputRefNum;    recordBuffer2.paramBlock.count = RECORD_BUFFER_SIZE;    recordBuffer2.paramBlock.milliseconds = 0;    recordBuffer2.paramBlock.bufferLength = RECORD_BUFFER_SIZE;    recordBuffer2.paramBlock.bufferPtr = recordBuffer2.samples;    recordBuffer2.paramBlock.completionRoutine = NewSICompletionProc(FlipRecordBuffers);    recordBuffer2.paramBlock.interruptRoutine = nil;    recordBuffer2.paramBlock.userLong = (long) &recordBuffer1;  /* pointer to other buffer */    recordBuffer2.paramBlock.error = noErr;    recordBuffer2.paramBlock.unused1 = 0;    recordBuffer2.stereo = stereo;    recordBuffer2.bytesPerSample = sampleSizeArg == 8 ? 1 : 2;    recordBuffer2.recordSemaIndex = semaIndex;    recordBuffer2.readIndex = RECORD_BUFFER_SIZE;    err = SPBRecord(&recordBuffer1.paramBlock, true);    if (err !!= noErr) {        success(false);        SPBCloseDevice(soundInputRefNum);        return;    }    recordingInProgress = true;}int snd_StopRecording(void) {    /* turn off sound recording */    int err;    if (!!recordingInProgress) return;  /* noop if not recording */    err = SPBStopRecording(soundInputRefNum);    if (err !!= noErr) success(false);    SPBCloseDevice(soundInputRefNum);    DisposeRoutineDescriptor(recordBuffer1.paramBlock.completionRoutine);    recordBuffer1.paramBlock.completionRoutine = nil;    DisposeRoutineDescriptor(recordBuffer2.paramBlock.completionRoutine);    recordBuffer2.paramBlock.completionRoutine = nil;    recordBuffer1.recordSemaIndex = 0;    recordBuffer2.recordSemaIndex = 0;    recordingInProgress = false;}double snd_GetRecordingSampleRate(void) {    /* return the actual recording rate; fail if not currently recording */    UnsignedFixed sampleRateArg;    int err;    if (!!recordingInProgress) {        success(false);        return 0.0;    }    err = SPBGetDeviceInfo(soundInputRefNum, siSampleRate, &sampleRateArg);    if (err !!= noErr) {        success(false);        return 0.0;    }    return  (double) ((sampleRateArg >> 16) & 0xFFFF) +            ((double) (sampleRateArg & 0xFFFF) / 65536.0);}int snd_RecordSamplesIntoAtLength(int buf, int startSliceIndex, int bufferSizeInBytes) {    /* if data is available, copy as many sample slices as possible into the       given buffer starting at the given slice index. do not write past the       end of the buffer, which is buf + bufferSizeInBytes. return the number       of slices (not bytes) copied. a slice is one 16-bit sample in mono       or two 16-bit samples in stereo. */    int bytesPerSlice = (recordBuffer1.stereo ? 4 : 2);    char *nextBuf = (char *) buf + (startSliceIndex * bytesPerSlice);    char *bufEnd = (char *) buf + bufferSizeInBytes;    char *src, *srcEnd;    RecordBuffer recBuf = nil;    int bytesCopied;    if (!!recordingInProgress) {        success(false);        return 0;    }    /* select the buffer with unread samples, if any */    recBuf = nil;    if (recordBuffer1.readIndex < RECORD_BUFFER_SIZE) recBuf = &recordBuffer1;    if (recordBuffer2.readIndex < RECORD_BUFFER_SIZE) recBuf = &recordBuffer2;    if (recBuf == nil) return 0;  /* no samples available */    /* copy samples into the client''s buffer */    src = &recBuf->samples[0] + recBuf->readIndex;    srcEnd = &recBuf->samples[RECORD_BUFFER_SIZE];    if (recBuf->bytesPerSample == 1) {        while ((src < srcEnd) && (nextBuf < bufEnd)) {            /* convert 8-bit sample to 16-bit sample */            *nextBuf++ = (*src++) - 128;  /* convert from [0-255] to [-128-127] */            *nextBuf++ = 0;  /* low-order byte is zero */        }    } else {        while ((src < srcEnd) && (nextBuf < bufEnd)) {            *nextBuf++ = *src++;        }    }    recBuf->readIndex = src - &recBuf->samples[0];  /* update read index */    /* return the number of slices copied */    bytesCopied = (int) nextBuf - (buf + (startSliceIndex * bytesPerSlice));    return bytesCopied / bytesPerSlice;}'! !!InterpreterSupportCode class methodsFor: 'source files'!macTCPFile    ^ '/*     File:        MacTCP.h      Contains:    TCP Manager Interfaces.      Version:    Technology:    MacTCP 2.0.6                 Package:    Universal Interfaces 2.1º1 in ╥MPW Prerelease╙ on ETO #17      Copyright:    ⌐ 1984-1995 by Apple Computer, Inc.                 All rights reserved.      Bugs?:        If you find a problem with this file, use the Apple Bug Reporter                 stack.  Include the file and version information (from above)                 in the problem description and send to:                     Internet:    [e-mail]                     AppleLink:    APPLE.BUGS */#ifndef __MACTCP__#define __MACTCP__#ifndef __TYPES__#include <Types.h>#endif/*    #include <ConditionalMacros.h>                                */#ifndef __APPLETALK__#include <AppleTalk.h>#endif/*    #include <OSUtils.h>                                        *//*        #include <MixedMode.h>                                    *//*        #include <Memory.h>                                        */#ifdef __cplusplusextern "C" {#endif#if PRAGMA_ALIGN_SUPPORTED#pragma options align=mac68k#endif#if PRAGMA_IMPORT_SUPPORTED#pragma import on#endif/*Developer Notes:        0. This MacTCP header replaces what used to be defined in the following header files            MacTCPCommonTypes.h            GetMyIPAddr.h            MiscIPPB.h            TCPPB.h            UDPPB.h                         When the various control calls are made to the ip driver, you must set up a             NewRoutineDescriptor for every non-nil completion routine and/or notifyProc parameter.              Otherwise, the 68K driver code, will not correctly call your routine.        1. For ipctlGetAddr Control calls, use NewGetIPIOCompletionProc            to set up a GetIPIOCompletionUPP universal procptr to pass as            the ioCompletion parameter.        2. For the ipctlEchoICMP and ipctlLAPStats Control calls, use             NewIPIOCompletion to set up a IPIOCompletionUPP universal procptr            to pass in the ioCompletion field of the parameter block.        3. For TCPCreatePB Control calls, use NewTCPNotifyProc to set up a            TCPNotifyUPP universal procptr to pass in the notifyProc field            of the parameter block        4. For all of the TCP Control calls using the TCPiopb parameter block,            use NewTCPIOCompletionProc to set up a TCPIOCompletionUPP            universal procptr to pass in the ioCompletion field of the paramter            block.        5. For UDBCreatePB Control calls, use NewUDPNotifyProc to set up a            UDPNotifyUPP universal procptr to pass in the notifyProc field            of the parameter block        6. For all of the UDP Control calls using the UDPiopb parameter block,            use NewUDPIOCompletionProc to set up a UDPIOCompletionUPP            universal procptr to pass in the ioCompletion field of the paramter            block.        7. For all calls implementing a notifyProc or ioCompletion routine            which was set up using a NewTCPRoutineProc call, do not call            DisposeRoutineSDescriptor on the universal procptr until            after the completion or notify proc has completed.*//* MacTCP return Codes in the range -23000 through -23049 */enum {    inProgress                    = 1,                            /* I/O in progress */    ipBadLapErr                    = -23000,                        /* bad network configuration */    ipBadCnfgErr                = -23001,                        /* bad IP configuration error */    ipNoCnfgErr                    = -23002,                        /* missing IP or LAP configuration error */    ipLoadErr                    = -23003,                        /* error in MacTCP load */    ipBadAddr                    = -23004,                        /* error in getting address */    connectionClosing            = -23005,                        /* connection is closing */    invalidLength                = -23006,    connectionExists            = -23007,                        /* request conflicts with existing connection */    connectionDoesntExist        = -23008,                        /* connection does not exist */    insufficientResources        = -23009,                        /* insufficient resources to perform request */    invalidStreamPtr            = -23010,    streamAlreadyOpen            = -23011,    connectionTerminated        = -23012,    invalidBufPtr                = -23013,    invalidRDS                    = -23014,    invalidWDS                    = -23014,    openFailed                    = -23015,    commandTimeout                = -23016,    duplicateSocket                = -23017};/* Error codes from internal IP functions */enum {    ipDontFragErr                = -23032,                        /* Packet too large to send w/o fragmenting */    ipDestDeadErr                = -23033,                        /* destination not responding */    icmpEchoTimeoutErr            = -23035,                        /* ICMP echo timed-out */    ipNoFragMemErr                = -23036,                        /* no memory to send fragmented pkt */    ipRouteErr                    = -23037,                        /* can''t route packet off-net */    nameSyntaxErr                = -23041,    cacheFault                    = -23042,    noResultProc                = -23043,    noNameServer                = -23044,    authNameErr                    = -23045,    noAnsErr                    = -23046,    dnrErr                        = -23047,    outOfMemory                    = -23048};enum {    BYTES_16WORD                = 2,                            /* bytes per = 16, bit ip word */    BYTES_32WORD                = 4,                            /* bytes per = 32, bit ip word */    BYTES_64WORD                = 8                                /* bytes per = 64, bit ip word */};/* 8-bit quantity */typedef UInt8 b_8;/* 16-bit quantity */typedef UInt16 b_16;/* 32-bit quantity */typedef UInt32 b_32;/* IP address is 32-bits */typedef b_32 ip_addr;struct ip_addrbytes {    union {        b_32                            addr;        UInt8                            byte[4];    }                                a;};typedef struct ip_addrbytes ip_addrbytes;struct wdsEntry {    unsigned short                    length;                        /* length of buffer */    Ptr                                ptr;                        /* pointer to buffer */};typedef struct wdsEntry wdsEntry;struct rdsEntry {    unsigned short                    length;                        /* length of buffer */    Ptr                                ptr;                        /* pointer to buffer */};typedef struct rdsEntry rdsEntry;typedef unsigned long BufferPtr;typedef unsigned long StreamPtr;enum {    netUnreach                    = 0,    hostUnreach                    = 1,    protocolUnreach                = 2,    portUnreach                    = 3,    fragReqd                    = 4,    sourceRouteFailed            = 5,    timeExceeded                = 6,    parmProblem                    = 7,    missingOption                = 8,    lastICMPMsgType                = 32767};typedef unsigned short ICMPMsgType;typedef b_16 ip_port;struct ICMPReport {    StreamPtr                        streamPtr;    ip_addr                            localHost;    ip_port                            localPort;    ip_addr                            remoteHost;    ip_port                            remotePort;    short                            reportType;    unsigned short                    optionalAddlInfo;    unsigned long                    optionalAddlInfoPtr;};typedef struct ICMPReport ICMPReport;/* csCode to get our IP address */enum {    ipctlGetAddr                = 15};typedef void (*GetIPIOCompletionProcPtr)(struct GetAddrParamBlock *iopb);#if GENERATINGCFMtypedef UniversalProcPtr GetIPIOCompletionUPP;#elsetypedef GetIPIOCompletionProcPtr GetIPIOCompletionUPP;#endif#define GetIPParamBlockHeader     \    struct QElem*    qLink;         \    short    qType;                 \    short    ioTrap;                 \    Ptr    ioCmdAddr;                 \    GetIPIOCompletionUPP    ioCompletion;  \    OSErr    ioResult;             \    StringPtr    ioNamePtr;         \    short    ioVRefNum;                \    short    ioCRefNum;                \    short    csCodestruct GetAddrParamBlock {    struct QElem                    *qLink;    short                            qType;    short                            ioTrap;    Ptr                                ioCmdAddr;    GetIPIOCompletionUPP            ioCompletion;    OSErr                            ioResult;    StringPtr                        ioNamePtr;    short                            ioVRefNum;    short                            ioCRefNum;    short                            csCode;                        /* standard I/O header */    ip_addr                            ourAddress;                    /* our IP address */    long                            ourNetMask;                    /* our IP net mask */};typedef struct GetAddrParamBlock GetAddrParamBlock;/* control codes */enum {    ipctlEchoICMP                = 17,                            /* send icmp echo */    ipctlLAPStats                = 19                            /* get lap stats */};typedef void (*IPIOCompletionProcPtr)(struct ICMPParamBlock *iopb);#if GENERATINGCFMtypedef UniversalProcPtr IPIOCompletionUPP;#elsetypedef IPIOCompletionProcPtr IPIOCompletionUPP;#endif#define IPParamBlockHeader         \    struct QElem*    qLink;         \    short    qType;                 \    short    ioTrap;                 \    Ptr    ioCmdAddr;                 \    IPIOCompletionUPP    ioCompletion;  \    OSErr    ioResult;             \    StringPtr    ioNamePtr;         \    short    ioVRefNum;                \    short    ioCRefNum;                \    short    csCodestruct ICMPParamBlock {    struct QElem                    *qLink;    short                            qType;    short                            ioTrap;    Ptr                                ioCmdAddr;    IPIOCompletionUPP                ioCompletion;    OSErr                            ioResult;    StringPtr                        ioNamePtr;    short                            ioVRefNum;    short                            ioCRefNum;    short                            csCode;                        /* standard I/O header */    short                            params[11];    struct {        unsigned long                    echoRequestOut;            /* time in ticks of when the echo request went out */        unsigned long                    echoReplyIn;            /* time in ticks of when the reply was received */        struct rdsEntry                    echoedData;                /* data received in responce */        Ptr                                options;        unsigned long                    userDataPtr;    }                                icmpEchoInfo;};typedef pascal void (*ICMPEchoNotifyProcPtr)(struct ICMPParamBlock *iopb);#if GENERATINGCFMtypedef UniversalProcPtr ICMPEchoNotifyUPP;#elsetypedef ICMPEchoNotifyProcPtr ICMPEchoNotifyUPP;#endifstruct IPParamBlock {    struct QElem                    *qLink;    short                            qType;    short                            ioTrap;    Ptr                                ioCmdAddr;    IPIOCompletionUPP                ioCompletion;    OSErr                            ioResult;    StringPtr                        ioNamePtr;    short                            ioVRefNum;    short                            ioCRefNum;    short                            csCode;                        /* standard I/O header */    union {        struct {            ip_addr                            dest;                /* echo to IP address */            wdsEntry                        data;            short                            timeout;            Ptr                                options;            unsigned short                    optLength;            ICMPEchoNotifyUPP                icmpCompletion;            unsigned long                    userDataPtr;        }                                IPEchoPB;        struct {            struct LAPStats                    *lapStatsPtr;        }                                LAPStatsPB;    }                                csParam;};union LAPStatsAddrXlation {    struct arp_entry                *arp_table;    struct nbp_entry                *nbp_table;};struct LAPStats {    short                            ifType;    char                            *ifString;    short                            ifMaxMTU;    long                            ifSpeed;    short                            ifPhyAddrLength;    char                            *ifPhysicalAddress;    union LAPStatsAddrXlation        AddrXlation;    short                            slotNumber;};typedef struct LAPStats LAPStats;struct nbp_entry {    ip_addr                            ip_address;                    /* IP address */    AddrBlock                        at_address;                    /* matching AppleTalk address */    Boolean                            gateway;                    /* TRUE if entry for a gateway */    Boolean                            valid;                        /* TRUE if LAP address is valid */    Boolean                            probing;                    /* TRUE if NBP lookup pending */    SInt8                            afiller;                    /* Filler for proper byte alignment     */    long                            age;                        /* ticks since cache entry verified */    long                            access;                        /* ticks since last access */    SInt8                            filler[116];                /* for internal use only !!!!!! */};struct Enet_addr {    b_16                            en_hi;    b_32                            en_lo;};typedef struct Enet_addr Enet_addr;struct arp_entry {    short                            age;                        /* cache aging field */    b_16                            protocol;                    /* Protocol type */    ip_addr                            ip_address;                    /* IP address */    Enet_addr                        en_address;                    /* matching Ethernet address */};typedef struct arp_entry arp_entry;/* number of ARP table entries */enum {    ARP_TABLE_SIZE                = 20};enum {    NBP_TABLE_SIZE                = 20,                            /* number of NBP table entries */    NBP_MAX_NAME_SIZE            = 16 + 10 + 2};/* Command codes */enum {    TCPCreate                    = 30,    TCPPassiveOpen                = 31,    TCPActiveOpen                = 32,    TCPSend                        = 34,    TCPNoCopyRcv                = 35,    TCPRcvBfrReturn                = 36,    TCPRcv                        = 37,    TCPClose                    = 38,    TCPAbort                    = 39,    TCPStatus                    = 40,    TCPExtendedStat                = 41,    TCPRelease                    = 42,    TCPGlobalInfo                = 43,    TCPCtlMax                    = 49};enum {    TCPClosing                    = 1,    TCPULPTimeout                = 2,    TCPTerminate                = 3,    TCPDataArrival                = 4,    TCPUrgent                    = 5,    TCPICMPReceived                = 6,    lastEvent                    = 32767};typedef unsigned short TCPEventCode;enum {    TCPRemoteAbort                = 2,    TCPNetworkFailure            = 3,    TCPSecPrecMismatch            = 4,    TCPULPTimeoutTerminate        = 5,    TCPULPAbort                    = 6,    TCPULPClose                    = 7,    TCPServiceError                = 8,    lastReason                    = 32767};typedef unsigned short TCPTerminationReason;typedef pascal void (*TCPNotifyProcPtr)(StreamPtr tcpStream, unsigned short eventCode, Ptr userDataPtr, unsigned short terminReason, struct ICMPReport *icmpMsg);#if GENERATINGCFMtypedef UniversalProcPtr TCPNotifyUPP;#elsetypedef TCPNotifyProcPtr TCPNotifyUPP;#endiftypedef unsigned short tcp_port;/* ValidityFlags */enum {    timeoutValue                = 0x80,    timeoutAction                = 0x40,    typeOfService                = 0x20,    precedence                    = 0x10};/* TOSFlags */enum {    lowDelay                    = 0x01,    throughPut                    = 0x02,    reliability                    = 0x04};struct TCPCreatePB {    Ptr                                rcvBuff;    unsigned long                    rcvBuffLen;    TCPNotifyUPP                    notifyProc;    Ptr                                userDataPtr;};typedef struct TCPCreatePB TCPCreatePB;struct TCPOpenPB {    SInt8                            ulpTimeoutValue;    SInt8                            ulpTimeoutAction;    SInt8                            validityFlags;    SInt8                            commandTimeoutValue;    ip_addr                            remoteHost;    tcp_port                        remotePort;    ip_addr                            localHost;    tcp_port                        localPort;    SInt8                            tosFlags;    SInt8                            precedence;    Boolean                            dontFrag;    SInt8                            timeToLive;    SInt8                            security;    SInt8                            optionCnt;    SInt8                            options[40];    Ptr                                userDataPtr;};typedef struct TCPOpenPB TCPOpenPB;struct TCPSendPB {    SInt8                            ulpTimeoutValue;    SInt8                            ulpTimeoutAction;    SInt8                            validityFlags;    Boolean                            pushFlag;    Boolean                            urgentFlag;    SInt8                            filler;                        /* Filler for proper byte alignment     */    Ptr                                wdsPtr;    unsigned long                    sendFree;    unsigned short                    sendLength;    Ptr                                userDataPtr;};typedef struct TCPSendPB TCPSendPB;/* for receive and return rcv buff calls *//*   Note: the filler in the following structure is in a different location than *//*         that specified in the Programmer''s Guide.  */struct TCPReceivePB {    SInt8                            commandTimeoutValue;    Boolean                            markFlag;    Boolean                            urgentFlag;    SInt8                            filler;                        /* Filler for proper byte alignment  */    Ptr                                rcvBuff;    unsigned short                    rcvBuffLen;    Ptr                                rdsPtr;    unsigned short                    rdsLength;    unsigned short                    secondTimeStamp;    Ptr                                userDataPtr;};typedef struct TCPReceivePB TCPReceivePB;struct TCPClosePB {    SInt8                            ulpTimeoutValue;    SInt8                            ulpTimeoutAction;    SInt8                            validityFlags;    SInt8                            filler;                        /* Filler for proper byte alignment     */    Ptr                                userDataPtr;};typedef struct TCPClosePB TCPClosePB;struct HistoBucket {    unsigned short                    value;    unsigned long                    counter;};typedef struct HistoBucket HistoBucket;enum {    NumOfHistoBuckets            = 7};struct TCPConnectionStats {    unsigned long                    dataPktsRcvd;    unsigned long                    dataPktsSent;    unsigned long                    dataPktsResent;    unsigned long                    bytesRcvd;    unsigned long                    bytesRcvdDup;    unsigned long                    bytesRcvdPastWindow;    unsigned long                    bytesSent;    unsigned long                    bytesResent;    unsigned short                    numHistoBuckets;    struct HistoBucket                sentSizeHisto[NumOfHistoBuckets];    unsigned short                    lastRTT;    unsigned short                    tmrSRTT;    unsigned short                    rttVariance;    unsigned short                    tmrRTO;    SInt8                            sendTries;    SInt8                            sourchQuenchRcvd;};typedef struct TCPConnectionStats TCPConnectionStats;struct TCPStatusPB {    SInt8                            ulpTimeoutValue;    SInt8                            ulpTimeoutAction;    long                            unused;    ip_addr                            remoteHost;    tcp_port                        remotePort;    ip_addr                            localHost;    tcp_port                        localPort;    SInt8                            tosFlags;    SInt8                            precedence;    SInt8                            connectionState;    SInt8                            filler;                        /* Filler for proper byte alignment     */    unsigned short                    sendWindow;    unsigned short                    rcvWindow;    unsigned short                    amtUnackedData;    unsigned short                    amtUnreadData;    Ptr                                securityLevelPtr;    unsigned long                    sendUnacked;    unsigned long                    sendNext;    unsigned long                    congestionWindow;    unsigned long                    rcvNext;    unsigned long                    srtt;    unsigned long                    lastRTT;    unsigned long                    sendMaxSegSize;    struct TCPConnectionStats        *connStatPtr;    Ptr                                userDataPtr;};typedef struct TCPStatusPB TCPStatusPB;struct TCPAbortPB {    Ptr                                userDataPtr;};typedef struct TCPAbortPB TCPAbortPB;struct TCPParam {    unsigned long                    tcpRtoA;    unsigned long                    tcpRtoMin;    unsigned long                    tcpRtoMax;    unsigned long                    tcpMaxSegSize;    unsigned long                    tcpMaxConn;    unsigned long                    tcpMaxWindow;};typedef struct TCPParam TCPParam;struct TCPStats {    unsigned long                    tcpConnAttempts;    unsigned long                    tcpConnOpened;    unsigned long                    tcpConnAccepted;    unsigned long                    tcpConnClosed;    unsigned long                    tcpConnAborted;    unsigned long                    tcpOctetsIn;    unsigned long                    tcpOctetsOut;    unsigned long                    tcpOctetsInDup;    unsigned long                    tcpOctetsRetrans;    unsigned long                    tcpInputPkts;    unsigned long                    tcpOutputPkts;    unsigned long                    tcpDupPkts;    unsigned long                    tcpRetransPkts;};typedef struct TCPStats TCPStats;typedef StreamPtr *StreamPPtr;struct TCPGlobalInfoPB {    struct TCPParam                    *tcpParamPtr;    struct TCPStats                    *tcpStatsPtr;    StreamPPtr                        tcpCDBTable[1];    Ptr                                userDataPtr;    unsigned short                    maxTCPConnections;};typedef struct TCPGlobalInfoPB TCPGlobalInfoPB;typedef void (*TCPIOCompletionProcPtr)(struct TCPiopb *iopb);#if GENERATINGCFMtypedef UniversalProcPtr TCPIOCompletionUPP;#elsetypedef TCPIOCompletionProcPtr TCPIOCompletionUPP;#endifstruct TCPiopb {    SInt8                            fill12[12];    TCPIOCompletionUPP                ioCompletion;    short                            ioResult;    Ptr                                ioNamePtr;    short                            ioVRefNum;    short                            ioCRefNum;    short                            csCode;    StreamPtr                        tcpStream;    union {        struct TCPCreatePB                create;        struct TCPOpenPB                open;        struct TCPSendPB                send;        struct TCPReceivePB                receive;        struct TCPClosePB                close;        struct TCPAbortPB                abort;        struct TCPStatusPB                status;        struct TCPGlobalInfoPB            globalInfo;    }                                csParam;};typedef struct TCPiopb TCPiopb;enum {    UDPCreate                    = 20,    UDPRead                        = 21,    UDPBfrReturn                = 22,    UDPWrite                    = 23,    UDPRelease                    = 24,    UDPMaxMTUSize                = 25,    UDPStatus                    = 26,    UDPMultiCreate                = 27,    UDPMultiSend                = 28,    UDPMultiRead                = 29,    UDPCtlMax                    = 29};enum {    UDPDataArrival                = 1,    UDPICMPReceived                = 2,    lastUDPEvent                = 32767};typedef unsigned short UDPEventCode;typedef pascal void (*UDPNotifyProcPtr)(StreamPtr udpStream, unsigned short eventCode, Ptr userDataPtr, struct ICMPReport *icmpMsg);#if GENERATINGCFMtypedef UniversalProcPtr UDPNotifyUPP;#elsetypedef UDPNotifyProcPtr UDPNotifyUPP;#endiftypedef unsigned short udp_port;/* for create and release calls */struct UDPCreatePB {    Ptr                                rcvBuff;    unsigned long                    rcvBuffLen;    UDPNotifyUPP                    notifyProc;    unsigned short                    localPort;    Ptr                                userDataPtr;    udp_port                        endingPort;};typedef struct UDPCreatePB UDPCreatePB;struct UDPSendPB {    unsigned short                    reserved;    ip_addr                            remoteHost;    udp_port                        remotePort;    Ptr                                wdsPtr;    Boolean                            checkSum;    SInt8                            filler;                        /* Filler for proper byte alignment     */    unsigned short                    sendLength;    Ptr                                userDataPtr;    udp_port                        localPort;};typedef struct UDPSendPB UDPSendPB;/* for receive and buffer return calls */struct UDPReceivePB {    unsigned short                    timeOut;    ip_addr                            remoteHost;    udp_port                        remotePort;    Ptr                                rcvBuff;    unsigned short                    rcvBuffLen;    unsigned short                    secondTimeStamp;    Ptr                                userDataPtr;    ip_addr                            destHost;                    /* only for use with multi rcv */    udp_port                        destPort;                    /* only for use with multi rcv */};typedef struct UDPReceivePB UDPReceivePB;struct UDPMTUPB {    unsigned short                    mtuSize;    ip_addr                            remoteHost;    Ptr                                userDataPtr;};typedef struct UDPMTUPB UDPMTUPB;typedef void (*UDPIOCompletionProcPtr)(struct UDPiopb *iopb);#if GENERATINGCFMtypedef UniversalProcPtr UDPIOCompletionUPP;#elsetypedef UDPIOCompletionProcPtr UDPIOCompletionUPP;#endifstruct UDPiopb {    SInt8                            fill12[12];    UDPIOCompletionUPP                ioCompletion;    short                            ioResult;    Ptr                                ioNamePtr;    short                            ioVRefNum;    short                            ioCRefNum;    short                            csCode;    StreamPtr                        udpStream;    union {        struct UDPCreatePB                create;        struct UDPSendPB                send;        struct UDPReceivePB                receive;        struct UDPMTUPB                    mtu;    }                                csParam;};typedef struct UDPiopb UDPiopb;#if GENERATINGCFM#else#endifenum {    uppGetIPIOCompletionProcInfo = kCStackBased         | STACK_ROUTINE_PARAMETER(1, SIZE_CODE(sizeof(struct GetAddrParamBlock*))),    uppIPIOCompletionProcInfo = kCStackBased         | STACK_ROUTINE_PARAMETER(1, SIZE_CODE(sizeof(struct ICMPParamBlock*))),    uppICMPEchoNotifyProcInfo = kPascalStackBased         | STACK_ROUTINE_PARAMETER(1, SIZE_CODE(sizeof(struct ICMPParamBlock*))),    uppTCPNotifyProcInfo = kPascalStackBased         | STACK_ROUTINE_PARAMETER(1, SIZE_CODE(sizeof(StreamPtr)))         | STACK_ROUTINE_PARAMETER(2, SIZE_CODE(sizeof(unsigned short)))         | STACK_ROUTINE_PARAMETER(3, SIZE_CODE(sizeof(Ptr)))         | STACK_ROUTINE_PARAMETER(4, SIZE_CODE(sizeof(unsigned short)))         | STACK_ROUTINE_PARAMETER(5, SIZE_CODE(sizeof(struct ICMPReport*))),    uppTCPIOCompletionProcInfo = kCStackBased         | STACK_ROUTINE_PARAMETER(1, SIZE_CODE(sizeof(struct TCPiopb*))),    uppUDPNotifyProcInfo = kPascalStackBased         | STACK_ROUTINE_PARAMETER(1, SIZE_CODE(sizeof(StreamPtr)))         | STACK_ROUTINE_PARAMETER(2, SIZE_CODE(sizeof(unsigned short)))         | STACK_ROUTINE_PARAMETER(3, SIZE_CODE(sizeof(Ptr)))         | STACK_ROUTINE_PARAMETER(4, SIZE_CODE(sizeof(struct ICMPReport*))),    uppUDPIOCompletionProcInfo = kCStackBased         | STACK_ROUTINE_PARAMETER(1, SIZE_CODE(sizeof(struct UDPiopb*)))};#if GENERATINGCFM#define NewGetIPIOCompletionProc(userRoutine)        \        (GetIPIOCompletionUPP) NewRoutineDescriptor((ProcPtr)(userRoutine), uppGetIPIOCompletionProcInfo, GetCurrentArchitecture())#define NewIPIOCompletionProc(userRoutine)        \        (IPIOCompletionUPP) NewRoutineDescriptor((ProcPtr)(userRoutine), uppIPIOCompletionProcInfo, GetCurrentArchitecture())#define NewICMPEchoNotifyProc(userRoutine)        \        (ICMPEchoNotifyUPP) NewRoutineDescriptor((ProcPtr)(userRoutine), uppICMPEchoNotifyProcInfo, GetCurrentArchitecture())#define NewTCPNotifyProc(userRoutine)        \        (TCPNotifyUPP) NewRoutineDescriptor((ProcPtr)(userRoutine), uppTCPNotifyProcInfo, GetCurrentArchitecture())#define NewTCPIOCompletionProc(userRoutine)        \        (TCPIOCompletionUPP) NewRoutineDescriptor((ProcPtr)(userRoutine), uppTCPIOCompletionProcInfo, GetCurrentArchitecture())#define NewUDPNotifyProc(userRoutine)        \        (UDPNotifyUPP) NewRoutineDescriptor((ProcPtr)(userRoutine), uppUDPNotifyProcInfo, GetCurrentArchitecture())#define NewUDPIOCompletionProc(userRoutine)        \        (UDPIOCompletionUPP) NewRoutineDescriptor((ProcPtr)(userRoutine), uppUDPIOCompletionProcInfo, GetCurrentArchitecture())#else#define NewGetIPIOCompletionProc(userRoutine)        \        ((GetIPIOCompletionUPP) (userRoutine))#define NewIPIOCompletionProc(userRoutine)        \        ((IPIOCompletionUPP) (userRoutine))#define NewICMPEchoNotifyProc(userRoutine)        \        ((ICMPEchoNotifyUPP) (userRoutine))#define NewTCPNotifyProc(userRoutine)        \        ((TCPNotifyUPP) (userRoutine))#define NewTCPIOCompletionProc(userRoutine)        \        ((TCPIOCompletionUPP) (userRoutine))#define NewUDPNotifyProc(userRoutine)        \        ((UDPNotifyUPP) (userRoutine))#define NewUDPIOCompletionProc(userRoutine)        \        ((UDPIOCompletionUPP) (userRoutine))#endif#if GENERATINGCFM#define CallGetIPIOCompletionProc(userRoutine, iopb)        \        CallUniversalProc((UniversalProcPtr)(userRoutine), uppGetIPIOCompletionProcInfo, (iopb))#define CallIPIOCompletionProc(userRoutine, iopb)        \        CallUniversalProc((UniversalProcPtr)(userRoutine), uppIPIOCompletionProcInfo, (iopb))#define CallICMPEchoNotifyProc(userRoutine, iopb)        \        CallUniversalProc((UniversalProcPtr)(userRoutine), uppICMPEchoNotifyProcInfo, (iopb))#define CallTCPNotifyProc(userRoutine, tcpStream, eventCode, userDataPtr, terminReason, icmpMsg)        \        CallUniversalProc((UniversalProcPtr)(userRoutine), uppTCPNotifyProcInfo, (tcpStream), (eventCode), (userDataPtr), (terminReason), (icmpMsg))#define CallTCPIOCompletionProc(userRoutine, iopb)        \        CallUniversalProc((UniversalProcPtr)(userRoutine), uppTCPIOCompletionProcInfo, (iopb))#define CallUDPNotifyProc(userRoutine, udpStream, eventCode, userDataPtr, icmpMsg)        \        CallUniversalProc((UniversalProcPtr)(userRoutine), uppUDPNotifyProcInfo, (udpStream), (eventCode), (userDataPtr), (icmpMsg))#define CallUDPIOCompletionProc(userRoutine, iopb)        \        CallUniversalProc((UniversalProcPtr)(userRoutine), uppUDPIOCompletionProcInfo, (iopb))#else#define CallGetIPIOCompletionProc(userRoutine, iopb)        \        (*(userRoutine))((iopb))#define CallIPIOCompletionProc(userRoutine, iopb)        \        (*(userRoutine))((iopb))#define CallICMPEchoNotifyProc(userRoutine, iopb)        \        (*(userRoutine))((iopb))#define CallTCPNotifyProc(userRoutine, tcpStream, eventCode, userDataPtr, terminReason, icmpMsg)        \        (*(userRoutine))((tcpStream), (eventCode), (userDataPtr), (terminReason), (icmpMsg))#define CallTCPIOCompletionProc(userRoutine, iopb)        \        (*(userRoutine))((iopb))#define CallUDPNotifyProc(userRoutine, udpStream, eventCode, userDataPtr, icmpMsg)        \        (*(userRoutine))((udpStream), (eventCode), (userDataPtr), (icmpMsg))#define CallUDPIOCompletionProc(userRoutine, iopb)        \        (*(userRoutine))((iopb))#endif#if PRAGMA_IMPORT_SUPPORTED#pragma import off#endif#if PRAGMA_ALIGN_SUPPORTED#pragma options align=reset#endif#ifdef __cplusplus}#endif#endif /* __MACTCP__ */'.! !!InterpreterSupportCode class methodsFor: 'source files' stamp: 'jm 9/21/97 18:08'!macWindowFile    ^ '#include <MacHeaders.h>#include <OSUtils.h>#include <Timer.h>#include <profiler.h>#include "sq.h"/*** Compilation Options:**    define PLUGIN        to compile code for Netscape Plug-in*    define MAKE_PROFILE    to compile code for profiling****///#define PLUGIN//#define MAKE_PROFILE/*** Enumerations ***/enum { appleID = 1, fileID, editID };enum { quitItem = 1 };/*** Variables -- Imported from Virtual Machine ***/extern unsigned char *memory;extern int interruptCheckCounter;extern int interruptKeycode;extern int interruptPending;  /* set to true by recordKeystroke if interrupt key is pressed */extern int savedWindowSize;   /* set from header when image file is loaded *//*** Variables -- image and path names ***/#define IMAGE_NAME_SIZE 300char imageName[IMAGE_NAME_SIZE + 1];  /* full path to image */#define SHORTIMAGE_NAME_SIZE 100char shortImageName[SHORTIMAGE_NAME_SIZE + 1];  /* just the image file name */#define DOCUMENT_NAME_SIZE 300char documentName[DOCUMENT_NAME_SIZE + 1];  /* full path to document or image file */#define SHORTDOCUMENT_NAME_SIZE 100char shortDocumentName[SHORTDOCUMENT_NAME_SIZE + 1];  /* just the document file name */#define VMPATH_SIZE 300char vmPath[VMPATH_SIZE + 1];  /* full path to interpreter''s directory *//*** Variables -- Mac Related ***/MenuHandle        appleMenu = nil;Handle            clipboardBuffer = nil;MenuHandle        editMenu = nil;MenuHandle        fileMenu = nil;CTabHandle        stColorTable = nil;PixMapHandle    stPixMap = nil;WindowPtr        stWindow = nil;/*** Variables -- Event Recording ***/#define KEYBUF_SIZE 64int keyBuf[KEYBUF_SIZE];    /* circular buffer */int keyBufGet = 0;            /* index of next item of keyBuf to read */int keyBufPut = 0;            /* index of next item of keyBuf to write */int keyBufOverflows = 0;    /* number of characters dropped */int buttonState = 0;        /* mouse button and modifier state when mouse                               button went down or 0 if not pressed */Point savedMousePosition;        /* mouse position when window is inactive */int windowActive = true;        /* true if the Squeak window is the active window *//* This table maps the 5 Macintosh modifier key bits to 4 Squeak modifier   bits. (The Mac shift and caps lock keys are both mapped to the single   Squeak shift bit).        Mac bits: <control><option><caps lock><shift><command>        ST bits:  <command><option><control><shift>   */ char modifierMap[32] = {    0,  8, 1,  9, 1,  9, 1,  9, 4, 12, 5, 13, 5, 13, 5, 13,    2, 10, 3, 11, 3, 11, 3, 11, 6, 14, 7, 15, 7, 15, 7, 15};/*** Functions ***/void AdjustMenus(void);void FreeClipboard(void);void FreePixmap(void);char * GetAttributeString(int id);int  HandleEvents(void);void HandleMenu(int mSelect);void HandleMouseDown(EventRecord *theEvent);void InitMacintosh(void);void InstallAppleEventHandlers(void);int  IsImageName(char *name);void SetColorEntry(int index, int red, int green, int blue);void SetUpClipboard(void);void SetUpMenus(void);void SetUpPixmap(void);void SetUpWindow(void);void SetWindowSize(void);void SetWindowTitle(char *title);void StoreFullPathForLocalNameInto(char *shortName, char *fullName, int length);/* event capture */int recordKeystroke(EventRecord *theEvent);int recordModifierButtons(EventRecord *theEvent);int recordMouseDown(EventRecord *theEvent);/*** Apple Event Handlers ***/static pascal OSErr HandleOpenAppEvent(AEDescList *aevt, AEDescList *reply, int refCon);static pascal OSErr HandleOpenDocEvent(AEDescList *aevt, AEDescList *reply, int refCon);static pascal OSErr HandlePrintDocEvent(AEDescList *aevt, AEDescList *reply, int refCon);static pascal OSErr HandleQuitAppEvent(AEDescList *aevt, AEDescList *reply, int refCon);/*** Apple Event Handling ***/void InstallAppleEventHandlers() {    OSErr    err;    long    result;    shortImageName[0] = 0;    err = Gestalt(gestaltAppleEventsAttr, &result);    if (err == noErr) {            AEInstallEventHandler(kCoreEventClass, kAEOpenApplication, NewAEEventHandlerProc(HandleOpenAppEvent),  0, false);        AEInstallEventHandler(kCoreEventClass, kAEOpenDocuments,   NewAEEventHandlerProc(HandleOpenDocEvent),  0, false);        AEInstallEventHandler(kCoreEventClass, kAEPrintDocuments,  NewAEEventHandlerProc(HandlePrintDocEvent), 0, false);        AEInstallEventHandler(kCoreEventClass, kAEQuitApplication, NewAEEventHandlerProc(HandleQuitAppEvent),  0, false);    }}pascal OSErr HandleOpenAppEvent(AEDescList *aevt, AEDescList *reply, int refCon) {    /* User double-clicked application; look for "squeak.image" in same directory */    aevt; reply; refCon;  /* reference args to avoid compiler warnings */    /* record path to VM''s home folder */    dir_PathToWorkingDir(vmPath, VMPATH_SIZE);    /* use default image name in same directory as the VM */    strcpy(shortImageName, "squeak.image");    return noErr;}pascal OSErr HandleOpenDocEvent(AEDescList *aevt, AEDescList *reply, int refCon) {    /* User double-clicked an image file. Record the path to the VM''s directory,       then set the default directory to the folder containing the image and       record the image name. Fail if mullitple image files were selected. */    OSErr        err;    AEDesc        fileList = {''NULL'', NULL};    long        numFiles, size;    DescType    type;    AEKeyword    keyword;    FSSpec        fileSpec;    WDPBRec        pb;    reply; refCon;  /* reference args to avoid compiler warnings */    /* record path to VM''s home folder */    dir_PathToWorkingDir(vmPath, VMPATH_SIZE);    /* copy document list */    err = AEGetKeyDesc(aevt, keyDirectObject, typeAEList, &fileList);    if (err) goto done;    /* count list elements */    err = AECountItems( &fileList, &numFiles);    if (err) goto done;    if (numFiles !!= 1) {        error("You may only open one Squeak image or document file at a time.");    }    /* get image name */    err = AEGetNthPtr(&fileList, 1, typeFSS,                      &keyword, &type, (Ptr) &fileSpec, sizeof(fileSpec), &size);    if (err) goto done;    strcpy(shortImageName, p2cstr(fileSpec.name));    if (!!IsImageName(shortImageName)) {        /* record the document name, but run the default image in VM directory */        strcpy(shortDocumentName, shortImageName);        strcpy(shortImageName, "squeak.image");        StoreFullPathForLocalNameInto(shortImageName, imageName, IMAGE_NAME_SIZE);    }    /* make the image or document directory the working directory */    pb.ioNamePtr = NULL;    pb.ioVRefNum = fileSpec.vRefNum;    pb.ioWDDirID = fileSpec.parID;    PBHSetVolSync(&pb);    if (shortDocumentName[0] !!= 0) {        /* record the document''s full name */        StoreFullPathForLocalNameInto(shortDocumentName, documentName, DOCUMENT_NAME_SIZE);    }done:    AEDisposeDesc(&fileList);    return err;}pascal OSErr HandlePrintDocEvent(AEDescList *aevt, AEDescList *reply, int refCon) {    aevt; reply; refCon;  /* reference args to avoid compiler warnings */    return errAEEventNotHandled;}pascal OSErr HandleQuitAppEvent(AEDescList *aevt, AEDescList *reply, int refCon) {    aevt; reply; refCon;  /* reference args to avoid compiler warnings */    return errAEEventNotHandled;}/*** VM Home Directory Path ***/int vmPathSize(void) {    return strlen(vmPath);}int vmPathGetLength(int sqVMPathIndex, int length) {    char *stVMPath = (char *) sqVMPathIndex;    int count, i;    count = strlen(vmPath);    count = (length < count) ? length : count;    /* copy the file name into the Squeak string */    for (i = 0; i < count; i++) {        stVMPath[i] = vmPath[i];    }    return count;}/*** Mac-related Functions ***/void AdjustMenus(void) {    WindowPeek        wp;    int                isDeskAccessory;    wp = (WindowPeek) FrontWindow();    if (wp !!= NULL) {        isDeskAccessory = (wp->windowKind < 0);    } else {        isDeskAccessory = false;    }    if (isDeskAccessory) {        /* Enable items in the Edit menu */        EnableItem(editMenu, 1);        EnableItem(editMenu, 3);        EnableItem(editMenu, 4);        EnableItem(editMenu, 5);        EnableItem(editMenu, 6);    } else {        /* Disable items in the Edit menu */        DisableItem(editMenu, 1);        DisableItem(editMenu, 3);        DisableItem(editMenu, 4);        DisableItem(editMenu, 5);        DisableItem(editMenu, 6);    }}int HandleEvents(void) {    EventRecord        theEvent;    int                ok;    SystemTask();    ok = GetNextEvent(everyEvent, &theEvent);    if (ok) {        switch (theEvent.what) {            case mouseDown:                HandleMouseDown(&theEvent);                return false;            break;            case mouseUp:                recordModifierButtons(&theEvent);                return false;            break;            case keyDown:            case autoKey:                if ((theEvent.modifiers & cmdKey) !!= 0) {                    AdjustMenus();                    HandleMenu(MenuKey(theEvent.message & charCodeMask));                }                recordModifierButtons(&theEvent);                recordKeystroke(&theEvent);            break;            case updateEvt:                BeginUpdate(stWindow);                fullDisplayUpdate();  /* this makes VM call ioShowDisplay */                EndUpdate(stWindow);            break;            case activateEvt:                if (theEvent.modifiers & activeFlag) {                    windowActive = true;                } else {                    GetMouse(&savedMousePosition);                    windowActive = false;                }                InvalRect(&stWindow->portRect);            break;            case kHighLevelEvent:                AEProcessAppleEvent(&theEvent);            break;        }    }    return ok;}void HandleMenu(int mSelect) {    int            menuID, menuItem;    Str255        name;    GrafPtr        savePort;    menuID = HiWord(mSelect);    menuItem = LoWord(mSelect);    switch (menuID) {        case appleID:            GetPort(&savePort);            GetItem(appleMenu, menuItem, name);            OpenDeskAcc(name);            SetPort(savePort);        break;        case fileID:            if (menuItem == quitItem) {                ioExit();            }        break;        case editID:            if (!!SystemEdit(menuItem - 1)) {                SysBeep(5);            }        break;    }}void HandleMouseDown(EventRecord *theEvent) {    WindowPtr    theWindow;    Rect        growLimits = { 20, 20, 4000, 4000 };    Rect        dragBounds;    int            windowCode, newSize;    windowCode = FindWindow(theEvent->where, &theWindow);    switch (windowCode) {        case inSysWindow:            SystemClick(theEvent, theWindow);        break;        case inMenuBar:            AdjustMenus();            HandleMenu(MenuSelect(theEvent->where));        break;        case inDrag:            dragBounds = qd.screenBits.bounds;            if (theWindow == stWindow) {                DragWindow(stWindow, theEvent->where, &dragBounds);            }        break;        case inGrow:            if (theWindow == stWindow) {                newSize = GrowWindow(stWindow, theEvent->where, &growLimits);                if (newSize !!= 0) {                    SizeWindow(stWindow, LoWord(newSize), HiWord(newSize), true);                }            }        break;        case inContent:            if (theWindow == stWindow) {                if (theWindow !!= FrontWindow()) {                    SelectWindow(stWindow);                }                recordMouseDown(theEvent);            }        break;        case inGoAway:            if ((theWindow == stWindow) &&                (TrackGoAway(stWindow, theEvent->where))) {                    /* HideWindow(stWindow); noop for now */            }        break;    }}void InitMacintosh(void) {    MaxApplZone();    InitGraf(&qd.thePort);    InitFonts();    FlushEvents(everyEvent, 0);    InitWindows();    InitMenus();    TEInit();    InitDialogs(NULL);    InitCursor();}void SetUpMenus(void) {    InsertMenu(appleMenu = NewMenu(appleID, "\p\024"), 0);    InsertMenu(fileMenu  = NewMenu(fileID,  "\pFile"), 0);    InsertMenu(editMenu  = NewMenu(editID,  "\pEdit"), 0);    DrawMenuBar();    AddResMenu(appleMenu, ''DRVR'');    AppendMenu(fileMenu, "\pQuit");    AppendMenu(editMenu, "\pUndo/Z;(-;Cut/X;Copy/C;Paste/V;Clear");}void SetColorEntry(int index, int red, int green, int blue) {    (*stColorTable)->ctTable[index].value = index;    (*stColorTable)->ctTable[index].rgb.red = red;    (*stColorTable)->ctTable[index].rgb.green = green;    (*stColorTable)->ctTable[index].rgb.blue = blue;}void FreePixmap(void) {    if (stPixMap !!= nil) {        DisposePixMap(stPixMap);        stPixMap = nil;    }    if (stColorTable !!= nil) {        DisposeHandle((void *) stColorTable);        stColorTable = nil;    }}void SetUpPixmap(void) {    int i, r, g, b;    stColorTable = (CTabHandle) NewHandle(sizeof(ColorTable) + (256 * sizeof(ColorSpec)));    (*stColorTable)->ctSeed = GetCTSeed();    (*stColorTable)->ctFlags = 0;    (*stColorTable)->ctSize = 255;    /* 1-bit colors (monochrome) */    SetColorEntry(0, 65535, 65535, 65535);    /* white or transparent */    SetColorEntry(1,     0,     0,     0);    /* black */    /* additional colors for 2-bit color */    SetColorEntry(2, 65535, 65535, 65535);    /* opaque white */    SetColorEntry(3, 32768, 32768, 32768);    /* 1/2 gray */    /* additional colors for 4-bit color */    SetColorEntry( 4, 65535,     0,     0);    /* red */    SetColorEntry( 5,     0, 65535,     0);    /* green */    SetColorEntry( 6,     0,     0, 65535);    /* blue */    SetColorEntry( 7,     0, 65535, 65535);    /* cyan */    SetColorEntry( 8, 65535, 65535,     0);    /* yellow */    SetColorEntry( 9, 65535,     0, 65535);    /* magenta */    SetColorEntry(10,  8192,  8192,  8192);    /* 1/8 gray */    SetColorEntry(11, 16384, 16384, 16384);    /* 2/8 gray */    SetColorEntry(12, 24576, 24576, 24576);    /* 3/8 gray */    SetColorEntry(13, 40959, 40959, 40959);    /* 5/8 gray */    SetColorEntry(14, 49151, 49151, 49151);    /* 6/8 gray */    SetColorEntry(15, 57343, 57343, 57343);    /* 7/8 gray */    /* additional colors for 8-bit color */    /* 24 more shades of gray (does not repeat 1/8th increments) */    SetColorEntry(16,  2048,  2048,  2048);    /*  1/32 gray */    SetColorEntry(17,  4096,  4096,  4096);    /*  2/32 gray */    SetColorEntry(18,  6144,  6144,  6144);    /*  3/32 gray */    SetColorEntry(19, 10240, 10240, 10240);    /*  5/32 gray */    SetColorEntry(20, 12288, 12288, 12288);    /*  6/32 gray */    SetColorEntry(21, 14336, 14336, 14336);    /*  7/32 gray */    SetColorEntry(22, 18432, 18432, 18432);    /*  9/32 gray */    SetColorEntry(23, 20480, 20480, 20480);    /* 10/32 gray */    SetColorEntry(24, 22528, 22528, 22528);    /* 11/32 gray */    SetColorEntry(25, 26624, 26624, 26624);    /* 13/32 gray */    SetColorEntry(26, 28672, 28672, 28672);    /* 14/32 gray */    SetColorEntry(27, 30720, 30720, 30720);    /* 15/32 gray */    SetColorEntry(28, 34815, 34815, 34815);    /* 17/32 gray */    SetColorEntry(29, 36863, 36863, 36863);    /* 18/32 gray */    SetColorEntry(30, 38911, 38911, 38911);    /* 19/32 gray */    SetColorEntry(31, 43007, 43007, 43007);    /* 21/32 gray */    SetColorEntry(32, 45055, 45055, 45055);    /* 22/32 gray */    SetColorEntry(33, 47103, 47103, 47103);    /* 23/32 gray */    SetColorEntry(34, 51199, 51199, 51199);    /* 25/32 gray */    SetColorEntry(35, 53247, 53247, 53247);    /* 26/32 gray */    SetColorEntry(36, 55295, 55295, 55295);    /* 27/32 gray */    SetColorEntry(37, 59391, 59391, 59391);    /* 29/32 gray */    SetColorEntry(38, 61439, 61439, 61439);    /* 30/32 gray */    SetColorEntry(39, 63487, 63487, 63487);    /* 31/32 gray */    /* The remainder of color table defines a color cube with six steps       for each primary color. Note that the corners of this cube repeat       previous colors, but simplifies the mapping between RGB colors and       color map indices. This color cube spans indices 40 through 255.    */    for (r = 0; r < 6; r++) {        for (g = 0; g < 6; g++) {            for (b = 0; b < 6; b++) {                i = 40 + ((36 * r) + (6 * b) + g);                if (i > 255) error("index out of range in color table compuation");                SetColorEntry(i, (r * 65535) / 5, (g * 65535) / 5, (b * 65535) / 5);            }        }    }    stPixMap = NewPixMap();    (*stPixMap)->pixelType = 0; /* chunky */    (*stPixMap)->cmpCount = 1;    (*stPixMap)->pmTable = stColorTable;}void SetUpWindow(void) {    Rect windowBounds = { 44, 8, 408, 648 };  /* default window bounds */    Rect screen;    int right, bottom;    if (savedWindowSize !!= 0) {        right  = windowBounds.left + ((unsigned) savedWindowSize >> 16);        bottom = windowBounds.top  + (savedWindowSize & 0xFFFF);    } else {        right  = windowBounds.right;        bottom = windowBounds.bottom;    }    /* minimum size is 64 x 64 */    right  = ( right > (windowBounds.left + 64)) ?  right : (windowBounds.left + 64);    bottom = (bottom > (windowBounds.top  + 64)) ? bottom : (windowBounds.top  + 64);    /* maximum bottom-right is screen bottom-right */    screen = qd.screenBits.bounds;    right  = ( right <= screen.right)  ?  right : (screen.right  - 8);    bottom = (bottom <= screen.bottom) ? bottom : (screen.bottom - 8);    windowBounds.right = right;    windowBounds.bottom = bottom;    stWindow = NewCWindow(0L, &windowBounds, "\pWelcome to Squeak!!", true, documentProc, (WindowPtr) -1L, true, 0);}void SetWindowSize(void) {    Rect screen;    int width, height, maxWidth, maxHeight;    if (savedWindowSize !!= 0) {        width  = (unsigned) savedWindowSize >> 16;        height = savedWindowSize & 0xFFFF;    } else {        width  = 640;        height = 480;    }    /* minimum size is 64 x 64 */    width  = ( width > 64) ?   width : 64;    height = (height > 64) ?  height : 64;    /* maximum size is screen size */    screen = qd.screenBits.bounds;    maxWidth  = (screen.right  - screen.left) - 16;    maxHeight = (screen.bottom - screen.top)  - 52;    width  = ( width <= maxWidth)  ?  width : maxWidth;    height = (height <= maxHeight) ? height : maxHeight;    SizeWindow(stWindow, width, height, true);}void SetWindowTitle(char *title) {    SetWTitle(stWindow, c2pstr(title));    p2cstr((unsigned char *) title);}/*** Event Recording Functions ***/int recordKeystroke(EventRecord *theEvent) {    int keystate;    /* keystate: low byte is the ascii character; next 4 bits are modifier bits */    keystate =        (modifierMap[(theEvent->modifiers >> 8) & 0x1F] << 8) |        (theEvent->message & 0xFF);    if (keystate == interruptKeycode) {        /* Note: interrupt key is "meta"; it not reported as a keystroke */        interruptPending = true;        interruptCheckCounter = 0;    } else {        keyBuf[keyBufPut] = keystate;        keyBufPut = (keyBufPut + 1) % KEYBUF_SIZE;        if (keyBufGet == keyBufPut) {            /* buffer overflow; drop the last character */            keyBufGet = (keyBufGet + 1) % KEYBUF_SIZE;            keyBufOverflows++;        }    }}int recordMouseDown(EventRecord *theEvent) {    int stButtons;    stButtons = 4;        /* red button by default */    if ((theEvent->modifiers & optionKey) !!= 0) {        stButtons = 2;    /* yellow button if option down */    }    if ((theEvent->modifiers & cmdKey) !!= 0) {        stButtons = 1;    /* blue button if command down */    }    /* button state: low three bits are mouse buttons; next 4 bits are modifier bits */    buttonState =        (modifierMap[(theEvent->modifiers >> 8) & 0x1F] << 3) |        (stButtons & 0x7);}int recordModifierButtons(EventRecord *theEvent) {    int stButtons = 0;    if (Button()) {        stButtons = buttonState & 0x7;    } else {        stButtons = 0;    }    /* button state: low three bits are mouse buttons; next 4 bits are modifier bits */    buttonState =        (modifierMap[(theEvent->modifiers >> 8) & 0x1F] << 3) |        (stButtons & 0x7);}/*** I/O Primitives ***/int ioBeep(void) {    SysBeep(1000);}int ioExit(void) {    sqNetworkShutdown();    ExitToShell();}int ioGetButtonState(void) {    ioProcessEvents();  /* process all pending events */    return buttonState;}int ioGetKeystroke(void) {    int keystate;    ioProcessEvents();  /* process all pending events */    if (keyBufGet == keyBufPut) {        return -1;  /* keystroke buffer is empty */    } else {        keystate = keyBuf[keyBufGet];        keyBufGet = (keyBufGet + 1) % KEYBUF_SIZE;        /* set modifer bits in buttonState to reflect the last keystroke fetched */        buttonState = ((keystate >> 5) & 0xF8) | (buttonState & 0x7);    }    return keystate;}int ioMicroMSecs(void) {    /* millisecond clock based on microsecond timer (about 60 times slower than ioMSecs!!!!) */    UnsignedWide microTicks;    Microseconds(µTicks);    return (microTicks.lo / 1000) + (microTicks.hi * 4294967);}int ioMousePoint(void) {    Point p;    ioProcessEvents();  /* process all pending events */    if (windowActive) {        GetMouse(&p);    } else {        /* don''t report mouse motion if window is not active */        p = savedMousePosition;    }    return (p.h << 16) | (p.v & 0xFFFF);  /* x is high 16 bits; y is low 16 bits */}int ioPeekKeystroke(void) {    int keystate;    ioProcessEvents();  /* process all pending events */    if (keyBufGet == keyBufPut) {        return -1;  /* keystroke buffer is empty */    } else {        keystate = keyBuf[keyBufGet];        /* set modifer bits in buttonState to reflect the last keystroke peeked at */        buttonState = ((keystate >> 5) & 0xF8) | (buttonState & 0x7);    }    return keystate;}int ioProcessEvents(void) {    /* This is a noop when running as a plugin; the browser handles events. */    int maxPollsPerSec = 30;    static clock_t nextPollTick = 0;#ifndef PLUGIN    if (clock() > nextPollTick) {        /* time to process events!! */        while (HandleEvents()) {            /* process all pending events */        }        /* wait a while before trying again */        nextPollTick = clock() + (CLOCKS_PER_SEC / maxPollsPerSec);    }#endif    return interruptPending;}int ioRelinquishProcessorForMicroseconds(int microSeconds) {    /* This operation is platform dependent. On the Mac, it simply calls     * HandleEvents(), which gives other applications a chance to run.     */    while (HandleEvents()) {        /* process all pending events */    }    return microSeconds;}int ioScreenSize(void) {    int w = 10, h = 10;    if (stWindow !!= nil) {        w = stWindow->portRect.right - stWindow->portRect.left;        h = stWindow->portRect.bottom - stWindow->portRect.top;    }    return (w << 16) | (h & 0xFFFF);  /* w is high 16 bits; h is low 16 bits */}int ioSeconds(void) {    struct tm timeRec;    time_t time1904, timeNow;    /* start of ANSI epoch is midnight of Jan 1, 1904 */    timeRec.tm_sec   = 0;    timeRec.tm_min   = 0;    timeRec.tm_hour  = 0;    timeRec.tm_mday  = 1;    timeRec.tm_mon   = 0;    timeRec.tm_year  = 4;    timeRec.tm_wday  = 0;    timeRec.tm_yday  = 0;    timeRec.tm_isdst = 0;    time1904 = mktime(&timeRec);    timeNow = time(NULL);    /* Squeak epoch is Jan 1, 1901, 3 non-leap years earlier than ANSI one */    return (timeNow - time1904) + (3 * 365 * 24 * 60 * 60);}int ioSetCursor(int cursorBitsIndex, int offsetX, int offsetY) {    Cursor macCursor;    int i;    for (i = 0; i < 16; i++) {        macCursor.data[i] = (checkedLongAt(cursorBitsIndex + (4 * i)) >> 16) & 0xFFFF;        macCursor.mask[i] = (checkedLongAt(cursorBitsIndex + (4 * i)) >> 16) & 0xFFFF;    }    /* Squeak hotspot offsets are negative; Mac''s are positive */    macCursor.hotSpot.h = -offsetX;    macCursor.hotSpot.v = -offsetY;    SetCursor(&macCursor);}int ioShowDisplay(    int dispBitsIndex, int width, int height, int depth,    int affectedL, int affectedR, int affectedT, int affectedB) {    Rect        dstRect = { 0, 0, 0, 0 };    Rect        srcRect = { 0, 0, 0, 0 };    RgnHandle    maskRect = nil;    if (stWindow == nil) {        return;    }    dstRect.left    = 0;    dstRect.top        = 0;    dstRect.right    = width;    dstRect.bottom    = height;    srcRect.left    = 0;    srcRect.top        = 0;    srcRect.right    = width;    srcRect.bottom    = height;    (*stPixMap)->baseAddr = (void *) dispBitsIndex;    /* Note: top three bits of rowBytes indicate this is a PixMap, not a BitMap */    (*stPixMap)->rowBytes = (((((width * depth) + 31) / 32) * 4) & 0x1FFF) | 0x8000;    (*stPixMap)->bounds = srcRect;    (*stPixMap)->pixelSize = depth;    (*stPixMap)->cmpSize = depth;    /* create a mask region so that only the affected rectangle is copied */    maskRect = NewRgn();    SetRectRgn(maskRect, affectedL, affectedT, affectedR, affectedB);    SetPort(stWindow);    CopyBits((BitMap *) *stPixMap, &stWindow->portBits, &srcRect, &dstRect, srcCopy, maskRect);    DisposeRgn(maskRect);}/*** Image File Naming ***/void StoreFullPathForLocalNameInto(char *shortName, char *fullName, int length) {    int offset, sz, i;    offset = dir_PathToWorkingDir(fullName, length);    /* copy the file name into a null-terminated C string */    sz = strlen(shortName);    for (i = 0; i <= sz; i++) {        /* append shortName to fullName, including terminator */        fullName[i + offset] = shortName[i];    }}int imageNameSize(void) {    return strlen(imageName);}int imageNameGetLength(int sqImageNameIndex, int length) {    char *sqImageName = (char *) sqImageNameIndex;    int count, i;    count = strlen(imageName);    count = (length < count) ? length : count;    /* copy the file name into the Squeak string */    for (i = 0; i < count; i++) {        sqImageName[i] = imageName[i];    }    return count;}int imageNamePutLength(int sqImageNameIndex, int length) {    char *sqImageName = (char *) sqImageNameIndex;    int count, i, ch, j;    int lastColonIndex = -1;    count = (IMAGE_NAME_SIZE < length) ? IMAGE_NAME_SIZE : length;    /* copy the file name into a null-terminated C string */    for (i = 0; i < count; i++) {        ch = imageName[i] = sqImageName[i];        if (ch == '':'') {            lastColonIndex = i;        }    }    imageName[count] = 0;    /* copy short image name into a null-terminated C string */    for (i = lastColonIndex + 1, j = 0; i < count; i++, j++) {        shortImageName[j] = imageName[i];    }    shortImageName[j] = 0;    SetWindowTitle(shortImageName);    return count;}/*** Clipboard Support (text only for now) ***/void SetUpClipboard(void) {    /* allocate clipboard in the system heap to support really big copy/paste */    THz oldZone;    oldZone = GetZone();    SetZone(SystemZone());    clipboardBuffer = NewHandle(0);    SetZone(oldZone);}void FreeClipboard(void) {    if (clipboardBuffer !!= nil) {        DisposeHandle(clipboardBuffer);        clipboardBuffer = nil;    }}int clipboardReadIntoAt(int count, int byteArrayIndex, int startIndex) {    long clipSize, charsToMove;    char *srcPtr, *dstPtr, *end;    clipSize = clipboardSize();    charsToMove = (count < clipSize) ? count : clipSize;    srcPtr = (char *) *clipboardBuffer;    dstPtr = (char *) byteArrayIndex + startIndex;    end = srcPtr + charsToMove;    while (srcPtr < end) {        *dstPtr++ = *srcPtr++;    }    return charsToMove;}int clipboardSize(void) {    long count, offset;    count = GetScrap(clipboardBuffer, ''TEXT'', &offset);    if (count < 0) {        return 0;    } else {        return count;    }}int clipboardWriteFromAt(int count, int byteArrayIndex, int startIndex) {    ZeroScrap();    PutScrap(count, ''TEXT'', (char *) (byteArrayIndex + startIndex));}/*** Profiling ***/int clearProfile(void) {#ifdef MAKE_PROFILE    ProfilerClear();#endif}int dumpProfile(void) {#ifdef MAKE_PROFILE    ProfilerDump("\pProfile.out");#endif}int startProfiling(void) {#ifdef MAKE_PROFILE    ProfilerSetStatus(true);#endif}int stopProfiling(void) {#ifdef MAKE_PROFILE    ProfilerSetStatus(false);#endif}/*** Plugin Support ***/int plugInInit(char *fullImagePath) {    if (memory == nil) {        return;    /* failed to read image */    }    /* check the interpreter''s size assumptions for basic data types */    if (sizeof(int) !!= 4) {        error("This C compiler''s integers are not 32 bits.");    }    if (sizeof(double) !!= 8) {        error("This C compiler''s floats are not 64 bits.");    }    if (sizeof(time_t) !!= 4) {        error("This C compiler''s time_t''s are not 32 bits.");    }    strcpy(imageName, fullImagePath);    dir_PathToWorkingDir(vmPath, VMPATH_SIZE);    SetUpClipboard();    SetUpPixmap();    sqFileInit();    joystickInit();}int plugInShutdown(void) {    snd_Stop();    FreeClipboard();    FreePixmap();    if (memory !!= nil) {        DisposePtr((void *) memory);        memory = nil;    }}/*** System Attributes ***/int IsImageName(char *name) {    char *suffix;    suffix = strrchr(name, ''.'');  /* pointer to last period in name */    if (suffix == NULL) return false;    if (strcmp(suffix, ".ima") == 0) return true;    if (strcmp(suffix, ".image") == 0) return true;    if (strcmp(suffix, ".IMA") == 0) return true;    if (strcmp(suffix, ".IMAGE") == 0) return true;    return false;}char * GetAttributeString(int id) {    /* This is a hook for getting various status strings back from       the OS. In particular, it allows Squeak to be passed arguments       such as the name of a file to be processed. Command line options       could be reported this way as well.    */    switch (id) {    case 1:        return documentName;        break;    default:        success(false);        return "";        break;    }}int attributeSize(int id) {    return strlen(GetAttributeString(id));}int getAttributeIntoLength(int id, int byteArrayIndex, int length) {    char *srcPtr, *dstPtr, *end;    int charsToMove;    srcPtr = GetAttributeString(id);    charsToMove = strlen(srcPtr);    if (charsToMove > length) {        charsToMove = length;    }    dstPtr = (char *) byteArrayIndex;    end = srcPtr + charsToMove;    while (srcPtr < end) {        *dstPtr++ = *srcPtr++;    }    return charsToMove;}/*** Main ***/#ifndef PLUGINvoid main(void) {    EventRecord theEvent;    FILE *f;    int reservedMemory, availableMemory;    InitMacintosh();    SetUpMenus();    SetUpClipboard();    SetUpWindow();    SetUpPixmap();    sqFileInit();    joystickInit();    /* install apple event handlers and wait for open event */    imageName[0] = shortImageName[0] = documentName[0] = vmPath[0] = 0;    InstallAppleEventHandlers();    while (shortImageName[0] == 0) {        GetNextEvent(everyEvent, &theEvent);        if (theEvent.what == kHighLevelEvent) {            AEProcessAppleEvent(&theEvent);        }    }    if (imageName[0] == 0) {        StoreFullPathForLocalNameInto(shortImageName, imageName, IMAGE_NAME_SIZE);    }    /* check the interpreter''s size assumptions for basic data types */    if (sizeof(int) !!= 4) {        error("This C compiler''s integers are not 32 bits.");    }    if (sizeof(double) !!= 8) {        error("This C compiler''s floats are not 64 bits.");    }    if (sizeof(time_t) !!= 4) {        error("This C compiler''s time_t''s are not 32 bits.");    }#ifdef MAKE_PROFILE    ProfilerInit(collectDetailed, bestTimeBase, 1000, 50);    ProfilerSetStatus(false);    ProfilerClear();#endif    /* compute the desired memory allocation */    reservedMemory = 400000;    availableMemory = MaxBlock() - reservedMemory;    /******      Note: This is platform-specific. On the Mac, the user specifies the desired        memory partition for each application using the Finder''s Get Info command.        MaxBlock() returns the amount of memory in the partition minus space for        the code segment and other resources. On other platforms, the desired heap        size would be specified in other ways (e.g, via a command line argument).        The maximum size of the object heap is fixed at at startup. If you run low        on space, you must save the image and restart with more memory.      Note: Some memory must be reserved for Mac toolbox calls, sound buffers, etc.        A 30K reserve is too little. 40K allows Squeal to run but crashes if the        console is opened. 50K allows the console to be opened (with and w/o the        profiler). I added another 30K to provide for sound buffers and reliability.        (Note: Later discovered that sound output failed if SoundManager was not        preloaded unless there is about 100K reserved. Added 30K to that.)    ******/    /* uncomment the following when using the C transcript window for debugging: */    //printf("Move this window, then hit CR\n"); getchar();    /* read the image file and allocate memory for Squeak heap */    f = fopen(imageName, "rb");    if (f == NULL) {        /* give a Mac-specific error message if image file is not found */        printf("Could not open the Squeak image file ''%s''\n\n", imageName);        printf("There are several ways to open a Squeak image file. You can:\n");        printf("  1. Double-click on the desired image file.\n");        printf("  2. Drop the image file icon onto the Squeak application or an alias to it.\n");        printf("  3. Name your image ''squeak.image'' and put it in the same folder as the\n");        printf("     Squeak application, then double-click on the Squeak application.\n\n");        printf("Press the return key to exit.\n");        getchar();        printf("Aborting...\n");        ioExit();    }        readImageFromFileHeapSize(f, availableMemory);    fclose(f);    SetWindowTitle(shortImageName);    SetWindowSize();    /* run Squeak */    interpret();}#endif'! !!InterpreterSupportCode class methodsFor: 'source files'!readmeFile    ^ 'Building the Squeak Virtual MachineThe virtual machine is build from one header and eight source files:    sq.h                -- shared definitions included in all .c files    sqFilePrims.c        -- file primitives    sqMacDirectory.c    -- Mac directory enumerations    sqMacJoystick.c        -- primitives to support Gravis MouseStickII joystick    sqMacNetwork.c        -- Mac networking primitives    sqMacSound.c        -- Mac audio output primitives    sqMacWindow.c        -- Mac window and event handling; main program    sqSoundPrims.c        -- automatically generated sound synthesis primitives    interp.c                -- automatically generated code for the virtual machineThe platform specific files are sqMacWindow.c, sqMacDirectory.c, sqMacJoystick.c, sqMacNetwork.c, and sqMacSound.c, totaling about 1800 lines of code when this document was written. All other code is written to standard ANSI libraries and should port easily to other C environments. When doing the initial port to a new system, the functions in sqMacJoystick.c, sqMacNetwork.c, and sqMacSound.c can be replaced by stub functions that do nothing.The code assumes that C ints are 4 bytes and double floats are 8 bytes; these assumptions are checked at start up time. Floats are always stored in PowerPC byte order (which I believe is the IEEE standard byte ordering); macros in sq.h can be defined to swap bytes into and out of the platform native format if necessary.The files interp.c and sqSoundPrims.c are generated automatically, so changes to these files will be lost when the next interpreter is generated. It is fine to make ephemeral changes to these file for the purpose of debugging or statistics gathering. To generate the interpreter, see the "translation" category in Interpreter class. To generate sqSoundPrims.c, see the class method "cCodeForSoundPrimitives" in AbstractSound.The current VM was compiled with Metrowerks CodeWarrier 8. Earlier, I used Semantec Think C 6.0, but discovered a few bugs in their libraries having to do with 8-byte versus 4-byte integers. These bugs could probably be worked around if one really wanted to use that environment.The virtual machine uses the following libraries:    Libraries for 68K Project:        MathLib68K (4i/8d).Lib        MacOS.lib        profiler68k(Small).lib        SIOUX.68K.Lib        ANSI (4i/8d) C.68K.lib    Libraries for PowerPC Project:        ANSI C.PPC.Lib        SIOUX.PPC.Lib        InterfaceLib        profilerPPC.lib        MathLib        MWCRuntime.LibThe Mac networking code also requires three files from Apple''s MacTCP developer''s kit:    MacTCP.h    AddressXlation.h    dnr.cFor convenience, these files are included.To build a fat binary, build the 68K version first, and make sure that the file "Squeak VM 68K" is included in the PowerPC project. Then build the PowerPC version. CodeWarrier will include the 68K interpreter in the resource fork of the output file, resulting in an interpreter that runs on either 68K or PowerPC Macs. To get an additional speedup, the object code for the bytecode dispatch loop of the PPC version can be patched using the method "patchInterp:" in Interpreter class.    -- John Maloney, March 16, 1997'.! !!InterpreterSupportCode class methodsFor: 'source files' stamp: 'jm 9/21/97 18:09'!squeakHeaderFile    ^ '#include <math.h>#include <stdio.h>#include <stdlib.h>#include <string.h>#include <time.h>#define true 1#define false 0#define null 0  /* using ''null'' because nil is predefined in Think C *//* platform-dependent float conversion macros *//* Note: Second argument must be a variable name, not an expression!! *//* Note: Floats in image are always in PowerPC word order; change   these macros to swap words if necessary. This costs no extra and   obviates sometimes having to word-swap floats when reading an image.*/#ifdef DOUBLE_WORD_ALIGNMENT/* word-based copy for machines that require doubles to be double-word aligned */#define storeFloatAtfrom(i, floatVarName) \    *((int *) (i) + 0) = *((int *) &(floatVarName) + 0); \    *((int *) (i) + 1) = *((int *) &(floatVarName) + 1);#define fetchFloatAtinto(i, floatVarName) \    *((int *) &(floatVarName) + 0) = *((int *) (i) + 0); \    *((int *) &(floatVarName) + 1) = *((int *) (i) + 1);#else/* for machines that allow doubles to be on any word boundary */#define storeFloatAtfrom(i, floatVarName) \    *((double *) (i)) = (floatVarName);#define fetchFloatAtinto(i, floatVarName) \    (floatVarName) = *((double *) (i));#endif/*** increment this version number when the image file format changes ***/#define CURRENT_VERSION 6502/* squeak file record; see sqFilePrims.c for details */typedef struct {    FILE    *file;    int        sessionID;    int        writable;    int        fileSize;    int        lastOp;  /* 0 = uncommitted, 1 = read, 2 = write */} SQFile;/* file i/o */int sqFileAtEnd(SQFile *f);int sqFileClose(SQFile *f);int sqFileDeleteNameSize(int sqFileNameIndex, int sqFileNameSize);int sqFileGetPosition(SQFile *f);int sqFileInit(void);int sqFileOpen(SQFile *f, int sqFileNameIndex, int sqFileNameSize, int writeFlag);int sqFileReadIntoAt(SQFile *f, int count, int byteArrayIndex, int startIndex);int sqFileRenameOldSizeNewSize(int oldNameIndex, int oldNameSize, int newNameIndex, int newNameSize);int sqFileSetPosition(SQFile *f, int position);int sqFileSize(SQFile *f);int sqFileValid(SQFile *f);int sqFileWriteFromAt(SQFile *f, int count, int byteArrayIndex, int startIndex);/* directories */int dir_Create(char *pathString, int pathStringLength);int dir_Delimitor(void);int dir_Lookup(char *pathString, int pathStringLength, int index,    /* outputs: */    char *name, int *nameLength, int *creationDate, int *modificationDate,    int *isDirectory, int *sizeIfFile);int dir_PathToWorkingDir(char *pathName, int pathNameMax);int dir_SetMacFileTypeAndCreator(char *filename, int filenameSize, char *fType, char *fCreator);/* interpreter entry points */void error(char *s);int checkedByteAt(int byteAddress);int checkedByteAtput(int byteAddress, int byte);int checkedLongAt(int byteAddress);int checkedLongAtput(int byteAddress, int a32BitInteger);int fullDisplayUpdate(void);int initializeInterpreter(int bytesToShift);int interpret(void);int signalSemaphoreWithIndex(int index);int success(int);/* display, mouse, keyboard, time i/o */int ioBeep(void);int ioExit(void);int ioGetButtonState(void);int ioGetKeystroke(void);int ioMicroMSecs(void);int ioMousePoint(void);int ioPeekKeystroke(void);int ioProcessEvents(void);int ioRelinquishProcessorForMicroseconds(int microSeconds);int ioScreenSize(void);int ioSeconds(void);int ioSetCursor(int cursorBitsIndex, int offsetX, int offsetY);int ioShowDisplay(    int dispBitsIndex, int width, int height, int depth,    int affectedL, int affectedR, int affectedT, int affectedB);/* millisecond clock */#define ioMSecs() ((1000 * clock()) / CLOCKS_PER_SEC)/* image file and VM path names */extern char imageName[];int imageNameGetLength(int sqImageNameIndex, int length);int imageNamePutLength(int sqImageNameIndex, int length);int imageNameSize(void);int vmPathSize(void);int vmPathGetLength(int sqVMPathIndex, int length);/* save/restore */int readImageFromFileHeapSize(FILE *f, int desiredHeapSize);/* clipboard (cut/copy/paste) */int clipboardSize(void);int clipboardReadIntoAt(int count, int byteArrayIndex, int startIndex);int clipboardWriteFromAt(int count, int byteArrayIndex, int startIndex);/* sound output */int snd_AvailableSpace(void);int snd_InsertSamplesFromLeadTime(int frameCount, int srcBufPtr, int samplesOfLeadTime);int snd_PlaySamplesFromAtLength(int frameCount, int arrayIndex, int startIndex);int snd_PlaySilence(void);int snd_Start(int frameCount, int samplesPerSec, int stereo, int semaIndex);int snd_Stop(void);/* sound input */int snd_SetRecordLevel(int level);int snd_StartRecording(int desiredSamplesPerSec, int stereo, int semaIndex);int snd_StopRecording(void);double snd_GetRecordingSampleRate(void);int snd_RecordSamplesIntoAtLength(int buf, int startSliceIndex, int bufferSizeInBytes);/* joystick support */int joystickInit(void);int joystickRead(int stickIndex);/* netscape plug-in support */int plugInInit(char *imageName);int plugInShutdown(void);int plugInInterpretCycles(int cycleCount);/* interpreter entry points needed by compiled primitives */void * arrayValueOf(int arrayOop);int checkedIntegerValueOf(int intOop);void * fetchArrayofObject(int fieldIndex, int objectPointer);double fetchFloatofObject(int fieldIndex, int objectPointer);int fetchIntegerofObject(int fieldIndex, int objectPointer);double floatValueOf(int floatOop);int pop(int nItems);int storeIntegerofObjectwithValue(int fieldIndex, int objectPointer, int integerValue);/* sound generation primitives */int primWaveTableSoundmixSampleCountintostartingAtpan(void);int primFMSoundmixSampleCountintostartingAtpan(void);int primPluckedSoundmixSampleCountintostartingAtpan(void);int primSampledSoundmixSampleCountintostartingAtpan(void);/* squeak socket record; see sqMacNetwork.c for details */typedef struct {    int        sessionID;    int        socketType;  /* 0 = TCP, 1 = UDP */    void    *privateSocketPtr;}  SQSocket, *SocketPtr;/* networking primitives */int        sqNetworkInit(int resolverSemaIndex);void    sqNetworkShutdown(void);void    sqResolverAbort(void);void    sqResolverAddrLookupResult(char *nameForAddress, int nameSize);int        sqResolverAddrLookupResultSize(void);int        sqResolverError(void);int        sqResolverLocalAddress(void);int        sqResolverNameLookupResult(void);void    sqResolverStartAddrLookup(int address);void    sqResolverStartNameLookup(char *hostName, int nameSize);int        sqResolverStatus(void);void    sqSocketAbortConnection(SocketPtr s);void    sqSocketCloseConnection(SocketPtr s);int        sqSocketConnectionStatus(SocketPtr s);void    sqSocketConnectToPort(SocketPtr s, int addr, int port);void    sqSocketCreateNetTypeSocketTypeRecvBytesSendBytesSemaID(            SocketPtr s, int netType, int socketType,            int recvBufSize, int sendBufSize, int semaIndex);void    sqSocketDestroy(SocketPtr s);int        sqSocketError(SocketPtr s);void    sqSocketListenOnPort(SocketPtr s, int port);int        sqSocketLocalAddress(SocketPtr s);int        sqSocketLocalPort(SocketPtr s);int        sqSocketReceiveDataAvailable(SocketPtr s);int        sqSocketReceiveDataBufCount(SocketPtr s, int buf, int bufSize);int        sqSocketRemoteAddress(SocketPtr s);int        sqSocketRemotePort(SocketPtr s);int        sqSocketSendDataBufCount(SocketPtr s, int buf, int bufSize);int        sqSocketSendDone(SocketPtr s);/* profiling */int clearProfile(void);int dumpProfile(void);int startProfiling(void);int stopProfiling(void);/* system attributes */int attributeSize(int id);int getAttributeIntoLength(int id, int byteArrayIndex, int length);'! !!KeyboardBuffer methodsFor: 'all' stamp: 'di 9/30/97 19:53'!commandKeyPressed    ^ event commandKeyPressed! !!KeyboardBuffer methodsFor: 'all' stamp: 'di 9/30/97 19:54'!controlKeyPressed    ^ event controlKeyPressed! !!KeyboardBuffer methodsFor: 'all' stamp: 'di 9/29/97 12:34'!flushKeyboard    eventUsed ifFalse: [^ eventUsed _ true].! !!KeyboardBuffer methodsFor: 'all' stamp: 'di 9/29/97 12:34'!keyboard    eventUsed ifFalse: [eventUsed _ true.  ^ event keyCharacter].    ^ nil! !!KeyboardBuffer methodsFor: 'all' stamp: 'di 9/29/97 12:34'!keyboardPeek    eventUsed ifFalse: [^ event keyCharacter].    ^ nil! !!KeyboardBuffer methodsFor: 'all' stamp: 'di 9/29/97 12:34'!keyboardPressed    ^ eventUsed not! !!KeyboardBuffer methodsFor: 'all' stamp: 'di 9/30/97 19:54'!leftShiftDown    ^ event shiftPressed! !!KeyboardBuffer methodsFor: 'all'!startingEvent: evt    event _ evt.    eventUsed _ false! !LargeNegativeInteger comment:'Just like LargePositiveInteger, but represents a negative number.'!LargePositiveInteger comment:'I represent a positive large integer, integers greater than 2-to-the-30th (1073741824).  These are beyond the range of SmallInteger, encoded as an array of 8-bit digits.  Care must be taken, when new results are computed, that any value that COULD BE a SmallInteger IS a SmallInteger (see normalize).'!!LargePositiveInteger methodsFor: 'arithmetic'!* anInteger     "Primitive. Multiply the receiver by the argument and answer with an    Integer result. Fail if either the argument or the result is not a    SmallInteger or a LargePositiveInteger less than 2-to-the-30th (1073741824). Optional. See    Object documentation whatIsAPrimitive. "    <primitive: 29>    ^super * anInteger! !!LargePositiveInteger methodsFor: 'arithmetic'!+ anInteger     "Primitive. Add the receiver to the argument and answer with an    Integer result. Fail if either the argument or the result is not a    SmallInteger or a LargePositiveInteger less than 2-to-the-30th (1073741824). Optional. See    Object documentation whatIsAPrimitive."    <primitive: 21>    ^super + anInteger! !!LargePositiveInteger methodsFor: 'arithmetic'!- anInteger     "Primitive. Subtract the argument from the receiver and answer with an    Integer result. Fail if either the argument or the result is not a    SmallInteger or a LargePositiveInteger less than 2-to-the-30th (1073741824). Optional. See    Object documentation whatIsAPrimitive."    <primitive: 22>    ^super - anInteger! !!LargePositiveInteger methodsFor: 'arithmetic'!/ anInteger     "Primitive. Divide the receiver by the argument and answer with the    result if the division is exact. Fail if the result is not a whole integer.    Fail if the argument is 0. Fail if either the argument or the result is not    a SmallInteger or a LargePositiveInteger less than 2-to-the-30th (1073741824). Optional. See    Object documentation whatIsAPrimitive. "    <primitive: 30>    ^super / anInteger! !!LargePositiveInteger methodsFor: 'arithmetic'!// anInteger     "Primitive. Divide the receiver by the argument and return the result.    Round the result down towards negative infinity to make it a whole    integer. Fail if the argument is 0. Fail if either the argument or the    result is not a SmallInteger or a LargePositiveInteger less than 2-to-the-30th (1073741824).    Optional. See Object documentation whatIsAPrimitive. "    <primitive: 32>    ^super // anInteger! !!LargePositiveInteger methodsFor: 'arithmetic'!quo: anInteger     "Primitive. Divide the receiver by the argument and return the result.    Round the result down towards zero to make it a whole integer. Fail if    the argument is 0. Fail if either the argument or the result is not a    SmallInteger or a LargePositiveInteger less than 2-to-the-30th (1073741824). Optional. See    Object documentation whatIsAPrimitive."    <primitive: 33>    ^super quo: anInteger! !!LargePositiveInteger methodsFor: 'arithmetic'!\\ anInteger     "Primitive. Take the receiver modulo the argument. The result is the    remainder rounded towards negative infinity, of the receiver divided    by the argument. Fail if the argument is 0. Fail if either the argument    or the result is not a SmallInteger or a LargePositiveInteger less than    2-to-the-30th (1073741824). Optional. See Object documentation whatIsAPrimitive."    <primitive: 31>    ^super \\ anInteger! !!LargePositiveInteger methodsFor: 'comparing'!< anInteger     "Primitive. Compare the receiver with the argument and answer true if    the receiver is less than the argument. Otherwise answer false. Fail if the    argument is not a SmallInteger or a LargePositiveInteger less than 2-to-the-30th (1073741824).    Optional. See Object documentation whatIsAPrimitive."    <primitive: 23>    ^super < anInteger! !!LargePositiveInteger methodsFor: 'comparing'!<= anInteger     "Primitive. Compare the receiver with the argument and answer true if    the receiver is less than or equal to the argument. Otherwise answer false.    Fail if the argument is not a SmallInteger or a LargePositiveInteger less    than 2-to-the-30th (1073741824). Optional. See Object documentation whatIsAPrimitive."    <primitive: 25>    ^super <= anInteger! !!LargePositiveInteger methodsFor: 'comparing'!= anInteger     "Primitive. Compare the receiver with the argument and answer true if    the receiver is equal to the argument. Otherwise answer false. Fail if the    receiver or argument is negative or greater than 32 bits.    Optional. See Object documentation whatIsAPrimitive."    <primitive: 7>    ^ super = anInteger! !!LargePositiveInteger methodsFor: 'comparing'!> anInteger     "Primitive. Compare the receiver with the argument and answer true if    the receiver is greater than the argument. Otherwise answer false. Fail if    the argument is not a SmallInteger or a LargePositiveInteger less than    2-to-the-30th (1073741824). Optional. See Object documentation whatIsAPrimitive."    <primitive: 24>    ^super > anInteger! !!LargePositiveInteger methodsFor: 'comparing'!>= anInteger     "Primitive. Compare the receiver with the argument and answer true if    the receiver is greater than or equal to the argument. Otherwise answer    false. Fail if the argument is not a SmallInteger or a LargePositiveInteger    less than 2-to-the-30th (1073741824). Optional. See Object documentation whatIsAPrimitive."    <primitive: 26>    ^super >= anInteger! !!LayoutMorph methodsFor: 'initialization'!initialize    super initialize.    borderWidth _ 0.    orientation _ #horizontal.    "#horizontal or #vertical"    centering _ #topLeft.        "#topLeft, #center, or #bottomRight"    hResizing _ #spaceFill.        "#spaceFill, #shrinkWrap, or #rigid"    vResizing _ #spaceFill.        "#spaceFill, #shrinkWrap, or #rigid"    inset _ 2.                    "pixels inset within owner's bounds"    minCellSize _ 0.                "minimum space between morphs; useful for tables"    openToDragNDrop _ false.    "objects can be dropped in or dragged out"    layoutNeeded _ true.    color _ Color r: 0.8 g: 1.0 b: 0.8.! !!LayoutMorph methodsFor: 'classification'!isLayoutMorph    ^ true! !!LayoutMorph methodsFor: 'accessing'!centering    ^ centering! !!LayoutMorph methodsFor: 'accessing'!centering: aSymbol    "Set the minor dimension alignment to #topLeft, #center, or #bottomRight."    centering _ aSymbol.! !!LayoutMorph methodsFor: 'accessing'!hResizing    ^ hResizing! !!LayoutMorph methodsFor: 'accessing'!hResizing: aSymbol    "Set the horizontal resizing style to #spaceFill, #shrinkWrap, or #rigid."    hResizing _ aSymbol.! !!LayoutMorph methodsFor: 'accessing'!inset    ^ inset! !!LayoutMorph methodsFor: 'accessing'!inset: anInteger    "Set the amount of padding within my bounds to the given amount."    inset _ anInteger.! !!LayoutMorph methodsFor: 'accessing'!minCellSize    ^ minCellSize! !!LayoutMorph methodsFor: 'accessing'!minCellSize: anInteger    "Set the minium space per submorph to the given size. Useful for making tables."    minCellSize _ anInteger.! !!LayoutMorph methodsFor: 'accessing'!openCloseDragNDrop    "Toggle this morph's ability to add and remove morphs via drag-n-drop."    openToDragNDrop _ openToDragNDrop not.! !!LayoutMorph methodsFor: 'accessing'!openToDragNDrop    ^ openToDragNDrop! !!LayoutMorph methodsFor: 'accessing'!openToDragNDrop: aBoolean    "Set this morph's ability to add and remove morphs via drag-n-drop."    openToDragNDrop _ aBoolean.! !!LayoutMorph methodsFor: 'accessing'!orientation    ^ orientation! !!LayoutMorph methodsFor: 'accessing'!orientation: aSymbol    "Set the major layout dimension to #horizontal or #vertical."    orientation _ aSymbol.! !!LayoutMorph methodsFor: 'accessing'!vResizing    ^ vResizing! !!LayoutMorph methodsFor: 'accessing'!vResizing: aSymbol    "Set the vertical resizing style to #spaceFill, #shrinkWrap, or #rigid."    vResizing _ aSymbol.! !!LayoutMorph methodsFor: 'geometry'!layoutChanged    super layoutChanged.    layoutNeeded _ true.! !!LayoutMorph methodsFor: 'dropping/grabbing'!acceptDroppingMorph: aMorph event: evt    "Allow the user to add submorphs just by dropping them on this morph."    self privateAddMorph: aMorph atIndex: (self insertionIndexFor: aMorph).    self changed.    self layoutChanged.! !!LayoutMorph methodsFor: 'dropping/grabbing'!allowSubmorphExtraction    ^ openToDragNDrop! !!LayoutMorph methodsFor: 'dropping/grabbing'!rootForGrabOf: aMorph    | root |    openToDragNDrop ifFalse: [^ super rootForGrabOf: aMorph].    root _ aMorph.    [root = self] whileFalse: [        root owner = self ifTrue: [^ root].        root _ root owner].    ^ super rootForGrabOf: aMorph! !!LayoutMorph methodsFor: 'dropping/grabbing'!wantsDroppedMorph: aMorph event: evt    "Supports adding morphs by dropping."    ^ openToDragNDrop! !!LayoutMorph methodsFor: 'layout'!fullBounds    "This is the hook that triggers lazy re-layout of layout morphs. It works because layoutChanged clears the fullBounds cache. Once per cycle, the fullBounds is requested from every morph in the world, and that request gets propagated through the entire submorph hierarchy, causing re-layout where needed. Note that multiple layoutChanges to the same morph can be done with little cost, since the layout is only done when the morph needs to be displayed."    fullBounds ifNil: [        layoutNeeded ifTrue: [            self resizeIfNeeded.            self fixLayout.            "compute fullBounds before calling changed to avoid infinite recursion"            super fullBounds.  "updates cache"            self changed.  "report change due to layout"            layoutNeeded _ false]].    ^ super fullBounds! !!LayoutMorph methodsFor: 'layout'!minHeight    "Return the minimum height for this morph."    | minH spaceNeeded |    vResizing = #rigid ifTrue: [^ self fullBounds height].    submorphs isEmpty ifTrue: [^ self minHeightWhenEmpty].    orientation = #horizontal ifTrue: [        minH _ 0.        submorphs do: [:m | minH _ minH max: m minHeight].        spaceNeeded _ minH + (2 * (inset + borderWidth)).    ] ifFalse: [        spaceNeeded _ 2 * (inset + borderWidth).        submorphs do: [:m | spaceNeeded _ spaceNeeded + (m minHeight max: minCellSize)]].    ^ spaceNeeded! !!LayoutMorph methodsFor: 'layout'!minHeightWhenEmpty    ^ 5! !!LayoutMorph methodsFor: 'layout'!minWidth    "Return the minimum width for this morph."    | spaceNeeded minW |    hResizing = #rigid ifTrue: [^ self fullBounds width].    submorphs isEmpty ifTrue: [^ self minWidthWhenEmpty].    orientation = #horizontal ifTrue: [        spaceNeeded _ 2 * (inset + borderWidth).        submorphs do: [:m | spaceNeeded _ spaceNeeded + (m minWidth max: minCellSize)].    ] ifFalse: [        minW _ 0.        submorphs do: [:m | minW _ minW max: m minWidth].        spaceNeeded _ minW + (2 * (inset + borderWidth))].    ^ spaceNeeded! !!LayoutMorph methodsFor: 'layout'!minWidthWhenEmpty    ^ 5! !!LayoutMorph methodsFor: 'menu'!addCustomMenuItems: aCustomMenu hand: aHandMorph    super addCustomMenuItems: aCustomMenu hand: aHandMorph.    aCustomMenu add: (openToDragNDrop ifTrue: ['close'] ifFalse: ['open']) , ' dragNdrop'            action: #openCloseDragNDrop.! !!LayoutMorph methodsFor: 'private'!extraSpacePerMorph    | spaceFillingMorphs spaceNeeded extra |    spaceFillingMorphs _ 0.    spaceNeeded _ 2 * (inset + borderWidth).    orientation = #horizontal ifTrue: [        submorphs do: [:m |            spaceNeeded _ spaceNeeded + (m minWidth max: minCellSize).            (m isLayoutMorph and: [m hResizing = #spaceFill])                ifTrue: [spaceFillingMorphs _ spaceFillingMorphs + 1]].        extra _ (bounds width - spaceNeeded) max: 0.    ] ifFalse: [        submorphs do: [:m |            spaceNeeded _ spaceNeeded + (m minHeight max: minCellSize).            (m isLayoutMorph and: [m vResizing = #spaceFill])                ifTrue: [spaceFillingMorphs _ spaceFillingMorphs + 1]].        extra _ (bounds height - spaceNeeded) max: 0].    (submorphs size <= 1 or: [spaceFillingMorphs <= 1]) ifTrue: [^ extra].    ^ extra // spaceFillingMorphs! !!LayoutMorph methodsFor: 'private'!fixLayout    | extraPerMorph nextPlace space |    extraPerMorph _ self extraSpacePerMorph.    orientation = #horizontal        ifTrue: [nextPlace _ bounds left + inset + borderWidth]        ifFalse: [nextPlace _ bounds top + inset + borderWidth].    submorphs do: [:m |        space _ self placeAndSize: m at: nextPlace padding: extraPerMorph.        nextPlace _ nextPlace + space].! !!LayoutMorph methodsFor: 'private'!insertionIndexFor: aMorph    "Return the index at which the given morph should be inserted into the submorphs of the receiver."    | newCenter |    newCenter _ aMorph fullBounds center.    orientation = #horizontal ifTrue: [        submorphs doWithIndex: [:m :i |            newCenter x < m fullBounds center x ifTrue: [^ i]].    ] ifFalse: [        submorphs doWithIndex: [:m :i |            newCenter y < m fullBounds center y ifTrue: [^ i]]].    ^ submorphs size + 1  "insert after the last submorph"! !!LayoutMorph methodsFor: 'private'!layoutInWidth: w height: h    "Adjust the size of the receiver in its space-filling dimensions during layout. This message is sent to only to layout submorphs."    ((hResizing = #spaceFill) and: [bounds width ~= w]) ifTrue: [        bounds _ bounds origin extent: (w @ bounds height).        fullBounds _ nil.        layoutNeeded _ true].    ((vResizing = #spaceFill) and: [bounds height ~= h]) ifTrue: [        bounds _ bounds origin extent: (bounds width @ h).        fullBounds _ nil.        layoutNeeded _ true].! !!LayoutMorph methodsFor: 'private'!placeAndSize: m at: nextPlace padding: padding    | space totalInset fullBnds left top |    totalInset _ inset + borderWidth.    orientation = #horizontal ifTrue: [        space _ m minWidth max: minCellSize.        m isLayoutMorph ifTrue: [            (m hResizing = #spaceFill) ifTrue: [space _ space + padding].            m layoutInWidth: space height: (bounds height - (2 * totalInset))].    ] ifFalse: [        space _ m minHeight max: minCellSize.        m isLayoutMorph ifTrue: [            (m vResizing = #spaceFill) ifTrue: [space _ space + padding].            m layoutInWidth: (bounds width - (2 * totalInset)) height: space]].    fullBnds _ m fullBounds.    orientation = #horizontal ifTrue: [        left _ nextPlace.        centering = #topLeft            ifTrue: [top _ bounds top + totalInset].        centering = #bottomRight            ifTrue: [top _ bounds bottom - totalInset - fullBnds height].        centering = #center            ifTrue: [top _ bounds top + ((bounds height - fullBnds height) // 2)].    ] ifFalse: [        top _ nextPlace.        centering = #topLeft            ifTrue: [left _ bounds left + totalInset].        centering = #bottomRight            ifTrue: [left _ bounds right - totalInset - fullBnds width].        centering = #center            ifTrue: [left _ bounds left + ((bounds width - fullBnds width) // 2)]].    m position: (left + (m bounds left - fullBnds left)) @ (top + (m bounds top - fullBnds top)).    ^ space! !!LayoutMorph methodsFor: 'private'!resizeIfNeeded    "Resize this morph if it is space-filling or shrink-wrap and its owner is not a layout morph."    | newWidth newHeight |    newWidth _ bounds width.    newHeight _ bounds height.    (owner == nil or: [owner isLayoutMorph not]) ifTrue: [        "if spaceFill and not in a LayoutMorph, grow to enclose submorphs"        hResizing = #spaceFill ifTrue: [newWidth _ self minWidth max: self bounds width].        vResizing = #spaceFill ifTrue: [newHeight _ self minHeight max: self bounds height]].    "if shrinkWrap, adjust size to just fit around submorphs"    hResizing = #shrinkWrap ifTrue: [newWidth _ self minWidth].    vResizing = #shrinkWrap ifTrue: [newHeight _ self minHeight].    ((newWidth ~= bounds width) or: [newHeight ~= bounds height]) ifTrue: [        "bounds really changed; flush fullBounds cache and fix submorph layouts"        bounds _ bounds origin extent: newWidth@newHeight.        fullBounds _ nil].! !!LayoutMorph class methodsFor: 'instance creation'!newColumn    ^ self new        orientation: #vertical;        hResizing: #spaceFill;        vResizing: #spaceFill! !!LayoutMorph class methodsFor: 'instance creation'!newRow    ^ self new        orientation: #horizontal;        hResizing: #spaceFill;        vResizing: #spaceFill;        borderWidth: 0! !!LayoutMorph class methodsFor: 'instance creation'!newRowHeight: h    ^ self new        orientation: #horizontal;        hResizing: #spaceFill;        vResizing: #rigid;        extent: (3*h)@h! !LeafNode comment:'I represent a leaf node of the compiler parse tree. I am abstract.    Types (defined in class ParseNode):    1 LdInstType (which uses class VariableNode)    2 LdTempType (which uses class VariableNode)    3 LdLitType (which uses class LiteralNode)    4 LdLitIndType (which uses class VariableNode)    5 SendType (which uses class SelectorNode).Note that Squeak departs slightly from the Blue Book bytecode spec.In order to allow access to more than 63 literals and instance variables,bytecode 132 has been redefined as DoubleExtendedDoAnything:        byte2                byte3            Operation(hi 3 bits)  (lo 5 bits)    0        nargs            lit index            Send Literal Message 0-255    1        nargs            lit index            Super-Send Lit Msg 0-255    2        ignored            rcvr index        Push Receiver Variable 0-255    3        ignored            lit index            Push Literal Constant 0-255    4        ignored            lit index            Push Literal Variable 0-255    5        ignored            rcvr index        Store Receiver Variable 0-255    6        ignored            rcvr index        Store-pop Receiver Variable 0-255    7        ignored            lit index            Store Literal Variable 0-255    This has allowed bytecode 134 also to be redefined as a second extended send    that can access literals up to 64 for nargs up to 3 without needing three bytes.    It is just like 131, except that the extension byte is aallllll instead of aaalllll,    where aaa are bits of argument count, and lll are bits of literal index.'!!LeafNode methodsFor: 'code generation'!emitLong: mode on: aStream     "Emit extended variable access."    | type index |    code < 256        ifTrue:            [code < 16            ifTrue: [type _ 0.                    index _ code]            ifFalse: [code < 32                    ifTrue: [type _ 1.                            index _ code - 16]                    ifFalse: [code < 96                            ifTrue: [type _ code // 32 + 1.                                    index _ code \\ 32]                            ifFalse: [self error:                                     'Sends should be handled in SelectorNode']]]]        ifFalse:             [index _ code \\ 256.            type _ code // 256 - 1].    index <= 63 ifTrue:        [aStream nextPut: mode.        ^ aStream nextPut: type * 64 + index].    "Compile for Double-exetended Do-anything instruction..."    mode = LoadLong ifTrue:        [aStream nextPut: DblExtDoAll.        aStream nextPut: (#(64 0 96 128) at: type+1).  "Cant be temp (type=1)"        ^ aStream nextPut: index].    mode = Store ifTrue:        [aStream nextPut: DblExtDoAll.        aStream nextPut: (#(160 0 0 224) at: type+1).  "Cant be temp or const (type=1 or 2)"        ^ aStream nextPut: index].    mode = StorePop ifTrue:        [aStream nextPut: DblExtDoAll.        aStream nextPut: (#(192 0 0 0) at: type+1).  "Can only be inst"        ^ aStream nextPut: index].! !!LeafNode methodsFor: 'code generation'!sizeForValue: encoder    self reserve: encoder.    code < 256 ifTrue: [^ 1].    (code \\ 256) <= 63 ifTrue: [^ 2].    ^ 3! !!LimitedWriteStream methodsFor: 'all' stamp: 'di 6/20/97 08:55'!pastEndPut: anObject    collection size >= limit ifTrue: [limitBlock value].  "Exceptional return"    collection _ collection ,        (collection class new: ((collection size max: 20) min: limit)).    writeLimit _ collection size.    collection at: (position _ position + 1) put: anObject! !!LimitedWriteStream methodsFor: 'all' stamp: 'di 6/20/97 09:07'!setLimit: sizeLimit limitBlock: aBlock    "Limit the numer of elements this stream will write..."    limit _ sizeLimit.    "Execute this (typically ^ contents) when that limit is exceded"    limitBlock _ aBlock! !!ListController methodsFor: 'marker adjustment'!computeMarkerRegion     "Refer to the comment in ScrollController|computeMarkerRegion."    | viewList |    viewList _ view list.    viewList compositionRectangle height = 0        ifTrue: [^ 0@0 extent: Preferences scrollBarWidth@scrollBar inside height].    ^ 0@0 extent: Preferences scrollBarWidth@            ((viewList clippingRectangle height asFloat /                        viewList compositionRectangle height *                            scrollBar inside height)                    rounded min: scrollBar inside height)! !!ListPane methodsFor: 'initialization'!extent: newExtent    super extent: newExtent.    self setScrollDeltas ! !!ListPane methodsFor: 'initialization' stamp: '6/11/97 09:05 di'!list: listOfStrings    | morphList handler h loc |    scroller removeAllMorphs.    scrollBar setValue: 0.0.    listOfStrings isEmpty ifTrue: [^ self setSelectedMorph: nil].    "NOTE: we will want a quick StringMorph init message, possibly even        combined with event install and positioning"    morphList _ listOfStrings collect: [:item | StringMorph contents: item].    "Sensitize first morph and copy handler to all the rest"    morphList first on: #mouseDown send: #mouseDown:onItem: to: self.    handler _ morphList first eventHandler.    morphList do: [:m | m eventHandler: handler].    "Lay items out vertically and install them in the scroller"    h _ morphList first height "self listItemHeight".    loc _ 0@0.    morphList do: [:m | m bounds: (loc extent: 9999@h).  loc _ loc + (0@h)].    scroller addAllMorphs: morphList.    self setSelectedMorph: nil.    self setScrollDeltas! !!ListPane methodsFor: 'initialization'!setScrollDeltas    | range |    scroller hasSubmorphs ifFalse: [^ self].    range _ self totalScrollRange.    range = 0 ifTrue: [^ scrollBar scrollDelta: 0.02 pageDelta: 0.2].    scrollBar scrollDelta: (scroller firstSubmorph height / range) asFloat             pageDelta: (self innerBounds height / range) asFloat ! !!ListPane methodsFor: 'drawing'!drawOn: aCanvas    super drawOn: aCanvas.    selectedMorph ifNotNil:        [aCanvas fillRectangle:            (((scroller transformFrom: self) invertRect: selectedMorph bounds)                        intersect: scroller bounds)                color: color darker]! !!ListPane methodsFor: 'drawing'!highlightSelection    selectedMorph ifNotNil: [selectedMorph color: Color red]! !!ListPane methodsFor: 'drawing'!unhighlightSelection    selectedMorph ifNotNil: [selectedMorph color: Color black]! !!ListPane methodsFor: 'events'!mouseDown: event onItem: aMorph    self setSelectedMorph: (aMorph == selectedMorph ifTrue: [nil] ifFalse: [aMorph])! !!ListPane methodsFor: 'selection'!selectedMorph: aMorph    self unhighlightSelection.    selectedMorph _ aMorph.    selection _ aMorph ifNil: [nil] ifNotNil: [aMorph contents].    self highlightSelection! !!ListPane methodsFor: 'selection'!selection     ^ selection! !!ListPane methodsFor: 'selection'!selection: item    "Called from outside to request setting a new selection.    Assumes scroller submorphs is exactly our list"    | index theMorph |    index _ scroller submorphs findFirst: [:m | m contents = item].    index = 0 ifTrue: [^ self selectedMorph: nil].    theMorph _ scroller submorphs at: index.        "Scroll into view -- should be elsewhere"        scrollBar value: (((index-1 * theMorph height) / self totalScrollRange)                                truncateTo: scrollBar scrollDelta).        scroller offset: -3 @ (self totalScrollRange * scrollBar value).    self selectedMorph: theMorph! !!ListPane methodsFor: 'selection'!setSelectedMorph: aMorph    self selectedMorph: aMorph.    self use: hitSelector orMakeModelSelectorFor: 'NewSelection:'        in: [:sel | hitSelector _ sel.  model perform: sel with: selection]! !!ListParagraph methodsFor: 'private' stamp: 'di 7/13/97 16:56'!withArray: anArray     "Modifies self to contain the list of strings in anArray"    | startOfLine endOfLine lineIndex aString |    lines _ Array new: 20.    lastLine _ 0.    startOfLine _ 1.    endOfLine _ 1.    lineIndex _ 0.    anArray do:         [:item |         endOfLine _ startOfLine + item size.        "this computation allows for a cr after each line..."                                                "...but later we will adjust for no cr after last line"        lineIndex _ lineIndex + 1.        self lineAt: lineIndex put:            ((TextLineInterval start: startOfLine stop: endOfLine                internalSpaces: 0 paddingWidth: 0)                lineHeight: textStyle lineGrid baseline: textStyle baseline).        startOfLine _ endOfLine + 1].    endOfLine _ endOfLine - 1.        "endOfLine is now the total size of the text"    self trimLinesTo: lineIndex.    aString _ String new: endOfLine.    anArray with: lines do:         [:item :interval |         aString            replaceFrom: interval first            to: interval last - 1            with: item asString            startingAt: 1.        interval last <= endOfLine ifTrue: [aString at: interval last put: Character cr]].    lineIndex > 0 ifTrue: [(lines at: lineIndex) stop: endOfLine].    "adjust for no cr after last line"    self text: aString asText.    anArray with: lines do:         [:item :interval |  item isText ifTrue:            [text replaceFrom: interval first to: interval last - 1 with: item]].    self updateCompositionHeight! !!ListParagraph class methodsFor: 'instance creation'!withArray: anArray    "Convert an array of strings into a ListParagraph."    ^ (super withText: Text new style: ListStyle) withArray: anArray! !!ListParagraph class methodsFor: 'initialization'!initialize  "ListParagraph initialize"    "Allow different line spacing for lists"    ListStyle _ TextStyle default copy gridForFont: 1 withLead: 1! !!ListView methodsFor: 'initialize-release'!initialize     "Refer to the comment in View|initialize."    super initialize.    topDelimiter _ '------------'.    bottomDelimiter _ '------------'.    isEmpty _ true.    self list: Array new! !!ListView methodsFor: 'list access'!list: anArray     "Set the list of items the receiver displays to be anArray."    | arrayCopy i |    isEmpty _ anArray isEmpty.    arrayCopy _ Array new: (anArray size + 2).    arrayCopy at: 1 put: topDelimiter.    arrayCopy at: arrayCopy size put: bottomDelimiter.    i _ 2.    anArray do: [:el | arrayCopy at: i put: el. i _ i+1].    arrayCopy _ arrayCopy copyWithout: nil.    list _ ListParagraph withArray: arrayCopy.    selection _ 0.    self positionList! !!ListView methodsFor: 'displaying'!scrollSelectionIntoView    "Selection is assumed to be on and clipped out of view.    Uses controller scrollView to keep selection right"    | delta |    (delta _ self insetDisplayBox bottom - self selectionBox bottom) < 0        ifTrue: [^ self controller scrollView: delta - (list lineGrid-1)]. "up"    (delta _ self insetDisplayBox top - self selectionBox top) > 0        ifTrue: [^ self controller scrollView: delta + 1] "down"! !!LiteralDictionary methodsFor: 'as yet unclassified'!scanFor: anObject    "Scan the key array for the first slot containing either a nil (indicating an empty slot) or an element that matches anObject. Answer the index of that slot or zero if no slot is found. This method will be overridden in various subclasses that have different interpretations for matching elements."    | element start finish |    start _ (anObject hash \\ array size) + 1.    finish _ array size.    "Search from (hash mod size) to the end."    start to: finish do:        [:index | ((element _ array at: index) == nil                    or: [(element key class == anObject class) and: [element key = anObject]])                    ifTrue: [^ index ]].    "Search from 1 to where we started."    1 to: start-1 do:        [:index | ((element _ array at: index) == nil                    or: [(element key class == anObject class) and: [element key = anObject]])                    ifTrue: [^ index ]].    ^ 0  "No match AND no empty slot"! !!LiteralNode methodsFor: 'code generation'!emitForValue: stack on: strm    code < 256        ifTrue: [strm nextPut: code]        ifFalse: [self emitLong: LoadLong on: strm].    stack push: 1! !!LiteralNode methodsFor: 'C translation'!asTranslatorNode     ^TConstantNode new setValue: key! !!LookupKey methodsFor: 'comparing' stamp: 'di 9/27/97 20:45'!identityHashMappedBy: map    "Answer what my hash would be if oops changed according to map."    ^ key identityHashMappedBy: map! !!MenuItemMorph methodsFor: 'initialization' stamp: 'jm 9/29/97 11:01'!initialize    super initialize.    bounds _ 0@0 extent: 10@10.    color _ Color black.    font _ nil.    contents _ ''.    hasFocus _ false.    isEnabled _ true.    subMenu _ nil.    isSelected _ false.    target _ nil.    selector _ nil.    arguments _ nil.! !!MenuItemMorph methodsFor: 'accessing' stamp: 'jm 9/28/97 13:07'!arguments    ^ arguments! !!MenuItemMorph methodsFor: 'accessing' stamp: 'jm 9/28/97 13:08'!arguments: aCollection    arguments _ aCollection.! !!MenuItemMorph methodsFor: 'accessing' stamp: 'jm 9/28/97 12:40'!isEnabled    ^ isEnabled! !!MenuItemMorph methodsFor: 'accessing' stamp: 'jm 9/28/97 12:40'!isEnabled: aBoolean    isEnabled = aBoolean ifTrue: [^ self].    isEnabled _ aBoolean.    self color: (aBoolean ifTrue: [Color black] ifFalse: [Color gray]).! !!MenuItemMorph methodsFor: 'accessing' stamp: 'jm 9/28/97 12:51'!selector    ^ selector! !!MenuItemMorph methodsFor: 'accessing' stamp: 'jm 9/28/97 12:51'!selector: aSymbol    selector _ aSymbol.! !!MenuItemMorph methodsFor: 'accessing' stamp: 'jm 9/28/97 12:24'!subMenu    ^ subMenu! !!MenuItemMorph methodsFor: 'accessing' stamp: 'jm 9/28/97 12:24'!subMenu: aMenuMorph    subMenu _ aMenuMorph.    self changed.! !!MenuItemMorph methodsFor: 'accessing' stamp: 'jm 9/28/97 13:18'!target    ^ target! !!MenuItemMorph methodsFor: 'accessing' stamp: 'jm 9/28/97 13:18'!target: anObject    target _ anObject.! !!MenuItemMorph methodsFor: 'drawing' stamp: 'jm 9/29/97 11:01'!drawOn: aCanvas    (isSelected & isEnabled) ifTrue: [        aCanvas fillRectangle: self bounds color: owner color darker].    super drawOn: aCanvas.    subMenu == nil ifFalse: [        aCanvas            image: SubMenuMarker            at: (self right - 8 @ ((self top + self bottom - SubMenuMarker height) // 2))].! !!MenuItemMorph methodsFor: 'events' stamp: 'jm 9/24/97 14:24'!handlesMouseDown: evt    ^ true! !!MenuItemMorph methodsFor: 'events' stamp: 'jm 9/29/97 15:10'!mouseDown: evt    "Handle a mouse down event. Menu items get activated when the mouse is over them."    self isInMenu ifFalse: [^ super mouseDown: evt].    evt shiftPressed ifTrue: [^ super mouseDown: evt].  "enable label editing"     self selectFromHand: evt hand.! !!MenuItemMorph methodsFor: 'events' stamp: 'jm 9/29/97 17:36'!mouseMove: evt    | m |    m _ evt hand recipientForMouseDown: evt.    m == self        ifTrue: [isSelected ifFalse: [self isSelected: true]]        ifFalse: [            self deselectForNewMorph: m.            ((m isKindOf: MenuItemMorph) and: [m isInMenu]) ifTrue: [                m selectFromHand: evt hand]]."xxx    m == self ifFalse: [        ((m isKindOf: MenuItemMorph) and: [m isInMenu]) ifTrue: [            m owner == subMenu                ifFalse: [self isSelected: false hand: evt hand].            m isSelected: true hand: evt hand.            evt hand newMouseFocus: m]].xxx""xxx    m == self ifTrue: [^ self].    ((m isKindOf: MenuItemMorph) and: [m isInMenu]) ifTrue: [        m isSelected: true hand: evt hand.        menu _ m owner.        (menu == self owner or: [         menu == subMenu or: [         menu hasSubMenu: owner]]) ifTrue: [            menu == subMenu ifFalse: [self hideSubmenu].            (menu == self owner or: [m subMenu == owner or: [menu == subMenu]])                ifFalse: [owner delete].            evt hand newMouseFocus: m]].xxx"! !!MenuItemMorph methodsFor: 'events' stamp: 'jm 9/29/97 13:06'!mouseUp: evt    "Handle a mouse up event. Menu items get activated when the mouse is over them."    | mouseInMe w |    self deselectItem.    mouseInMe _ self bounds containsPoint: evt cursorPoint.    self isInMenu ifTrue: [        (mouseInMe and: [self selector = #toggleStayUp:]) ifFalse: [            w _ owner world.            owner deleteIfPopUp].        subMenu ifNil: [            mouseInMe ifTrue: [                w ifNotNil: [w displayWorld].                owner invokeItem: self]]].! !!MenuItemMorph methodsFor: 'layout' stamp: 'jm 9/28/97 12:34'!hResizing    ^ #spaceFill! !!MenuItemMorph methodsFor: 'layout' stamp: 'jm 9/28/97 12:34'!isLayoutMorph    ^ true! !!MenuItemMorph methodsFor: 'layout' stamp: 'jm 9/28/97 12:34'!layoutInWidth: w height: h    | scanner |    scanner _ QuickPrint newOn: Display box: Display boundingBox font: font.    self extent: ((scanner stringWidth: contents) @ (scanner lineHeight) max: w@h).! !!MenuItemMorph methodsFor: 'layout' stamp: 'jm 9/28/97 12:35'!minHeight    ^ self extent y! !!MenuItemMorph methodsFor: 'layout' stamp: 'jm 9/28/97 12:35'!minWidth    | scanner |    scanner _ QuickPrint newOn: Display box: Display boundingBox font: font.    ^ (scanner stringWidth: contents) + (subMenu == nil ifTrue: [0] ifFalse: [10])! !!MenuItemMorph methodsFor: 'layout' stamp: 'jm 9/28/97 12:35'!vResizing    ^ #shrinkWrap! !!MenuItemMorph methodsFor: 'private' stamp: 'jm 9/29/97 18:27'!deletePopupBackToCommonMenuWith: menuOrMenuItem    | m menuToKeepUp owningItem |    (menuOrMenuItem isKindOf: MenuMorph)        ifTrue: [m _ menuOrMenuItem]        ifFalse: [            (menuOrMenuItem isKindOf: MenuItemMorph)                ifTrue: [m _ menuOrMenuItem owner]                ifFalse: [^ self]].    menuToKeepUp _ IdentitySet new.    [m isKindOf: MenuMorph] whileTrue: [        menuToKeepUp add: m.        owningItem _ m popUpOwner.        (owningItem isKindOf: MenuItemMorph)            ifTrue: [m _ owningItem owner]            ifFalse: [m _ nil]].    m _ self owner.    [m isKindOf: MenuMorph] whileTrue: [        (menuToKeepUp includes: m) ifTrue: [^ self].        m stayUp ifFalse: [m delete].        (m popUpOwner isKindOf: MenuItemMorph) ifTrue: [m popUpOwner isSelected: false].        owningItem _ m popUpOwner.        (owningItem isKindOf: MenuItemMorph)            ifTrue: [m _ owningItem owner]            ifFalse: [m _ nil]].! !!MenuItemMorph methodsFor: 'private' stamp: 'jm 9/29/97 18:11'!deselectForNewMorph: aMorph    aMorph == owner ifTrue: [^ self].   "in my menu but not over any item"    (aMorph == subMenu or: [aMorph owner == subMenu])        ifTrue: [^ self].  "selecting my submenu or an item in it, leave me selected"    isSelected _ false.    self changed.    subMenu ifNotNil: [subMenu stayUp ifFalse: [subMenu delete]].    self deletePopupBackToCommonMenuWith: aMorph.    aMorph owner ~= self owner ifFalse: [        self deletePopupBackToCommonMenuWith: aMorph].! !!MenuItemMorph methodsFor: 'private' stamp: 'jm 9/29/97 15:48'!deselectItem    | item |    isSelected _ false.    self changed.    subMenu ifNotNil: [subMenu deleteIfPopUp].    (owner isKindOf: MenuMorph) ifTrue: [        item _ owner popUpOwner.        (item isKindOf: MenuItemMorph) ifTrue: [item deselectItem]].! !!MenuItemMorph methodsFor: 'private' stamp: 'jm 9/29/97 12:04'!hideSubmenu    subMenu ifNotNil: [subMenu deleteIfPopUp].    (owner isKindOf: MenuMorph) ifTrue: [owner deleteIfPopUp].! !!MenuItemMorph methodsFor: 'private' stamp: 'jm 9/28/97 12:35'!isInMenu    ^ owner isKindOf: MenuMorph! !!MenuItemMorph methodsFor: 'private' stamp: 'jm 9/29/97 13:30'!isSelected: aBoolean    isSelected _ aBoolean.    self changed.! !!MenuItemMorph methodsFor: 'private' stamp: 'jm 9/29/97 18:32'!selectFromHand: aHand    isSelected _ true.    self changed.    aHand newMouseFocus: self.    subMenu ifNotNil: [        subMenu delete.        subMenu popUpAt: self bounds topRight forHand2: aHand.        subMenu popUpOwner: self].! !!MenuItemMorph class methodsFor: 'class initialization' stamp: 'jm 9/29/97 16:42'!initialize    "MenuItemMorph initialize"    | f |    f _ Form        extent: 5@9        fromArray: #(2147483648 3221225472 3758096384 4026531840 4160749568 4026531840 3758096384 3221225472 2147483648)        offset: 0@0.    SubMenuMarker _ ColorForm transparentFrom: f.! !!MenuLineMorph methodsFor: 'drawing' stamp: 'jm 9/28/97 12:36'!drawOn: aCanvas    aCanvas        fillRectangle: (bounds topLeft corner: bounds rightCenter)        color: owner color darker.    aCanvas        fillRectangle: (bounds leftCenter corner: bounds bottomRight)        color: owner color lighter.! !!MenuLineMorph methodsFor: 'layout' stamp: 'jm 9/28/97 12:36'!hResizing    ^ #spaceFill! !!MenuLineMorph methodsFor: 'layout' stamp: 'jm 9/28/97 12:37'!isLayoutMorph    ^ true! !!MenuLineMorph methodsFor: 'layout' stamp: 'jm 9/28/97 12:37'!layoutInWidth: w height: h    self extent: w@h.! !!MenuLineMorph methodsFor: 'layout' stamp: 'jm 9/28/97 12:37'!minHeight    ^ 2! !!MenuLineMorph methodsFor: 'layout' stamp: 'jm 9/28/97 12:37'!minWidth    ^ 10! !!MenuLineMorph methodsFor: 'layout' stamp: 'jm 9/28/97 12:37'!vResizing    ^ #shrinkWrap! !!MenuMorph methodsFor: 'initialization' stamp: 'jm 9/29/97 07:15'!initialize    super initialize.    self setColor: (Color r: 0.8 g: 0.8 b: 0.8) borderWidth: 2 borderColor: #raised.    inset _ 3.    orientation _ #vertical.    hResizing _ #shrinkWrap.    vResizing _ #shrinkWrap.    defaultTarget _ nil.    lastSelection _ nil.    stayUp _ false.    originalEvent _ nil.    popUpOwner _ nil.! !!MenuMorph methodsFor: 'accessing' stamp: 'jm 9/28/97 13:41'!hasSubMenu: aMenuMorph    | sub |    self items do: [:each |        sub _ each subMenu.        sub ifNotNil: [            sub == aMenuMorph ifTrue: [^ true].            (sub hasSubMenu: aMenuMorph) ifTrue: [^ true]]].    ^ false! !!MenuMorph methodsFor: 'accessing' stamp: 'jm 9/28/97 13:02'!items    ^ submorphs select: [:m | m isKindOf: MenuItemMorph]! !!MenuMorph methodsFor: 'accessing' stamp: 'jm 9/28/97 17:35'!lastSelection    "Return the label of the last selected item or nil."    lastSelection == nil        ifTrue: [^ lastSelection selector]        ifFalse: [^ nil].! !!MenuMorph methodsFor: 'accessing' stamp: 'jm 9/29/97 07:17'!lastSelection: aString    "Set the last selection so that it is selected by default when this menu first pops up."    lastSelection _ self items        detect: [:each | each selector == aString] ifNone: [nil].! !!MenuMorph methodsFor: 'accessing' stamp: 'jm 9/28/97 13:42'!popUpOwner    ^ popUpOwner! !!MenuMorph methodsFor: 'accessing' stamp: 'jm 9/28/97 13:42'!popUpOwner: aMenuItemMorph    popUpOwner _ aMenuItemMorph.! !!MenuMorph methodsFor: 'accessing' stamp: 'jm 9/29/97 07:21'!stayUp    ^ stayUp! !!MenuMorph methodsFor: 'accessing' stamp: 'jm 9/29/97 07:21'!stayUp: aBoolean    stayUp _ aBoolean.! !!MenuMorph methodsFor: 'construction' stamp: 'jm 9/28/97 17:28'!add: aString action: aSymbol    "Append a menu item with the given label. If the item is selected, it will send the given selector to the default target object."    "Details: Note that the menu item added captures the default target object at the time the item is added; the default target can later be changed before added additional items without affecting the targets of previously added entries. The model is that each entry is like a button that knows everything it needs to perform its action."    self add: aString        target: defaultTarget        selector: aSymbol        argumentList: EmptyArray.! !!MenuMorph methodsFor: 'construction' stamp: 'jm 9/28/97 14:04'!add: aString subMenu: aMenuMorph    "Append the given submenu with the given label."    | item |    item _ MenuItemMorph new.    item contents: aString;        subMenu: aMenuMorph.    self addMorphBack: item.! !!MenuMorph methodsFor: 'construction' stamp: 'jm 9/28/97 17:24'!add: aString target: anObject selector: aSymbol    "Append a menu item with the given label. If the item is selected, it will send the given selector to the target object."    self add: aString        target: anObject        selector: aSymbol        argumentList: EmptyArray.! !!MenuMorph methodsFor: 'construction' stamp: 'jm 9/28/97 14:05'!add: aString target: target selector: aSymbol argument: arg    "Append a menu item with the given label. If the item is selected, it will send the given selector to the target object with the given argument."    self add: aString        target: target        selector: aSymbol        argumentList: (Array with: arg)! !!MenuMorph methodsFor: 'construction' stamp: 'jm 9/28/97 14:05'!add: aString target: target selector: aSymbol argumentList: argList    "Append a menu item with the given label. If the item is selected, it will send the given selector to the target object with the given arguments. If the selector takes one more argument than the number of arguments in the given list, then the triggering event is supplied as as the last argument."    | item |    item _ MenuItemMorph new        contents: aString;        target: target;        selector: aSymbol;        arguments: argList asArray.    self addMorphBack: item.! !!MenuMorph methodsFor: 'construction' stamp: 'jm 9/29/97 08:01'!addLine    "Append a divider line to this menu. Suppress duplicate lines."    (self lastSubmorph isKindOf: MenuLineMorph)        ifFalse: [self addMorphBack: MenuLineMorph new].! !!MenuMorph methodsFor: 'construction'!addStayUpItem    "Append a menu item that can be used to toggle this menu's persistent."    self add: 'stay up'        target: self        selector: #toggleStayUp:        argumentList: EmptyArray.! !!MenuMorph methodsFor: 'construction' stamp: 'jm 9/29/97 07:19'!addTitle: aString    "Add a title line at the top of this menu."    | title |    title _ LayoutMorph new setColor: (Color r: 0.5 g: 1 b: 0.75) borderWidth: 1 borderColor: #inset.    title vResizing: #shrinkWrap.    title orientation: #vertical.    title centering: #center.    title addMorph: (StringMorph new contents: aString).    self addMorphFront: title.! !!MenuMorph methodsFor: 'construction' stamp: 'jm 9/28/97 17:18'!defaultTarget: anObject    "Set the default target for adding menu items."    defaultTarget _ anObject.! !!MenuMorph methodsFor: 'menu' stamp: 'jm 9/29/97 08:12'!addCustomMenuItems: aCustomMenu hand: aHandMorph    super addCustomMenuItems: aCustomMenu hand: aHandMorph.    aCustomMenu addLine.    aCustomMenu add: 'add title...' action: #addTitle.    aCustomMenu add: 'set target...' action: #setTarget:.    defaultTarget ifNotNil: [        aCustomMenu add: 'add item...' action: #addItem].    aCustomMenu add: 'remove item' action: #removeItem:.    aCustomMenu add: 'add line' action: #addLine.    (self canDetachSubMenu: aHandMorph)        ifTrue: [aCustomMenu add: 'detach submenu' action: #detachSubMenu:].! !!MenuMorph methodsFor: 'menu' stamp: 'jm 9/29/97 07:58'!addItem    | string sel |    string _ FillInTheBlank request: 'Label for new item?'.    string isEmpty ifTrue: [^ self].    sel _ FillInTheBlank request: 'Selector?'.    sel isEmpty ifFalse: [sel _ sel asSymbol].    self add: string action: sel.! !!MenuMorph methodsFor: 'menu' stamp: 'jm 9/28/97 13:33'!addTitle    | string |    string _ FillInTheBlank request: 'Title for this menu?'.    string isEmpty ifTrue: [^ self].    self addTitle: string.! !!MenuMorph methodsFor: 'menu' stamp: 'jm 9/28/97 13:38'!canDetachSubMenu: hand    | possibleTargets item |    possibleTargets _ hand argumentOrNil morphsAt: hand targetOffset.    item _ possibleTargets        detect: [:each | each isKindOf: MenuItemMorph]        ifNone: [^ false].    ^ item subMenu notNil! !!MenuMorph methodsFor: 'menu' stamp: 'jm 9/29/97 08:20'!detachSubMenu: evt    | possibleTargets item subMenu |    possibleTargets _ evt hand argumentOrNil morphsAt: evt hand targetOffset.    item _ possibleTargets detect: [:each | each isKindOf: MenuItemMorph] ifNone: [^ self].    subMenu _ item subMenu.    subMenu ifNotNil: [        item subMenu: nil.        item delete.        subMenu stayUp: true.        subMenu popUpOwner: nil.        subMenu addTitle: item contents.        evt hand attachMorph: subMenu].! !!MenuMorph methodsFor: 'menu' stamp: 'jm 9/29/97 08:07'!removeItem: evt    | possibleTargets item |    possibleTargets _ evt hand argumentOrNil morphsAt: evt hand targetOffset.    item _ possibleTargets        detect: [:each |                    (each isKindOf: MenuItemMorph) or:                     [each isKindOf: MenuLineMorph]]        ifNone: [^ self].    item delete.! !!MenuMorph methodsFor: 'menu' stamp: 'jm 9/29/97 08:24'!setTarget: evt    "Set the default target object to be used for add item commands, and re-target all existing items to the new target or the the invoking hand."    | rootMorphs old |    rootMorphs _ self world rootMorphsAt: evt hand targetOffset.    rootMorphs size > 1        ifTrue: [defaultTarget _ rootMorphs at: 2]        ifFalse: [^ self].    "re-target all existing items"    self items do: [:item |        old _ item target.        old isHandMorph            ifTrue: [item target: evt hand. evt hand setArgument: defaultTarget]            ifFalse: [item target: defaultTarget]].! !!MenuMorph methodsFor: 'menu' stamp: 'jm 9/29/97 16:27'!toggleStayUp: evt    "Toggle my 'stayUp' flag and adjust the menu item to reflect its new state."    stayUp _ stayUp not.    self items do: [:item |        item selector = #toggleStayUp: ifTrue: [            stayUp                ifTrue: [item contents: 'dismiss this menu']                ifFalse: [item contents: 'stay up']]].    stayUp ifFalse: [self delete].! !!MenuMorph methodsFor: 'layout'!minHeightWhenEmpty    ^ 10! !!MenuMorph methodsFor: 'layout'!minWidthWhenEmpty    ^ 20! !!MenuMorph methodsFor: 'control' stamp: 'jm 9/29/97 13:31'!deleteIfPopUp    "Remove this menu from the screen if stayUp is not true. If it is a submenu, also remove its owning menu."    stayUp ifFalse: [self delete].    (popUpOwner notNil and: [popUpOwner isKindOf: MenuItemMorph]) ifTrue: [        popUpOwner isSelected: false.        (popUpOwner owner isKindOf: MenuMorph)            ifTrue: [popUpOwner owner deleteIfPopUp]].! !!MenuMorph methodsFor: 'control' stamp: 'jm 9/29/97 07:53'!invokeItem: aMenuItem    "Perform the action associated with the given menu item."    | sel target args selArgCount |    aMenuItem isEnabled ifFalse: [^ self].    lastSelection _ aMenuItem.    "to do: report lastSelection"    sel _ aMenuItem selector.    target _ aMenuItem target.    args _ aMenuItem arguments.    selArgCount _ sel numArgs.    Cursor normal showWhile: [  "show cursor in case item opens a new MVC window"        selArgCount = 0            ifTrue: [target perform: sel]            ifFalse: [                selArgCount = args size                    ifTrue: [target perform: sel withArguments: args]                    ifFalse: [target perform: sel withArguments: (args copyWith: originalEvent)]]].! !!MenuMorph methodsFor: 'control' stamp: 'jm 9/29/97 07:52'!popUpAt: aPoint event: evt    "Present this menu at the given point in response to the given event."    originalEvent _ evt.    self popUpAt: aPoint forHand: evt hand.! !!MenuMorph methodsFor: 'control' stamp: 'jm 9/29/97 18:32'!popUpAt: aPoint forHand2: hand    "Present this menu at the given point under control of the given hand."    | selectedItem delta |    popUpOwner _ hand.    selectedItem _ self items detect: [:each | each == lastSelection] ifNone: [self items first].    self position: aPoint - selectedItem position + self position.    delta _ self bounds amountToTranslateWithin: hand worldBounds.    delta = (0@0) ifFalse: [self position: self position + delta].    hand world addMorphFront: self.    self changed.! !!MenuMorph methodsFor: 'control' stamp: 'jm 9/29/97 17:17'!popUpAt: aPoint forHand: hand    "Present this menu at the given point under control of the given hand."    | selectedItem delta |    popUpOwner _ hand.    selectedItem _ self items detect: [:each | each == lastSelection] ifNone: [self items first].    self position: aPoint - selectedItem position + self position.    delta _ self bounds amountToTranslateWithin: hand worldBounds.    delta = (0@0) ifFalse: [self position: self position + delta].    hand world addMorphFront: self.    hand newMouseFocus: selectedItem.    self changed.! !!MenuMorph class methodsFor: 'example' stamp: 'jm 9/29/97 10:36'!example    "MenuMorph example"    | menu |    menu _ MenuMorph new.    menu addStayUpItem.    menu add: 'apples' action: #apples.    menu add: 'oranges' action: #oranges.    menu addLine.    menu addLine.  "extra lines ignored"    menu add: 'peaches' action: #peaches.    menu addLine.    menu add: 'pears' action: #pears.    menu addLine.    ^ menu! !!MessageCategoryListController methodsFor: 'menu messages' stamp: 'di 6/28/97 19:16'!printOut    "Make a file with the description of the selected mesage category in Html format."    self controlTerminate.    Cursor write showWhile:        [model printOutMessageCategories].    self controlInitialize! !!MessageCategoryListView methodsFor: 'updating'!list: anArray     super list: anArray.    (Preferences browserAutoSelect and: [list numberOfLines = 3]) ifTrue:        [controller isNil ifFalse: [controller changeModelSelection: 1]].! !!MessageListController methodsFor: 'menu messages'!methodHierarchy    "Create and schedule a message browser on the hierarchical implementors."    self controlTerminate.    model methodHierarchy.    self controlInitialize! !!MessageListController methodsFor: 'menu messages' stamp: 'di 6/28/97 15:45'!printOut    "Write a description of the selected message on an external file."    self controlTerminate.    Cursor write showWhile:        [model printOutMessage].    self controlInitialize! !!MessageListController methodsFor: 'menu messages' stamp: 'sw 1/26/96'!shiftedYellowButtonMenu    "Answer the menu to be put up when shift key is down.  "    ^ PopUpMenu labels: 'browse fullbrowse inheritancebrowse methodimplementors of sent messagesinspect instancesinspect subinstancesremove from browsermore...' lines: #(4 6)! !!MessageListController methodsFor: 'menu messages' stamp: 'sw 1/26/96'!shiftedYellowButtonMessages    "Answer the messages corresponding to the shifted-yellow-button menu, to be put up when shift key is down.  .  Adjustments, "    ^ #(browseFull methodHierarchy browse allImplementorsOf inspectInstances inspectSubInstances removeMessageFromBrowser unshiftedYellowButtonActivity)! !!MessageListController class methodsFor: 'class initialization' stamp: 'di 6/28/97 15:42'!initialize    "Initialize the yellow button menu for message lists.  2/1/96 sw     7/30/96 sw: added browseInstVarDefs"    MessageListYellowButtonMenu _         PopUpMenu             labels:'browse classfileOutprintOutsendersimplementorssenders of...implementors of...versionsinst var refs...inst var defs...class var refs...class variablesclass refsremovemore...'            lines: #(3 8 13).    MessageListYellowButtonMessages _        #( browseClass fileOut printOut        senders implementors  browseSendersOfMessages messages versions        browseInstVarRefs browseInstVarDefs classVarRefs browseClassVariables browseClassRefs        remove shiftedYellowButtonActivity )"    MessageListController initialize.    MessageListController allInstancesDo:        [:x | x initializeYellowButtonMenu]."! !!MessageListView methodsFor: 'updating'!displayView     "Refer to the comment in View|displayView."    | aClass sel index baseClass |    Browser postOpenSuggestion == nil ifFalse: [        "Set the class and message"        aClass _ Browser postOpenSuggestion first.        sel _ Browser postOpenSuggestion last.        Browser postOpenSuggestion: nil.        baseClass _ aClass theNonMetaClass.        model systemCategoryListIndex:            (SystemOrganization numberOfCategoryOfElement: baseClass name).        model selectClass: baseClass.        model metaClassIndicated: aClass isMeta.        sel notNil ifTrue: [            model messageCategoryListIndex:                (index _ aClass organization numberOfCategoryOfElement: sel).            model messageListIndex:                 ((aClass organization listAtCategoryNumber: index) indexOf: sel)            ].        self topView deEmphasize.        ^ self   "a redisplay has already been done"].    super displayView.! !!MessageListView methodsFor: 'updating' stamp: 'sw 3/8/97'!update: aSymbol    "What to do to the message list when Browser changes. If there is only one item, select and show it.     : as part of adding a new feature that was subsequently removed, simplified the code here enough to justify using it"    aSymbol == #messageSelectionChanged        ifTrue: [^ self updateMessageSelection].    (#(systemCategorySelectionChanged editSystemCategories editClass editMessageCategories) includes: aSymbol)        ifTrue: [^ self resetAndDisplayView].    (aSymbol == #messageCategorySelectionChanged) | (aSymbol == #messageListChanged)         ifTrue: [^ self updateMessageList.].    (aSymbol == #classSelectionChanged) ifTrue:        [model messageCategoryListIndex = 1            ifTrue: ["self updateMessageList."]            ifFalse: [^ self resetAndDisplayView]]! !!MessageNode methodsFor: 'macro transformations' stamp: 'di 7/13/97 10:48'!toDoFromWhileWithInit: initStmt    "Return nil, or a to:do: expression equivalent to this whileTrue:"    | variable increment limit toDoBlock body test |    (selector key == #whileTrue:        and: [(initStmt isMemberOf: AssignmentNode) and:                [initStmt variable isTemp]])        ifFalse: [^ nil].    body _ arguments last statements.    variable _ initStmt variable.    increment _ body last toDoIncrement: variable.    (increment == nil or: [receiver statements size ~= 1])        ifTrue: [^ nil].    test _ receiver statements first.    "Note: test chould really be checked that <= or >= comparison    jibes with the sign of the (constant) increment"    ((test isMemberOf: MessageNode)        and: [(limit _ test toDoLimit: variable) notNil])        ifFalse: [^ nil].    toDoBlock _ BlockNode new            statements: body allButLast            returns: false.    toDoBlock arguments: (Array with: variable).    ^ MessageNode new        receiver: initStmt value        selector: (SelectorNode new key: #to:by:do: code: #macro)        arguments: (Array with: limit with: increment with: toDoBlock)        precedence: precedence! !!MessageNode methodsFor: 'macro transformations'!toDoWithLimit: limitStmt    "The receiver is a to:do: statement, preceded by a statement    that might be of the form {iLimiT _ expr}.  If so, replace the    limit argument by the given expr and return a new to:do: node.    Otherwise, return nil"    ((limitStmt isMemberOf: AssignmentNode)        and: [limitStmt variable = arguments first])        ifFalse: [^ nil].    limitStmt variable key = (arguments last firstArgument key , 'LimiT')        ifFalse: [^ nil].  "Must be a generated temp"    arguments at: 1 put: (limitStmt value)! !!MessageNode methodsFor: 'macro transformations'!transformToDo: encoder    " var _ rcvr. L1: [var <= arg1] Bfp(L2) [block body. var _ var + inc] Jmp(L1) L2: "    | limit increment block initStmt test incStmt limitInit blockVar |    "First check for valid arguments"    ((arguments last isMemberOf: BlockNode)            and: [arguments last numberOfArguments = 1])        ifFalse: [^ false].    arguments last firstArgument isVariableReference        ifFalse: [^ false]. "As with debugger remote vars"    arguments size = 3        ifTrue: [increment _ arguments at: 2.                increment isConstantNumber ifFalse: [^ false]]        ifFalse: [increment _ encoder encodeLiteral: 1].    arguments size < 3 ifTrue:   "transform to full form"        [selector _ SelectorNode new key: #to:by:do: code: #macro].    "Now generate auxiliary structures"    block _ arguments last.    blockVar _ block firstArgument.    initStmt _ AssignmentNode new variable: blockVar value: receiver.    limit _ arguments at: 1.    limit isVariableReference | limit isConstantNumber        ifTrue: [limitInit _ nil]        ifFalse:  "Need to store limit in a var"            [limit _ encoder autoBind: blockVar key , 'LimiT'.            limit scope: -2.  "Already done parsing block"            limitInit _ AssignmentNode new                    variable: limit                    value: (arguments at: 1)].    test _ MessageNode new receiver: blockVar            selector: (increment key > 0 ifTrue: [#<=] ifFalse: [#>=])            arguments: (Array with: limit)            precedence: precedence from: encoder.    incStmt _ AssignmentNode new            variable: blockVar            value: (MessageNode new                receiver: blockVar selector: #+                arguments: (Array with: increment)                precedence: precedence from: encoder).    arguments _ (Array with: limit with: increment with: block)        , (Array with: initStmt with: test with: incStmt with: limitInit).    ^ true! !!MessageNode methodsFor: 'code generation' stamp: 'tao 8/20/97 22:24'!emitCase: stack on: strm value: forValue    | braceNode sizeStream thenSize elseSize |    forValue not        ifTrue: [^super emitForEffect: stack on: strm].    braceNode _ arguments first.    sizeStream _ ReadStream on: sizes.    receiver emitForValue: stack on: strm.    braceNode casesForwardDo:        [:keyNode :valueNode :last |        thenSize _ sizeStream next.        elseSize _ sizeStream next.        last ifFalse: [strm nextPut: Dup. stack push: 1].        keyNode emitForEvaluatedValue: stack on: strm.        equalNode emit: stack args: 1 on: strm.        self emitBranchOn: false dist: thenSize pop: stack on: strm.        last ifFalse: [strm nextPut: Pop. stack pop: 1].        valueNode emitForEvaluatedValue: stack on: strm.        last ifTrue: [stack pop: 1].        valueNode returns ifFalse: [self emitJump: elseSize on: strm]].    arguments size = 2        ifTrue:            [arguments last emitForEvaluatedValue: stack on: strm] "otherwise: [...]"        ifFalse:            [NodeSelf emitForValue: stack on: strm.            caseErrorNode emit: stack args: 0 on: strm]! !!MessageNode methodsFor: 'code generation'!emitForValue: stack on: strm    special > 0        ifTrue:             [self perform: (MacroEmitters at: special) with: stack with: strm with: true.            pc _ 0]        ifFalse:             [receiver ~~ nil ifTrue: [receiver emitForValue: stack on: strm].            arguments do: [:argument | argument emitForValue: stack on: strm].            selector                emit: stack                args: arguments size                on: strm                super: receiver == NodeSuper.            pc _ strm position]! !!MessageNode methodsFor: 'code generation' stamp: 'tao 8/20/97 22:25'!sizeCase: encoder value: forValue    | braceNode sizeIndex thenSize elseSize |    forValue not        ifTrue: [^super sizeForEffect: encoder].    equalNode _ encoder encodeSelector: #=.    braceNode _ arguments first.    sizes _ Array new: 2 * braceNode numElements.    sizeIndex _ sizes size.    elseSize _ arguments size = 2        ifTrue:            [arguments last sizeForEvaluatedValue: encoder] "otherwise: [...]"        ifFalse:            [caseErrorNode _ encoder encodeSelector: #caseError.             1 + (caseErrorNode size: encoder args: 0 super: false)]. "self caseError"    braceNode casesReverseDo:        [:keyNode :valueNode :last |        sizes at: sizeIndex put: elseSize.        thenSize _ valueNode sizeForEvaluatedValue: encoder.        last ifFalse: [thenSize _ thenSize + 1]. "Pop"        valueNode returns ifFalse: [thenSize _ thenSize + (self sizeJump: elseSize)].        sizes at: sizeIndex-1 put: thenSize.        last ifFalse: [elseSize _ elseSize + 1]. "Dup"        elseSize _ elseSize + (keyNode sizeForEvaluatedValue: encoder) +            (equalNode size: encoder args: 1 super: false) +            (self sizeBranchOn: false dist: thenSize) + thenSize.        sizeIndex _ sizeIndex - 2].    ^(receiver sizeForValue: encoder) + elseSize! !!MessageNode methodsFor: 'code generation'!sizeForValue: encoder    | total argSize |    special > 0         ifTrue: [^self perform: (MacroSizers at: special) with: encoder with: true].    receiver == NodeSuper        ifTrue: [selector _ selector copy "only necess for splOops"].    total _ selector size: encoder args: arguments size super: receiver == NodeSuper.    receiver == nil         ifFalse: [total _ total + (receiver sizeForValue: encoder)].    sizes _ arguments collect:                     [:arg |                     argSize _ arg sizeForValue: encoder.                    total _ total + argSize.                    argSize].    ^total! !!MessageNode methodsFor: 'printing' stamp: 'di 7/13/97 14:50'!printCaseOn: aStream indent: level    "receiver caseOf: {[key]->[value]. ...} otherwise: [otherwise]"    | braceNode otherwise extra |    braceNode _ arguments first.    otherwise _ arguments last.    ((arguments size = 1) or: [otherwise isJustCaseError])        ifTrue: [otherwise _ nil].    receiver printOn: aStream indent: level precedence: 3.    aStream nextPutAll: ' caseOf: '.    braceNode isVariableReference        ifTrue: [braceNode printOn: aStream indent: level]        ifFalse:    [aStream nextPutAll: '{'; crtab: level+1.    braceNode casesForwardDo:        [:keyNode :valueNode :last |        keyNode printOn: aStream indent: level+1.         aStream nextPutAll: ' -> '.        extra _ valueNode isComplex ifTrue: [aStream crtab: level+2. 1] ifFalse: [0].         valueNode printOn: aStream indent: level+1+extra.         last ifTrue: [aStream nextPut: $}] ifFalse: [aStream nextPut: $.; crtab: level+1]]].    otherwise isNil        ifFalse:            [aStream crtab: level+1; nextPutAll: 'otherwise: '.             extra _ otherwise isComplex ifTrue: [aStream crtab: level+2. 1] ifFalse: [0].             otherwise printOn: aStream indent: level+1+extra]! !!MessageNode methodsFor: 'printing' stamp: 'di 9/20/97 22:58'!printKeywords: key arguments: args on: aStream indent: level    | keywords prev arg indent thisKey |    args size = 0         ifTrue: [aStream space; nextPutAll: key. ^ self].    keywords _ key keywords.    prev _ receiver.    1 to: keywords size do:        [:part | arg _ args at: part.        thisKey _ keywords at: part.        (prev isMemberOf: BlockNode)         | ((prev isMemberOf: MessageNode) and: [prev precedence >= 3])         | ((arg isMemberOf: BlockNode) and: [arg isComplex and: [thisKey ~= #do:]])         | (args size > 2)         | (key = #ifTrue:ifFalse:)            ifTrue: [aStream crtab: level+1. indent _ 1] "newline after big args"            ifFalse: [aStream space. indent _ 0].        aStream nextPutAll: thisKey; space.        arg  printOn: aStream indent: level + 1 + indent             precedence: (precedence = 2 ifTrue: [1] ifFalse: [precedence]).        prev _ arg]! !!MessageNode methodsFor: 'printing'!printToDoOn: aStream indent: level    | limitNode |    (arguments last == nil or: [(arguments last isMemberOf: AssignmentNode) not])        ifTrue: [limitNode _ arguments first]        ifFalse: [limitNode _ arguments last value].    (selector key = #to:by:do:            and: [(arguments at: 2) isConstantNumber                and: [(arguments at: 2) key = 1]])        ifTrue: [self printKeywords: #to:do:                    arguments: (Array with: limitNode with: (arguments at: 3))                    on: aStream indent: level]        ifFalse: [self printKeywords: selector key                    arguments: (Array with: limitNode) , arguments allButFirst                    on: aStream indent: level]! !!MessageNode methodsFor: 'C translation'!asTranslatorNode    "selector is sometimes a Symbol, sometimes a SelectorNode!!    On top of this, numArgs is needed due to the (truly grody) use of    arguments as a place to store the extra expressions needed to generate    code for in-line to:by:do:, etc.  see below, where it is used."    | sel args |    sel _ (selector isMemberOf: Symbol) ifTrue: [selector] ifFalse: [selector key].    args _ (1 to: sel numArgs) collect:            [:i | (arguments at: i) asTranslatorNode].    (sel = #to:by:do: and: [arguments size = 7 and: [(arguments at: 7) notNil]])        ifTrue: ["Restore limit expr that got moved by transformToDo:"                args at: 1 put: (arguments at: 7) value asTranslatorNode].    (sel = #or: and: [arguments size = 2 and: [(arguments at: 2) notNil]])        ifTrue: ["Restore argument block that got moved by transformOr:"                args at: 1 put: (arguments at: 2) asTranslatorNode].    (sel = #ifFalse: and: [arguments size = 2 and: [(arguments at: 2) notNil]])        ifTrue: ["Restore argument block that got moved by transformIfFalse:"                args at: 1 put: (arguments at: 2) asTranslatorNode].    ^ TSendNode new        setSelector: sel        receiver: ((receiver == nil)                    ifTrue: [nil]                    ifFalse: [receiver asTranslatorNode])        arguments: args! !!MessageNode class methodsFor: 'class initialization' stamp: 'di 7/13/97 10:31'!initialize        "MessageNode initialize"    MacroSelectors _         #(ifTrue: ifFalse: ifTrue:ifFalse: ifFalse:ifTrue:            and: or:            whileFalse: whileTrue: whileFalse whileTrue            to:do: to:by:do:            caseOf: caseOf:otherwise: as: ).    MacroTransformers _         #(transformIfTrue: transformIfFalse: transformIfTrueIfFalse: transformIfFalseIfTrue:            transformAnd: transformOr:            transformWhile: transformWhile: transformWhile: transformWhile:            transformToDo: transformToDo:            transformCase: transformCase: transformAs: ).    MacroEmitters _         #(emitIf:on:value: emitIf:on:value: emitIf:on:value: emitIf:on:value:            emitIf:on:value: emitIf:on:value:            emitWhile:on:value: emitWhile:on:value: emitWhile:on:value: emitWhile:on:value:            emitToDo:on:value: emitToDo:on:value:            emitCase:on:value: emitCase:on:value: emitAs:on:value: ).    MacroSizers _         #(sizeIf:value: sizeIf:value: sizeIf:value: sizeIf:value:            sizeIf:value: sizeIf:value:            sizeWhile:value: sizeWhile:value: sizeWhile:value: sizeWhile:value:            sizeToDo:value: sizeToDo:value:            sizeCase:value: sizeCase:value: sizeAs:value: ).    MacroPrinters _         #(printIfOn:indent: printIfOn:indent: printIfOn:indent: printIfOn:indent:            printIfOn:indent: printIfOn:indent:            printWhileOn:indent: printWhileOn:indent: printWhileOn:indent: printWhileOn:indent:            printToDoOn:indent: printToDoOn:indent:            printCaseOn:indent: printCaseOn:indent: printAsOn:indent: )! !!MessageSet methodsFor: 'contents' stamp: 'di 7/13/97 11:15'!contents: aString notifying: aController     "Compile the code in aString. Notify aController of any syntax errors.     Create an error if the category of the selected message is unknown.     Answer false if the compilation fails. Otherwise, if the compilation     created a new method, deselect the current selection. Then answer true."    | category selector |    messageListIndex = 0 ifTrue: [^ false].    self setClassAndSelectorIn: [:class :oldSelector].    category _ class organization categoryOfElement: oldSelector.    selector _ class compile: aString                classified: category                notifying: aController.    selector == nil ifTrue: [^false].    selector == oldSelector ifFalse: [self messageListIndex: 0].    ^ true! !!MessageTally methodsFor: 'initialize-release'!spyEvery: millisecs on: aBlock     "Create a spy and spy on the given block at the specified rate."    | myDelay value startTime |    (aBlock isMemberOf: BlockContext)        ifFalse: [self error: 'spy needs a block here'].    self class: aBlock receiver class method: aBlock method.        "set up the probe"    ObservedProcess _ Processor activeProcess.    myDelay _ Delay forMilliseconds: millisecs.    Timer _        [[true] whileTrue:             [startTime _ Time millisecondClockValue.            myDelay wait.            self tally: ObservedProcess suspendedContext                "tally can be > 1 if ran a long primitive"                by: (Time millisecondClockValue - startTime) // millisecs].        nil] newProcess.    Timer priority: Processor userInterruptPriority.        "activate the probe and evaluate the block"    Timer resume.    value _ aBlock value.        "cancel the probe and return the value"    Timer terminate.    ^value! !!MessageTally methodsFor: 'tallying'!bumpBy: count    tally _ tally + count! !!MessageTally methodsFor: 'tallying'!tally: context by: count    "Explicitly tally the specified context and its stack."    | root |    context method == method ifTrue: [^self bumpBy: count].    (root _ context home sender) == nil        ifTrue: [^ (self bumpBy: count) tallyPath: context by: count].    ^ (self tally: root by: count) tallyPath: context by: count! !!MessageTally methodsFor: 'tallying'!tallyPath: context by: count    | aMethod path |    aMethod _ context method.    receivers do:         [:aMessageTally |         aMessageTally method == aMethod ifTrue: [path _ aMessageTally]].    path == nil ifTrue:         [path _ MessageTally new class: context receiver class method: aMethod.        receivers _ receivers copyWith: path].    ^ path bumpBy: count! !!MessageTally methodsFor: 'printing'!printOn: aStream total: total tallyExact: isExact    | aSelector className myTally |    isExact ifTrue:        [myTally _ tally.        receivers == nil            ifFalse: [receivers do: [:r | myTally _ myTally - r tally]].        aStream print: myTally; space]        ifFalse:        [aStream print: (tally asFloat / total * 100.0 roundTo: 0.1); space].    receivers == nil        ifTrue: [aStream nextPutAll: 'primitives'; cr]        ifFalse:             [aSelector _ class selectorAtMethod: method setClass: [:aClass].            className _ aClass name contractTo: 30.            aStream nextPutAll: className; space;                nextPutAll: (aSelector contractTo: 60-className size); cr]! !!MessageTally class methodsFor: 'spying'!tallySendsTo: receiver inBlock: aBlock showTree: treeOption    "MessageTally tallySends: [3.14159 printString]"    "This method uses the simulator to count the number of calls on each method    invoked in evaluating aBlock. If receiver is not nil, then only sends    to that receiver are tallied.    Results are presented as leaves, sorted by frequency,    preceded, optionally, by the whole tree."    | prev tallies |    tallies _ MessageTally new class: aBlock receiver class                            method: aBlock method.    prev _ aBlock.    thisContext sender        runSimulated: aBlock        contextAtEachStep:            [:current |            current == prev ifFalse:                 ["call or return"                prev sender == nil ifFalse:                     ["call only"                    (receiver == nil or: [current receiver == receiver])                        ifTrue: [tallies tally: current by: 1]].                prev _ current]].    StringHolderView open: (StringHolder new contents:        (String streamContents:            [:s |            treeOption                ifTrue: [tallies fullPrintOn: s tallyExact: true orThreshold: 0]                ifFalse: [tallies leavesPrintOn: s tallyExact: true orThreshold: 0].            tallies close]))        label: 'Spy Results'! !!MessageTally class methodsFor: 'spying'!time: aBlock    ^ Time millisecondsToRun: aBlock! !!Metaclass methodsFor: 'initialize-release'!instanceVariableNames: instVarString     "Declare additional named variables for my instance."    | newMeta invalid |    newMeta _ self copyForValidation.    invalid _ newMeta                subclassOf: superclass                oldClass: self                instanceVariableNames: instVarString                variable: false                words: true                pointers: true                ifBad: [^false].    (invalid or: [instVarString ~= self instanceVariablesString])        ifTrue: [newMeta validateFrom: self                    in: Smalltalk                    instanceVariableNames: true                    methods: true.                Smalltalk changes changeClass: self]! !!Metaclass methodsFor: 'compiling'!scopeHas: name ifTrue: assocBlock      ^thisClass scopeHas: name ifTrue: assocBlock! !!Metaclass methodsFor: 'fileIn/Out'!definition     "Refer to the comment in ClassDescription|definition."    | aStream names |    aStream _ WriteStream on: (String new: 300).    self printOn: aStream.    names _ self instVarNames."    names isEmpty ifTrue: [^  aStream contents]."    aStream nextPutAll: '    instanceVariableNames: '''.    1 to: names size do: [:i | aStream nextPutAll: (names at: i); space].    aStream nextPut: $'.    ^ aStream contents! !!MethodDictionary methodsFor: 'private' stamp: 'di 9/21/97 20:54'!grow     | newSelf key |    newSelf _ self species new: self basicSize.  "This will double the size"    1 to: self basicSize do:        [:i | key _ self basicAt: i.        key == nil ifFalse: [newSelf at: key put: (array at: i)]].    self become: newSelf! !!MethodDictionary methodsFor: 'private'!rehash     | newSelf key |    newSelf _ self species new: self size.    1 to: self basicSize do:        [:i | key _ self basicAt: i.        key == nil ifFalse: [newSelf at: key put: (array at: i)]].    self become: newSelf! !!MethodDictionary methodsFor: 'private'!scanFor: anObject    "Scan the key array for the first slot containing either a nil (indicating an empty slot) or an element that matches anObject. Answer the index of that slot or zero if no slot is found. This method will be overridden in various subclasses that have different interpretations for matching elements."    | element start finish |    start _ (anObject identityHash \\ array size) + 1.    finish _ array size.    "Search from (hash mod size) to the end."    start to: finish do:        [:index | ((element _ self basicAt: index) == nil or: [element == anObject])            ifTrue: [^ index ]].    "Search from 1 to where we started."    1 to: start-1 do:        [:index | ((element _ self basicAt: index) == nil or: [element == anObject])            ifTrue: [^ index ]].    ^ 0  "No match AND no empty slot"! !!MethodDictionary class methodsFor: 'instance creation' stamp: 'di 9/21/97 20:53'!new: nElements    "Create a Dictionary large enough to hold nElements without growing.    Note that the basic size must be a power of 2.    It is VITAL (see grow) that size gets doubled if nElements is a power of 2"    | size |    size _ 1 bitShift: nElements highBit.    ^ (self basicNew: size) init: size! !!MethodNode methodsFor: 'code generation'!generate: trailer    "The receiver is the root of a parse tree. Answer a CompiledMethod. The     argument, trailer, is the references to the source code that is stored with     every CompiledMethod."    | blkSize nLits stack strm nArgs |    self generateIfQuick:         [:method |         1 to: trailer size do: [:i | method at: method size - trailer size + i put: (trailer at: i)].        method cacheTempNames: self tempNames.        ^method].    nArgs _ arguments size.    blkSize _ block sizeForEvaluatedValue: encoder.    encoder maxTemp > 31        ifTrue: [^self error: 'Too many temporary variables'].        literals _ encoder allLiterals.    (nLits _ literals size) > 255        ifTrue: [^self error: 'Too many literals referenced'].    method _ CompiledMethod    "Dummy to allocate right size"                newBytes: blkSize                nArgs: nArgs                nTemps: encoder maxTemp                nStack: 0                nLits: nLits                primitive: primitive.    strm _ ReadWriteStream with: method.    strm position: method initialPC - 1.    stack _ ParseStack new init.    block emitForEvaluatedValue: stack on: strm.    stack position ~= 1 ifTrue: [^self error: 'Compiler stack discrepancy'].    strm position ~= (method size - trailer size)         ifTrue: [^self error: 'Compiler code size discrepancy'].    method needsFrameSize: stack size.    1 to: nLits do: [:lit | method literalAt: lit put: (literals at: lit)].    1 to: trailer size do: [:i | method at: method size - trailer size + i put: (trailer at: i)].    method cacheTempNames: self tempNames.    ^ method! !!MethodNode methodsFor: 'code generation'!sourceMap    "Answer a SortedCollection of associations of the form: pc (byte offset in     me) -> sourceRange (an Interval) in source text."    self generate: #(0 0 0 0).    ^encoder sourceMap! !!MethodNode methodsFor: 'converting'!decompileString     "Answer a string description of the parse tree whose root is the receiver."    ^ String streamContents: [:strm | self printOn: strm]! !!MethodNode methodsFor: 'converting'!decompileText     "Answer a string description of the parse tree whose root is the receiver."    ^ Text streamContents: [:strm | self printOn: strm]! !!MethodNode methodsFor: 'printing'!printOn: aStream     | args |    precedence = 1        ifTrue:             [aStream nextPutAll: self selector]        ifFalse:             [args _ ReadStream on: arguments.            self selector keywords do:                 [:s |                 aStream nextPutAll: s; space.                aStream withAttribute: (TextColor color: Color green)                    do: [aStream nextPutAll: args next key].                aStream space]].    comment == nil ifFalse:             [aStream crtab: 1.            self printCommentOn: aStream indent: 1].    temporaries size > 0 ifTrue:             [aStream crtab: 1.            aStream nextPutAll: '| '.            aStream withAttribute: (TextColor color: Color green)                do: [temporaries do:                     [:temp |                     aStream nextPutAll: temp key.                    aStream space]].            aStream nextPut: $|].    primitive > 0 ifTrue:            [primitive < 256 ifTrue:  " Dont decompile <prim> for, eg, ^ self "                [aStream crtab: 1.                self printPrimitiveOn: aStream]].    aStream crtab: 1.    ^block printStatementsOn: aStream indent: 0! !!MethodNode methodsFor: 'C translation'!asTMethodFromClass: aClass     ^ TMethod new        setSelector: selectorOrFalse        args: arguments        locals: encoder tempsAndBlockArgs        block: block! !!MixedSound methodsFor: 'sound generation'!samplesRemaining    | remaining r |    remaining _ 0.    1 to: sounds size do: [ :i |        r _ (sounds at: i) samplesRemaining.        r > remaining ifTrue: [ remaining _ r ].    ].    ^ remaining! !!MixedSound methodsFor: 'copying' stamp: 'jm 10/4/97 16:52'!copy    "Copy my component sounds."    ^ self clone copySounds! !!MixedSound methodsFor: 'copying' stamp: 'jm 10/4/97 16:53'!copySounds    "Private!! Support for copying. Copy my component sounds and settings array."    sounds _ (sounds collect: [:s | s copy]).    panSettings _ panSettings copy.! !!Model methodsFor: 'dependents'!addDependent: anObject    "Make the given object one of the receiver's dependents."    dependents == nil        ifTrue: [dependents _ Array with: anObject]        ifFalse: [            "done if anObject is already a dependent"            dependents do: [:o | o == anObject ifTrue: [^ self]].            "otherwise, add it"            dependents _ dependents copyWith: anObject].! !!Model methodsFor: 'dependents'!breakDependents    "Remove all of the receiver's dependents."    dependents _ nil.! !!Model methodsFor: 'dependents'!dependents    "Answer a collection of objects that are 'dependent' on the receiver;     that is, all objects that should be notified if the receiver changes."    dependents == nil ifTrue: [^ #()].    ^ dependents! !!Model methodsFor: 'dependents' stamp: 'sw 10/30/96'!removeDependent: anObject    "Remove the given object as one of the receiver's dependents.    : if dependents nil on entry, simply exit; workaround for confusing bug encountered in bringing Fabrik up on Squeak."    | newDependents |    dependents == nil ifTrue: [^ self].    newDependents _ dependents select: [ :d | (d == anObject) not].    newDependents isEmpty        ifTrue: [dependents _ nil]        ifFalse: [dependents _ newDependents]! !Morph comment:'A morph (from the Greek "shape" or "form") is an interactive graphical object.'!!Morph methodsFor: 'initialization'!initialize    bounds _ 0@0 corner: 50@40.    owner _ nil.    submorphs _ EmptyArray.    color _ Color blue.    ! !!Morph methodsFor: 'classification'!isHandMorph    ^ false! !!Morph methodsFor: 'classification'!isLayoutMorph    ^ false! !!Morph methodsFor: 'classification'!isMorph    ^ true! !!Morph methodsFor: 'classification'!isWorldMorph    ^ false! !!Morph methodsFor: 'classification'!isWorldOrHandMorph    ^ self isWorldMorph or: [self isHandMorph]! !!Morph methodsFor: 'accessing' stamp: 'di 6/11/97 11:45'!balloonHelpText    "This message may be overridden to supply text particular to this morph"    ^ ''! !!Morph methodsFor: 'accessing'!color    ^ color! !!Morph methodsFor: 'accessing' stamp: 'jm 8/24/97 21:26'!color: aColor    color = aColor ifFalse: [        color _ aColor.        self changed].! !!Morph methodsFor: 'accessing'!colorForInsets    "Return the color to be used for shading inset borders.  The default is my own color, but it might want to be, eg, my owner's color."    ^ color! !!Morph methodsFor: 'accessing'!eventHandler    ^ eventHandler! !!Morph methodsFor: 'accessing' stamp: 'tk 5/22/97'!eventHandler: anEventHandler    "Note that morphs can share eventHandlers and all is OK.  "    eventHandler _ anEventHandler.! !!Morph methodsFor: 'accessing' stamp: '6/6/97 12:39 di'!paneColor: aColor    "May be overridden to color certain morphs in, eg, a browser"! !!Morph methodsFor: 'copying'!copy    ^ self copyWithoutSubmorphs! !!Morph methodsFor: 'copying'!fullCopy    | dict new |    dict _ IdentityDictionary new: 1000.    new _ self copyRecordingIn: dict.    new allMorphsDo: [:m | m updateReferencesUsing: dict].    ^ new! !!Morph methodsFor: 'copying'!updateReferencesUsing: aDictionary    "Update intra-morph references within a composite morph that has been copied. For example, if a button refers to morph X in the orginal composite then the copy of that button in the new composite should refer to the copy of X in new composite, not the original X. This default implementation updates the contents of any morph-bearing slot. It may be overridden to avoid this behavior if so desired."    | old |    Morph instSize + 1 to: self class instSize do:        [:i | old _ self instVarAt: i.        old isMorph ifTrue:            [self instVarAt: i put: (aDictionary at: old ifAbsent: [old])]].    eventHandler ifNotNil:        [eventHandler _ eventHandler copy.        1 to: eventHandler class instSize do:            [:i | old _ eventHandler instVarAt: i.            old isMorph ifTrue:                [eventHandler instVarAt: i put: (aDictionary at: old ifAbsent: [old])]]]! !!Morph methodsFor: 'structure'!isInWorld    "Return true if this morph is in a world."    ^ self world ~= nil! !!Morph methodsFor: 'structure'!owner    "Returns the owner of this morph, which may be nil."    ^ owner! !!Morph methodsFor: 'structure'!root    "Return the root of the composite morph containing the receiver. The owner of the root is either nil, a WorldMorph, or a HandMorph. If the receiver's owner is nil, the root is the receiver itself. This method always returns a morph."    (owner = nil or: [owner isWorldOrHandMorph]) ifTrue: [^ self].    ^ owner root! !!Morph methodsFor: 'structure'!world    "Return the WorldMorph that contains this morph, or nil if this morph is not in a world."    | o |    o _ self root owner.    o ifNil: [^ nil].    o isWorldMorph ifTrue: [^ o].    o isHandMorph ifTrue: [^ o owner].! !!Morph methodsFor: 'submorphs-accessing'!allMorphs    "Return a collection containing all morphs in this composite morph (including the receiver)."    | all |    all _ OrderedCollection new: 100.    self allMorphsDo: [: m | all add: m].    ^ all! !!Morph methodsFor: 'submorphs-accessing'!allMorphsDo: aBlock    "Evaluate the given block for all morphs in this composite morph (including the receiver)."    submorphs size > 0 ifTrue: [        submorphs do: [:m | m allMorphsDo: aBlock].    ].    aBlock value: self.! !!Morph methodsFor: 'submorphs-accessing' stamp: 'tk 5/29/97'!couldBeOwnedBy: aMorph    "Return true if self has no WorldMorph in its owner chain (it is not installed anywhere) or has aMorph in owner chain.  Returns false if self is definately owned by someone else, not aMorph.  Used for writing a subtree on the disk.  Need to include morphs with nil owner who are held in inst vars.  "    | nextOwner prev |    "is aMorph in my owner chain?"    nextOwner _ self.    prev _ nil.    [nextOwner == aMorph ifTrue: [^ true].        nextOwner == nil] whileFalse: [prev _ nextOwner.                                nextOwner _ nextOwner owner].    ^ prev isWorldMorph not    "If chain ends with no WorldMorph, not installed and might be held by aMorph"    "If installed in a world, and aMorph is in NOT on my owner chain, ^ false"    ! !!Morph methodsFor: 'submorphs-accessing'!findA: aClass    "Return the first submorph of the receiver that is descended from the given class. Return nil if there is no such submorph. Clients of this code should always check for a nil return value so that the code will be robust if the user takes the morph apart."    submorphs do: [:each | (each isKindOf: aClass) ifTrue: [^ each]].    ^ nil! !!Morph methodsFor: 'submorphs-accessing'!firstSubmorph    ^ submorphs at: 1! !!Morph methodsFor: 'submorphs-accessing'!hasSubmorphs    ^ submorphs size > 0! !!Morph methodsFor: 'submorphs-accessing'!lastSubmorph    ^ submorphs at: submorphs size! !!Morph methodsFor: 'submorphs-accessing' stamp: 'di 5/23/97'!morphsAt: aPoint    "Return a collection of all morphs in this morph structure that contain the given point, possibly including the receiver itself.  Simplified "    ^ self morphsAt: aPoint addTo: OrderedCollection new! !!Morph methodsFor: 'submorphs-accessing' stamp: 'tk 5/22/97'!morphsAt: aPoint addTo: mList    "Return a collection of all morphs in this morph structure that contain the given point, possibly including the receiver itself.  Must do this recursively because of transforms.  "    submorphs size > 0 ifTrue:        [submorphs do: [:m | m morphsAt: aPoint addTo: mList]].    (self containsPoint: aPoint) ifTrue: [mList addLast: self].    ^ mList! !!Morph methodsFor: 'submorphs-accessing'!submorphCount    ^ submorphs size! !!Morph methodsFor: 'submorphs-accessing'!submorphs    ^ submorphs copy! !!Morph methodsFor: 'submorphs-accessing'!submorphsDo: aBlock    submorphs do: aBlock.! !!Morph methodsFor: 'submorphs-accessing'!submorphsReverseDo: aBlock    submorphs reverseDo: aBlock.! !!Morph methodsFor: 'submorphs-accessing' stamp: 'jm 6/13/97 10:54'!uncoveredAt: aPoint    "Return true if the receiver is not covered by any submorphs at the given point."    | morphsAbove |    morphsAbove _ self world morphsAt: aPoint.    ^ morphsAbove first = self or:     [(morphsAbove first isKindOf: MouseOverHandlesMorph) and:     [(morphsAbove at: 2) = self]]! !!Morph methodsFor: 'submorphs-add/remove'!addAllMorphs: aCollection    aCollection do: [:m |        m owner ifNotNil: [m owner privateRemoveMorph: m].        m layoutChanged.        m privateOwner: self].    submorphs _ submorphs, aCollection.    self layoutChanged.! !!Morph methodsFor: 'submorphs-add/remove'!addMorph: aMorph    self addMorphFront: aMorph.! !!Morph methodsFor: 'submorphs-add/remove'!addMorphBack: aMorph    aMorph owner ifNotNil: [aMorph owner privateRemoveMorph: aMorph].    aMorph layoutChanged.    aMorph privateOwner: self.    submorphs _ submorphs copyWith: aMorph.    aMorph changed.  "need to paint morphs now front, if any"    self layoutChanged.! !!Morph methodsFor: 'submorphs-add/remove'!addMorphCentered: aMorph    self addMorphFront: aMorph.    aMorph position: bounds center - (aMorph extent // 2)! !!Morph methodsFor: 'submorphs-add/remove'!addMorphFront: aMorph    aMorph owner ifNotNil: [aMorph owner privateRemoveMorph: aMorph].    aMorph layoutChanged.    aMorph privateOwner: self.    submorphs _ (Array with: aMorph), submorphs.    self layoutChanged.! !!Morph methodsFor: 'submorphs-add/remove'!delete    "Remove the receiver as a submorph of its owner and make its new owner be nil."    owner ifNotNil: [        owner privateRemoveMorph: self.        owner _ nil].! !!Morph methodsFor: 'submorphs-add/remove'!removeAllMorphs    self changed.    submorphs do: [:m | m privateOwner: nil].    submorphs _ EmptyArray.    self layoutChanged.! !!Morph methodsFor: 'drawing'!drawOn: aCanvas    aCanvas fillRectangle: self bounds color: color.! !!Morph methodsFor: 'drawing'!fullDrawOn: aCanvas    (aCanvas isVisible: self fullBounds) ifFalse: [^ self].    (aCanvas isVisible: bounds) ifTrue: [self drawOn: aCanvas].    submorphs isEmpty ifFalse: [        submorphs reverseDo: [:m | m fullDrawOn: aCanvas]].  "draw back-to-front"! !!Morph methodsFor: 'drawing' stamp: 'jm 6/11/97 17:21'!imageForm    ^ self imageFormForRectangle: self fullBounds! !!Morph methodsFor: 'drawing'!imageFormForRectangle: rect    | canvas |    canvas _ FormCanvas extent: rect extent.    self fullDrawOn: (canvas copyOffset: rect topLeft negated).    ^ canvas form offset: rect topLeft! !!Morph methodsFor: 'geometry' stamp: 'di 9/25/97 20:45'!align: aPoint1 with: aPoint2    "Translate by aPoint2 - aPoint1."    ^ self position: self position + (aPoint2 - aPoint1)! !!Morph methodsFor: 'geometry'!bottom    ^ bounds bottom! !!Morph methodsFor: 'geometry' stamp: 'di 9/20/97 22:14'!bottomLeft    ^ bounds bottomLeft! !!Morph methodsFor: 'geometry' stamp: 'di 6/12/97 11:17'!bottomRight    ^ bounds bottomRight! !!Morph methodsFor: 'geometry'!bounds    ^ bounds! !!Morph methodsFor: 'geometry'!bounds: newBounds    self position: newBounds topLeft; extent: newBounds extent! !!Morph methodsFor: 'geometry'!center    ^ bounds center! !!Morph methodsFor: 'geometry'!extent    ^ bounds extent! !!Morph methodsFor: 'geometry' stamp: 'jm 8/24/97 21:27'!extent: aPoint    bounds extent = aPoint ifFalse: [        self changed.        bounds _ bounds topLeft extent: aPoint.        self layoutChanged.        self changed].! !!Morph methodsFor: 'geometry'!fullBounds    fullBounds ifNil: [        fullBounds _ self bounds.        self submorphsDo: [:m | fullBounds _ fullBounds quickMerge: m fullBounds]].    ^ fullBounds! !!Morph methodsFor: 'geometry'!height    ^ bounds height! !!Morph methodsFor: 'geometry'!innerBounds    "Return the inner rectangle enclosed by the bounds of this morph excluding the space taken by its borders. For an unbordered morph, this is just its bounds."    ^ bounds! !!Morph methodsFor: 'geometry'!left    ^ bounds left! !!Morph methodsFor: 'geometry'!moveBy: delta    "Relocate me, and all of my subMorphs by recursion"    (delta x = 0 and: [delta y = 0]) ifTrue: [^ self].  "Null change"    self changed.    submorphs size > 0        ifTrue: [submorphs do: [:m | m moveBy: delta]].    self privateMoveBy: delta.    self changed! !!Morph methodsFor: 'geometry'!position    ^ bounds topLeft! !!Morph methodsFor: 'geometry'!position: aPoint    "Relocate me, and all of my subMorphs by recursion"    self moveBy: aPoint truncated - bounds topLeft! !!Morph methodsFor: 'geometry'!right    ^ bounds right! !!Morph methodsFor: 'geometry'!top    ^ bounds top! !!Morph methodsFor: 'geometry' stamp: 'di 6/12/97 11:07'!topLeft    ^ bounds topLeft! !!Morph methodsFor: 'geometry'!width    ^ bounds width! !!Morph methodsFor: 'geometry' stamp: 'jm 6/26/97 08:30'!x    ^ bounds left! !!Morph methodsFor: 'geometry' stamp: 'jm 6/26/97 10:36'!x: aNumber    self position: aNumber@bounds top.! !!Morph methodsFor: 'geometry' stamp: 'jm 6/26/97 08:30'!y    ^ bounds top! !!Morph methodsFor: 'geometry' stamp: 'jm 6/26/97 10:35'!y: aNumber    self position: bounds left@aNumber.! !!Morph methodsFor: 'geometry testing'!containsPoint: aPoint    ^ self bounds containsPoint: aPoint! !!Morph methodsFor: 'geometry testing'!fullContainsPoint: aPoint    (self fullBounds containsPoint: aPoint) ifFalse: [^ false].  "quick elimination"    self allMorphsDo:        [:m | (m containsPoint: aPoint) ifTrue: [^ true]].    ^ false! !!Morph methodsFor: 'dropping/grabbing'!acceptDroppingMorph: aMorph event: evt    "This message is sent when a morph is dropped onto a morph that has agreed to accept the dropped morph by responding 'true' to the wantsDroppedMorph:Event: message. This default implementation just adds the given morph to the receiver."    self addMorph: aMorph.! !!Morph methodsFor: 'dropping/grabbing'!allowSubmorphExtraction    "Return true if this morph allows its submorphs to be extracted just by grabbing them. This default implementation returns false."    ^ false! !!Morph methodsFor: 'dropping/grabbing'!justDroppedInto: aMorph event: anEvent    "This message is sent to a dropped morph after it has been dropped on--and been accepted by--a drop-sensitive morph. This default implementation does nothing."! !!Morph methodsFor: 'dropping/grabbing'!rootForGrabOf: aMorph    "Like root, but can be overridden by a morph that wants to allow its submorphs to be extracted just by picking them up."    (owner = nil or: [owner isWorldOrHandMorph]) ifTrue: [^ self].    owner allowSubmorphExtraction        ifTrue: [^ self]        ifFalse: [^ owner rootForGrabOf: aMorph].! !!Morph methodsFor: 'dropping/grabbing'!wantsDroppedMorph: aMorph event: evt    "Return true if the receiver wishes to accept the given morph, which is being dropped into the world by a hand in response to the given event. This default implementation returns false."    ^ false! !!Morph methodsFor: 'event handling'!click: evt    "Handle a single-click event. This message is only sent to clients that request it by sending #waitForClicksOrDrag:event: to the initiating hand in their mouseDown: method. This default implementation does nothing."! !!Morph methodsFor: 'event handling'!doubleClick: evt    "Handle a double-click event. This message is only sent to clients that request it by sending #waitForClicksOrDrag:event: to the initiating hand in their mouseDown: method. This default implementation does nothing."! !!Morph methodsFor: 'event handling'!drag: evt    "Handle a double-click event. This message is only sent to clients that request it by sending #waitForClicksOrDrag:event: to the initiating hand in their mouseDown: method. This default implementation does nothing."! !!Morph methodsFor: 'event handling'!handlesMouseDown: evt    "Return true if this morph handles mouse events (mouseDown, mouseMove, mouseUp) itself or if its event handler does. Subclasses that implement mouse events typically override this message."    eventHandler ifNotNil: [^ eventHandler handlesMouseDown: evt].    ^ false! !!Morph methodsFor: 'event handling' stamp: 'tk 5/22/97'!handlesMouseOver: evt    "Do I respond to mouseDown, mouseStillDown, or mouseUp?  "    eventHandler ifNotNil: [^ eventHandler handlesMouseOver: evt].    ^ false! !!Morph methodsFor: 'event handling'!keyboardFocusChange: aBoolean    "The message is sent to a morph when its keyboard focus change. The given argument indicates that the receiver is gaining keyboard focus (versus losing) the keyboard focus. Morphs that accept keystrokes should change their appearance in some way when they are the current keyboard focus. This default implementation does nothing."! !!Morph methodsFor: 'event handling'!keyStroke: anEvent    "Handle a keystroke event.  The default response is to let my eventHandler, if any, handle it."    eventHandler ifNotNil:        [eventHandler keyStroke: anEvent fromMorph: self].! !!Morph methodsFor: 'event handling'!mouseDown: evt    "Handle a mouse down event. The default response is to let my eventHandler, if any, handle it."    eventHandler ifNotNil:        [eventHandler mouseDown: evt fromMorph: self].! !!Morph methodsFor: 'event handling'!mouseEnter: evt    "Handle a mouseEnter event, meaning the mouse just entered my bounds with no button pressed. The default response is to let my eventHandler, if any, handle it."    eventHandler ifNotNil:        [eventHandler mouseEnter: evt fromMorph: self].! !!Morph methodsFor: 'event handling'!mouseLeave: evt    "Handle a mouseLeave event, meaning the mouse just left my bounds with no button pressed. The default response is to let my eventHandler, if any, handle it."    eventHandler ifNotNil:        [eventHandler mouseLeave: evt fromMorph: self].! !!Morph methodsFor: 'event handling'!mouseMove: evt    "Handle a mouse move event. The default response is to let my eventHandler, if any, handle it."    eventHandler ifNotNil:        [eventHandler mouseStillDown: evt fromMorph: self].! !!Morph methodsFor: 'event handling'!mouseUp: evt    "Handle a mouse up event. The default response is to let my eventHandler, if any, handle it."    eventHandler ifNotNil:        [eventHandler mouseUp: evt fromMorph: self].! !!Morph methodsFor: 'event handling'!on: eventName send: selector to: recipient    eventHandler ifNil: [eventHandler _ EventHandler new].    eventHandler on: eventName send: selector to: recipient! !!Morph methodsFor: 'event handling' stamp: '6/9/97 06:22 di'!on: eventName send: selector to: recipient withValue: value    "NOTE: selector must take 3 arguments, of which value will be the 3rd"    eventHandler ifNil: [eventHandler _ EventHandler new].    eventHandler on: eventName send: selector to: recipient withValue: value! !!Morph methodsFor: 'event handling'!passToEventHandler: evt    "Pass the given event to my event handler, if any."    eventHandler ifNotNil:        [eventHandler handleEvent: evt fromMorph: self].! !!Morph methodsFor: 'event handling'!transformFrom: uberMorph    "Return a transform to be used to map coordinates in a morph above me into my local coordinates, or vice-versa. This is used to support scrolling, scaling, and/or rotation. This default implementation just returns my owner's transform or the identity transform if my owner is nil."    owner == uberMorph ifTrue: [^ MorphicTransform identity].    owner ifNil: [^ MorphicTransform identity].    ^ owner transformFrom: uberMorph! !!Morph methodsFor: 'event handling'!transformFromWorld    "Return a transform to map world coordinates into my local coordinates"    ^ self transformFrom: nil! !!Morph methodsFor: 'stepping'!startStepping    "Start getting sent the 'step' message."    | w |    self step.  "one to get started!!"    w _ self world.    w ifNotNil: [        w startStepping: self.        self changed].! !!Morph methodsFor: 'stepping'!step    "Do some periodic activity. Use startStepping/stopStepping to start and stop getting sent this message. The time between steps is specified by this morph's answer to the stepTime message. This default implementation does nothing."! !!Morph methodsFor: 'stepping'!stepTime    "Answer the desired time between steps in milliseconds. This default implementation requests that the 'step' method be called once every second."    ^ 1000! !!Morph methodsFor: 'stepping'!stopStepping    "Stop getting sent the 'step' message."    | w |    w _ self world.    w ifNotNil: [        w stopStepping: self.        self changed].! !!Morph methodsFor: 'stepping'!wantsSteps    "Return true if the receiver overrides the default Morph step method."    "Details: Find first class in superclass chain that implements #step and return true if it isn't class Morph."    | c |    c _ self class.    [c includesSelector: #step] whileFalse: [c _ c superclass].    ^ c ~= Morph! !!Morph methodsFor: 'menu' stamp: 'di 6/29/97 09:51'!addCustomMenuItems: aCustomMenu hand: aHandMorph    "Add morph-specific items to the given menu which was invoked by the given hand."! !!Morph methodsFor: 'layout'!minHeight    "Return the minimum width for this morph. Ordinary morphs just answer their current height."    ^ self fullBounds height! !!Morph methodsFor: 'layout'!minWidth    "Return the minimum width for this morph. Ordinary morphs just answer their current width."    ^ self fullBounds width! !!Morph methodsFor: 'change reporting'!changed    "Report that the area occupied by this morph should be redrawn."    self invalidRect: self fullBounds.! !!Morph methodsFor: 'change reporting'!invalidRect: damageRect    owner ifNotNil: [owner invalidRect: damageRect].! !!Morph methodsFor: 'change reporting'!layoutChanged    "Note that something has changed about the size, shape, or location of the receiver or one of its submorphs, so that fullBounds must be recomputed."    fullBounds ifNotNil: [        self invalidRect: fullBounds].  "invalidate with old fullBounds in case shrinking"    fullBounds _ nil.    owner ifNotNil: [owner layoutChanged].! !!Morph methodsFor: 'printing'!colorString: aColor    aColor == nil ifTrue: [^ 'nil'].    Color colorNames do: [:colorName | aColor = (Color perform: colorName)                                ifTrue: [^ 'Color ' , colorName]].    ^ aColor storeString! !!Morph methodsFor: 'printing'!constructorString    ^ String streamContents: [:s | self printConstructorOn: s indent: 0].! !!Morph methodsFor: 'printing'!fullPrintOn: aStream    aStream nextPutAll: self class name , ' newBounds: (';        print: bounds;        nextPutAll: ') color: ' , (self colorString: color)! !!Morph methodsFor: 'printing'!initString    ^ String streamContents: [:s | self fullPrintOn: s]! !!Morph methodsFor: 'printing'!printConstructorOn: aStream indent: level    ^ self printConstructorOn: aStream indent: level nodeDict: IdentityDictionary new! !!Morph methodsFor: 'printing'!printConstructorOn: aStream indent: level nodeDict: nodeDict    | nodeString |    (nodeString _ nodeDict at: self ifAbsent: [nil])        ifNotNil: [^ aStream nextPutAll: nodeString].    submorphs isEmpty ifFalse: [aStream nextPutAll: '('].    aStream nextPutAll: '('.    self fullPrintOn: aStream.    aStream nextPutAll: ')'.    submorphs isEmpty ifTrue: [^ self].    submorphs size <= 4    ifTrue:        [aStream crtab: level+1;            nextPutAll: 'addAllMorphs: (Array'.        1 to: submorphs size do:            [:i | aStream crtab: level+1; nextPutAll: 'with: '.            (submorphs at: i) printConstructorOn: aStream indent: level+1 nodeDict: nodeDict].        aStream nextPutAll: '))']    ifFalse:        [aStream crtab: level+1;            nextPutAll: 'addAllMorphs: ((Array new: ', submorphs size printString, ')'.        1 to: submorphs size do:            [:i |            aStream crtab: level+1; nextPutAll: 'at: ', i printString, ' put: '.            (submorphs at: i) printConstructorOn: aStream indent: level+1 nodeDict: nodeDict.            aStream nextPutAll: ';'].        aStream crtab: level+1; nextPutAll: 'yourself))']! !!Morph methodsFor: 'printing'!printOn: aStream    | string |    super printOn: aStream.    string _ self findA: StringMorph.    aStream nextPutAll: '('.    string ifNotNil: [            aStream print: string contents; space].     aStream print: self identityHash;            nextPutAll: ')'.! !!Morph methodsFor: 'e-toy commands' stamp: 'jm 9/12/97 17:21'!beep    (SampledSound new        setSamples: SampledSound coffeeCupClink        samplingRate: 1500) play.! !!Morph methodsFor: 'e-toy commands'!bounce    | box |    (owner == nil or: [owner isHandMorph]) ifTrue: [^ self].    box _ owner bounds.    (self left < box left) ifTrue: [self headRight].    (self right > box right) ifTrue: [self headLeft].    (self top < box top) ifTrue: [self headDown].    (self bottom > box bottom) ifTrue: [self headUp].! !!Morph methodsFor: 'e-toy commands' stamp: '6/10/97 17:06 jm'!colorUnder    "Return the color of under the receiver's center."    ^ self world colorAt: self center belowMorph: self! !!Morph methodsFor: 'e-toy commands'!commandsWithDefaultArgs    "Return a list of (command arg1 arg2 ...) arrays where each command is followed by the default values for is parameters."    | r |    r _ OrderedCollection new.    r add: #(beep).    r add: #(bounce).    r add: #(colorUnder).    r add: #(forward: 15)."    r add: #(headToward:)."    r add: #(hide).    r add: (Array with: #jumpTo: with: 10@10).    r add: #(show)."    r add: #(start).""    r add: #(stop)."    r add: #(turn: 15).    r add: #(#wearCostume:).    r add: #(wrap).    ^ r! !!Morph methodsFor: 'e-toy commands'!decr: aPointOrNumber    "Decrement my position."    self forward: aPointOrNumber negated.! !!Morph methodsFor: 'e-toy commands'!forward: dist    "Let my owner decide how I move."    owner move: self forwardBy: dist heading: self heading.! !!Morph methodsFor: 'e-toy commands'!headToward: aMorph    "Does nothing by default."! !!Morph methodsFor: 'e-toy commands'!hide    "Move this morph way, way offstage!!"    self position < (5000@5000) ifTrue: [        self position: self position + (1000000@100000)].! !!Morph methodsFor: 'e-toy commands'!incr: aPointOrNumber    "Increment my position."    self forward: aPointOrNumber.! !!Morph methodsFor: 'e-toy commands'!jumpTo: aPoint    "Let my owner decide how I move."    owner move: self toPosition: aPoint.! !!Morph methodsFor: 'e-toy commands'!set: aPointOrNumber    "Set my position."    self jumpTo: aPointOrNumber.! !!Morph methodsFor: 'e-toy commands'!show    "Make sure this morph is on-stage."    (self fullBounds intersects: self world bounds) ifFalse: [        self position: self position - (1000000@100000).        self wrap].  "be sure I'm on-stage"! !!Morph methodsFor: 'e-toy commands'!start    "Start running my script. For ordinary morphs, this means start stepping."    self startStepping.! !!Morph methodsFor: 'e-toy commands'!stop    "Stop running my script. For ordinary morphs, this means stop stepping."    self stopStepping.! !!Morph methodsFor: 'e-toy commands'!turn: degrees    "Note: This command may do nothing for some kinds of morph."    self rotationDegrees:        (self rotationDegrees + (self asAngleInDegrees: degrees)) \\ 360.0.! !!Morph methodsFor: 'e-toy commands'!wearCostume: aMorph    "If the receiver and argument are both kinds of SketchMorph, make the receiver wear the costume of the argument. Otherwise, do nothing. This default implementation does nothing."! !!Morph methodsFor: 'e-toy commands'!wrap    | myBox box newX newY |    owner ifNil: [^ self].    myBox _ self fullBounds.    box _ owner bounds.    newX _ self position x.    newY _ self position y.    ((myBox right < box left) or: [myBox left > box right])        ifTrue: [newX _ box left + ((self position x - box left) \\ box width)].    ((myBox bottom < box top) or: [myBox top > box bottom])        ifTrue: [newY _ box top + ((self position y - box top) \\ box height)].    self position: newX@newY.! !!Morph methodsFor: 'e-toy support'!asAngleInDegrees: aPointOrNumber    "Support for e-toy demo."    aPointOrNumber class = Point        ifTrue: [^ aPointOrNumber theta]        ifFalse: [^ aPointOrNumber asFloat].! !!Morph methodsFor: 'e-toy support'!asNumber: aPointOrNumber    "Support for e-toy demo."    aPointOrNumber class = Point        ifTrue: [^ aPointOrNumber r]        ifFalse: [^ aPointOrNumber].! !!Morph methodsFor: 'e-toy support'!buttonsForCommands    "Return a list of buttons from my commands."    | cmd args s |    ^ self commandsWithDefaultArgs collect: [:entry |        cmd _ entry first asSymbol.        args _ entry allButFirst.        s _ WriteStream on: ''.        s nextPutAll: cmd; space.        args do: [:arg | s nextPutAll: arg printString; space].        s position: s position - 1.  "remove trailing space"        SimpleButtonMorph new            actionSelector: cmd;            arguments: args;            label: s contents;            target: self].! !!Morph methodsFor: 'e-toy support'!choosePartNameSilently    ^ self world model namePartSilently: self! !!Morph methodsFor: 'e-toy support'!goHome    | box |    owner ifNotNil: [        box _ owner.        self left < box left ifTrue: [self position: box left@self position y].        self right > box right ifTrue: [self position: (box right - self width)@self position y].        self top < box top ifTrue: [self position: self position x@box top].        self bottom > box bottom ifTrue: [self position: self position x@(box bottom - self height)]].! !!Morph methodsFor: 'e-toy support'!headDown    | radians |    radians _ self rotationDegrees degreesToRadians.    self rotationDegrees:        ((radians cos @ radians sin abs negated) theta radiansToDegrees            roundTo: 0.0001).! !!Morph methodsFor: 'e-toy support'!heading    "Default implementation."    ^ 0.0! !!Morph methodsFor: 'e-toy support'!headLeft    | radians |    radians _ self rotationDegrees degreesToRadians.    self rotationDegrees:        ((radians cos abs negated @ radians sin) theta radiansToDegrees            roundTo: 0.0001).! !!Morph methodsFor: 'e-toy support'!headRight    | radians |    radians _ self rotationDegrees degreesToRadians.    self rotationDegrees:        ((radians cos abs @ radians sin) theta radiansToDegrees            roundTo: 0.0001).! !!Morph methodsFor: 'e-toy support'!headUp    | radians |    radians _ self rotationDegrees degreesToRadians.    self rotationDegrees:        ((radians cos @ radians sin abs) theta radiansToDegrees            roundTo: 0.0001).! !!Morph methodsFor: 'e-toy support'!move: aMorph forwardBy: aPointOrNumber heading: headingInDegrees    "Support for e-toy demo. Move the given submorph the given amount. Allows the morph's owner to determine the policy for motion. For example, moving forward through a table might mean motion only in the x-axis with wrapping modulo the table size."    aMorph position:        aMorph position +          (Point r: (self asNumber: aPointOrNumber) degrees: headingInDegrees negated) truncated.! !!Morph methodsFor: 'e-toy support'!move: aMorph toPosition: aPointOrNumber    "Support for e-toy demo. Move the given submorph to the given position. Allows the morph's owner to determine the policy for motion. For example, moving forward through a table might mean motion only in the x-axis with wrapping modulo the table size."    aMorph position: aPointOrNumber asPoint.! !!Morph methodsFor: 'e-toy support'!nameInModel    "Return the name for this morph in the underlying model or nil."    | w |    w _ self world.    w == nil        ifTrue: [^ nil]        ifFalse: [^ w model nameFor: self].! !!Morph methodsFor: 'e-toy support'!parts    "Return an array of part names for use in e-toys."    ^ #(position)! !!Morph methodsFor: 'e-toy support'!rotationDegrees    "Default implementation."    ^ 0.0! !!Morph methodsFor: 'e-toy support'!rotationDegrees: ignored    "Default implementation that does nothing to support noop turn: command."! !!Morph methodsFor: 'e-toy support'!specialNameInModel    "Return the name for this morph in the underlying model or nil."    "Not an easy problem.  For now, take the first part of the mouseDownSelector symbol in my eventHandler (fillBrushMouseUp:morph: gives 'fillBrush').  5/26/97 tk"    | hh |    (self isKindOf: MorphicModel)        ifTrue: [^ self slotName]        ifFalse: [            eventHandler ifNotNil: [                eventHandler mouseDownSelector ifNotNil: [                    hh _ eventHandler mouseDownSelector indexOfSubCollection: 'Mouse'                                 startingAt: 1.                    hh > 0 ifTrue: [^ eventHandler mouseDownSelector copyFrom: 1 to: hh-1]].                eventHandler mouseUpSelector ifNotNil: [                    hh _ eventHandler mouseUpSelector indexOfSubCollection: 'Mouse'                                 startingAt: 1.                    hh > 0 ifTrue: [^ eventHandler mouseUpSelector copyFrom: 1 to: hh-1]].                ]].            "    (eventHandler mouseDownRecipient respondsTo: #nameFor:) ifTrue: [                    ^ eventHandler mouseDownRecipient nameFor: self]]].    "            "myModel _ self findA: MorphicModel.            myModel ifNotNil: [^ myModel slotName]"        ^ self world model nameFor: self! !!Morph methodsFor: 'model access'!choosePartName    "Pick an unused name for this morph."    | className |    className _ self class name.    (className size > 5 and: [className endsWith: 'Morph'])        ifTrue: [className _ className copyFrom: 1 to: className size - 5].    ^ self world model addPartNameLike: className withValue: self! !!Morph methodsFor: 'model access'!installModelIn: ignored    "Simple morphs have no model"    "See MorphicApp for other behavior"! !!Morph methodsFor: 'model access'!sensitize    "This needs to be integrated with naming of parts"    "Really needs to proffer a senstivity dialog"    self halt: 'under construction...'.    self on: #mouseDown send: #mouseDown:fromMorph: to: self world model! !!Morph methodsFor: 'other'!flash    | w |    w _ self world.    w ifNotNil: [        Display flash: (bounds translateBy: w viewBox origin)].! !!Morph methodsFor: 'other'!prepareToBeSaved    "Prepare the morph to be saved to disk. Subclasses should nil out any instance variables that holds state that should not be saved, such as cached Forms."    fullBounds _ nil.! !!Morph methodsFor: 'other' stamp: 'tk 5/29/97'!storeDataOn: aDataStream    "Let all Morphs be written out.  DataStream.typeIDFor: catches the ones that are outside our tree (most notably, the root's owner).  For now let everthing try to write out.  "    | cntInstVars cntIndexedVars instVars ti got |    true ifTrue: [^ super storeDataOn: aDataStream].    "keep this code in case we need to filter fields later"    owner ifNil: [^ super storeDataOn: aDataStream].    got _ aDataStream references at: owner ifAbsent: [nil].    got ifNotNil: ["My owner has already started to go out.  I am not top"        ^ super storeDataOn: aDataStream].    "block my owner"    cntInstVars _ self class instSize.    cntIndexedVars _ self basicSize.    instVars _ self class allInstVarNames.    ti _ (instVars indexOf: 'owner').    (ti = 0) ifTrue: [self error: 'this method is out of date'].    aDataStream        beginInstance: self class        size: cntInstVars + cntIndexedVars.    1 to: ti-1 do:        [:i | aDataStream nextPut: (self instVarAt: i)].    aDataStream nextPut: nil.    "owner"    ti+1 to: cntInstVars do:        [:i | aDataStream nextPut: (self instVarAt: i)].    1 to: cntIndexedVars do:        [:i | aDataStream nextPut: (self basicAt: i)]! !!Morph methodsFor: 'private'!copyRecordingIn: dict    "Recursively copy this entire composite morph, recording the correspondence between old and new morphs in the given dictionary. This dictionary will be used to update intra-composite references in the copy."    | new |    new _ self copy.    submorphs size > 0 ifTrue: [        new privateSubmorphs:            (submorphs collect: [:m |                (m copyRecordingIn: dict) privateOwner: new])].    dict at: self put: new.    ^ new! !!Morph methodsFor: 'private'!copyWithoutSubmorphs    ^ self clone        privateOwner: nil;        privateSubmorphs: EmptyArray;        privateBounds: (bounds origin corner: bounds corner)  "deep-copy bounds"! !!Morph methodsFor: 'private'!privateAddMorph: aMorph atIndex: index    ((index >= 1) and: [index <= (submorphs size + 1)])        ifFalse: [^ self error: 'index out of range'].    aMorph owner ifNotNil: [aMorph owner privateRemoveMorph: aMorph].    aMorph layoutChanged.    aMorph privateOwner: self.    submorphs _ submorphs copyReplaceFrom: index to: index-1 with: (Array with: aMorph).    self layoutChanged.! !!Morph methodsFor: 'private'!privateBounds: boundsRect    "Private!! Use position: and/or extent: instead."    fullBounds _ nil.    bounds _ boundsRect.! !!Morph methodsFor: 'private'!privateMoveBy: delta    "Private!! Use 'position:' instead."    bounds _ bounds translateBy: delta.    fullBounds _ nil.! !!Morph methodsFor: 'private'!privateOwner: aMorph    "Private!! Should only be used by methods that maintain the ower/submorph invariant."    owner _ aMorph.! !!Morph methodsFor: 'private'!privateRemoveMorph: aMorph    "Private!! Should only be used by methods that maintain the ower/submorph invariant."    aMorph changed.    submorphs _ submorphs copyWithout: aMorph.    self layoutChanged.! !!Morph methodsFor: 'private'!privateSubmorphs    "Private!! Use 'submorphs' instead."    ^ submorphs! !!Morph methodsFor: 'private'!privateSubmorphs: aCollection    "Private!! Should only be used by methods that maintain the ower/submorph invariant."    submorphs _ aCollection.! !!Morph class methodsFor: 'instance creation' stamp: 'di 6/22/97 09:07'!includeInNewMorphMenu    "Return true for all classes that can be instantiated from the menu"    ^ true! !!Morph class methodsFor: 'instance creation'!new    ^ super new initialize! !!Morph class methodsFor: 'instance creation'!newBounds: bounds    ^ self new privateBounds: bounds! !!Morph class methodsFor: 'instance creation'!newBounds: bounds color: color    ^ (self new privateBounds: bounds) color: color! !!Morph class methodsFor: 'instance creation'!newExtent: extent    ^ self new privateBounds: (0@0 extent: extent)! !!Morph class methodsFor: 'class initialization'!initialize    "Morph initialize"    "this empty array object is shared by all morphs with no submorphs:"    EmptyArray _ Array new.! !!Morph class methodsFor: 'project management'!fileOutProject   "Morph fileOutProject"    "Note: This procedure assumes that all project classes are in system    categories of the form 'Morphic-Category'.  It operates as follows:    1.  It files out each category of the form 'Morphic-Category'.    2.  It removes all changes that are NOT in any of those classes.    3.  It files out the remaining changes as 'Morphic-Changes.st'."    "When you fileIn the project, you should do it as fillows:    1.  FileIn all files of the form 'Morphic-Category.st'.    2.  Clear your changeSet.    3.  FileIn the file 'Morphic-Changes.st'."    (PopUpMenu confirm: 'Did you remember to update the version numberby renaming the Morphic-vNN category??') ifFalse: [^ self].    (SystemOrganization categories select: [:cat | 'Morph*' match: cat]) do:        [:cat | SystemOrganization fileOutCategory: cat.        (SystemOrganization superclassOrder: cat) do:            [:cls | cls removeFromChanges]].    (FileStream newFileNamed: 'Morphic-Changes.st') fileOutChanges.! !!MorphicEvent methodsFor: 'initialization'!initialize    type _ #unknown.    cursorPoint _ 0@0.    buttons _ 0.    keyValue _ 0.    sourceHand _ nil.! !!MorphicEvent methodsFor: 'accessing'!buttons    "Return the a word encoding the mouse and modifier buttons for this event."    ^ buttons! !!MorphicEvent methodsFor: 'accessing'!hand    "Return the hand that originated this event."    ^ sourceHand! !!MorphicEvent methodsFor: 'accessing'!type    "Return a symbol indicating the type this event."    ^ type! !!MorphicEvent methodsFor: 'classification'!isKeystroke    ^ type == #keystroke! !!MorphicEvent methodsFor: 'classification'!isMouse    ^ (type == #mouseMove) | (type == #mouseDown) | (type == #mouseUp)! !!MorphicEvent methodsFor: 'classification'!isMouseDown    ^ type == #mouseDown! !!MorphicEvent methodsFor: 'classification'!isMouseMove    ^ type == #mouseMove! !!MorphicEvent methodsFor: 'classification'!isMouseUp    ^ type == #mouseUp! !!MorphicEvent methodsFor: 'equality' stamp: 'jm 9/24/97 13:05'!= aMorphicEvent    (aMorphicEvent isKindOf: self class) ifFalse: [^ false].    type = aMorphicEvent type ifFalse: [^ false].    cursorPoint = aMorphicEvent cursorPoint ifFalse: [^ false].    buttons = aMorphicEvent buttons ifFalse: [^ false].    keyValue = aMorphicEvent keyValue ifFalse: [^ false].    ^ true! !!MorphicEvent methodsFor: 'equality' stamp: 'jm 9/24/97 13:06'!hash    ^ cursorPoint hash + buttons hash + keyValue hash! !!MorphicEvent methodsFor: 'mouse'!anyButtonPressed    "Answer true if any mouse button is being pressed."    ^ buttons anyMask: 7! !!MorphicEvent methodsFor: 'mouse'!blueButtonPressed    "Answer true if the blue mouse button is being pressed."    ^ buttons anyMask: 1! !!MorphicEvent methodsFor: 'mouse'!cursorPoint    "Answer the location of the cursor's hotspot when this event occured."    ^ cursorPoint! !!MorphicEvent methodsFor: 'mouse'!redButtonPressed    "Answer true if the red mouse button is being pressed."    ^ buttons anyMask: 4! !!MorphicEvent methodsFor: 'mouse'!targetPoint    "Answer the location of the cursor's hotspot, adjusted by the offset    of the last mouseDown relative to the recipient morph."    ^ cursorPoint - sourceHand targetOffset! !!MorphicEvent methodsFor: 'mouse'!transformedBy: aMorphicTransform    "Return a copy of the receiver transformed by the given transformation."    aMorphicTransform isIdentity ifTrue: [^ self].  "no transformation needed"    ^ self copy setCursorPoint: (aMorphicTransform transform: cursorPoint)! !!MorphicEvent methodsFor: 'mouse'!yellowButtonPressed    "Answer true if the yellow mouse button is being pressed."    ^ buttons anyMask: 2! !!MorphicEvent methodsFor: 'keyboard'!commandKeyPressed    "Answer true if the command key on the keyboard was being held down when this event occurred."    ^ buttons anyMask: 64! !!MorphicEvent methodsFor: 'keyboard'!controlKeyPressed    "Answer true if the control key on the keyboard was being held down when this event occurred."    ^ buttons anyMask: 16! !!MorphicEvent methodsFor: 'keyboard'!keyCharacter    "Answer the character corresponding this keystroke. This is defined only for keystroke events."    ^ keyValue asCharacter! !!MorphicEvent methodsFor: 'keyboard'!keyValue    "Answer the ascii value for this keystroke. This is defined only for keystroke events."    ^ keyValue! !!MorphicEvent methodsFor: 'keyboard'!optionKeyPressed    "Answer whether the option key on the keyboard was being held down when this event occurred."    ^ buttons anyMask: 32! !!MorphicEvent methodsFor: 'keyboard'!shiftPressed    "Answer true if either the left or right shift key on the keyboard was being held down when this event occurred."    ^ buttons anyMask: 8! !!MorphicEvent methodsFor: 'printing'!printOn: aStream    aStream nextPut: $[.    aStream nextPutAll: self cursorPoint printString; space.    aStream nextPutAll: type.    self isKeystroke ifTrue: [        self controlKeyPressed ifTrue: [            aStream nextPutAll: ' ''^'.            aStream nextPut: (keyValue + $a asciiValue - 1) asCharacter.        ] ifFalse: [            aStream nextPutAll: ' '''.            aStream nextPut: self keyCharacter.        ].        aStream nextPut: $'.    ].    aStream nextPut: $].! !!MorphicEvent methodsFor: 'printing' stamp: 'jm 9/24/97 12:23'!storeOn: aStream    aStream nextPutAll: type.    aStream space.    cursorPoint x storeOn: aStream.    aStream space.    cursorPoint y storeOn: aStream.    aStream space.    buttons storeOn: aStream.    aStream space.    keyValue storeOn: aStream.! !!MorphicEvent methodsFor: 'private'!setCursorPoint: aPoint    "Used for transforming events."    cursorPoint _ aPoint.! !!MorphicEvent methodsFor: 'private' stamp: 'jm 9/24/97 12:51'!setHand: aHandMorph    "Set the hand that originated this event."    sourceHand _ aHandMorph.! !!MorphicEvent methodsFor: 'private'!setKeyValue: keyVal mousePoint: aPoint buttons: anInteger hand: hand    type _ #keystroke.    cursorPoint _ aPoint.    buttons _ anInteger.    keyValue _ keyVal.    sourceHand _ hand.! !!MorphicEvent methodsFor: 'private'!setMousePoint: aPoint buttons: anInteger lastEvent: lastEvent hand: hand    cursorPoint _ aPoint.    buttons _ anInteger.    keyValue _ 0.    sourceHand _ hand.    self anyButtonPressed ifTrue: [        lastEvent anyButtonPressed            ifTrue: [type _ #mouseMove]            ifFalse: [type _ #mouseDown].    ] ifFalse: [        lastEvent anyButtonPressed            ifTrue: [type _ #mouseUp]            ifFalse: [type _ #mouseMove]].! !!MorphicEvent methodsFor: 'private'!setType: newType    type _ newType.! !!MorphicEvent methodsFor: 'private' stamp: 'jm 9/24/97 12:25'!setType: t cursorPoint: p buttons: b keyValue: k    type _ t.    cursorPoint _ p.    buttons _ b.    keyValue _ k.    sourceHand _ nil.! !!MorphicEvent class methodsFor: 'instance creation'!new    ^ super new initialize! !!MorphicEvent class methodsFor: 'instance creation' stamp: 'jm 9/25/97 09:29'!newWorldExtent: aPoint    "Answer an event that records a WorldMorph window size change."    ^ self basicNew setType: #worldExtent        cursorPoint: aPoint        buttons: 0        keyValue: 0! !!MorphicEvent class methodsFor: 'instance creation' stamp: 'jm 9/24/97 13:18'!readFrom: aStream    "Read a MorphicEvent from the given stream."    | s type x y buttons keyValue |    s _ WriteStream on: ''.    [aStream peek isLetter] whileTrue: [s nextPut: aStream next].    type _ s contents asSymbol.    aStream skip: 1.    x _ Integer readFrom: aStream.    aStream skip: 1.    y _ Integer readFrom: aStream.    aStream skip: 1.    buttons _ Integer readFrom: aStream.    aStream skip: 1.    keyValue _ Integer readFrom: aStream.    ^ self basicNew setType: type        cursorPoint: x@y        buttons: buttons        keyValue: keyValue! !MorphicModel comment:'MorphicModels are used to represent structures with state and behavior as well as graphical structure.  A morphicModel is usually the root of a morphic tree depicting its appearance.  The tree is constructed concretely by adding its consituent morphs to a world.When a part is named in a world, it is given a new slot in the model.  When a part is sensitized, it is named, and a set of mouse-driven methods is also generated in the model.  These may be edited to induce particular behavior.  When a variable is added through the morphic world, it is given a slot in the model, along with a set of access methods.In addition for public variables (and this is the default for now), methods are generated and called in any outer model in which this model gets embedded, thus propagating variable changes outward.'!!MorphicModel methodsFor: 'initialization'!delete    model ifNil: [^ super delete].    (PopUpMenu confirm:'Shall I remove the slot ', slotName, 'along with all associated methods?') ifTrue: [        (model class selectors select: [:s | s beginsWith: slotName])            do: [:s | model class removeSelector: s].        (model class instVarNames includes: slotName)            ifTrue: [model class removeInstVarName: slotName].    ] ifFalse: [        (PopUpMenu confirm:'...but should I at least dismiss this morph?[choose no to leave everything unchanged]')            ifFalse: [^ self]].    super delete.! !!MorphicModel methodsFor: 'initialization' stamp: 'tk 4/15/97'!duplicate: newGuy from: oldGuy    "oldGuy has just been duplicated and will stay in this world.  Make sure all the MorphicModel requirements are carried out for the copy.  Ask user to rename it.  "    newGuy installModelIn: oldGuy world.    newGuy copySlotMethodsFrom: oldGuy slotName.! !!MorphicModel methodsFor: 'initialization' stamp: 'di 7/17/97 10:32'!initialize    super initialize.    open _ false.    bounds _ 0@0 corner: 200@100.    self color: Color transparent;        setBorderWidth: 2 borderColor: Color yellow.! !!MorphicModel methodsFor: 'initialization' stamp: 'di 6/21/97 13:25'!model: thang slotName: nameOfThisPart    model _ thang.    slotName _ nameOfThisPart.    open _ false.! !!MorphicModel methodsFor: 'access'!model     ^ model! !!MorphicModel methodsFor: 'access'!slotName    ^ slotName! !!MorphicModel methodsFor: 'access' stamp: '6/7/97 10:40 di'!wantsSlot    "Override this default for models that want to be installed in theri model"    ^ false! !!MorphicModel methodsFor: 'geometry'!newBounds: newBounds    self bounds: newBounds! !!MorphicModel methodsFor: 'geometry'!recomputeBounds    | bnds |    bnds _ submorphs first bounds.    bounds _ bnds origin corner: bnds corner. "copy it!!"    fullBounds _ nil.    bounds _ self fullBounds.! !!MorphicModel methodsFor: 'printing'!initString    ^ String streamContents:        [:s | s nextPutAll: self class name;            nextPutAll: ' newBounds: (';            print: bounds;            nextPutAll: ') model: self slotName: ';            print: slotName]! !!MorphicModel methodsFor: 'compilation'!addPartNameLike: className withValue: aMorph    | otherNames i default partName stem |    stem _ className first asLowercase asString , className allButFirst.    otherNames _ self class allInstVarNames.    i _ 1.    [otherNames includes: (default _ stem, i printString)]        whileTrue: [i _ i + 1].    partName _ FillInTheBlank        request: 'Please give this part a name'        initialAnswer: default.    (otherNames includes: partName)        ifTrue: [self inform: 'Sorry, that name is already used'. ^ nil].    self class addInstVarName: partName.    self instVarAt: self class instSize put: aMorph.  "Assumes added as last field"    ^ partName! !!MorphicModel methodsFor: 'compilation' stamp: 'tk 4/15/97'!choosePartName    "When I am renamed, get a slot, make default methods, move any existing methods.  ** Does not clean up old inst var name or methods**  "    | old |    old _ slotName.    super choosePartName.    slotName ifNil: [^ self].  "user chose bad slot name"    self model: self world model slotName: slotName.    old == nil         ifTrue: [self compilePropagationMethods]        ifFalse: [self copySlotMethodsFrom: old].            "old ones not erased!!"! !!MorphicModel methodsFor: 'compilation' stamp: 'tk 4/18/97'!compileAccessForSlot: aSlotName    "Write the method to get at this inst var.  "    "Instead call the right thing to make this happen?"    | s  |    s _ WriteStream on: (String new: 2000).    s nextPutAll: aSlotName; cr; tab; nextPutAll: '^', aSlotName.    self class        compile: s contents        classified: 'public access'        notifying: nil.! !!MorphicModel methodsFor: 'compilation'!compileInitMethods    | s nodeDict varNames |    nodeDict _ IdentityDictionary new.    s _ WriteStream on: (String new: 2000).    varNames _ self class allInstVarNames.    s nextPutAll: 'initMorph'.    3 to: self class instSize do:        [:i | (self instVarAt: i) isMorph ifTrue:            [s cr; tab; nextPutAll: (varNames at: i) , ' _ '.            s nextPutAll: (self instVarAt: i) initString; nextPutAll: '.'.            nodeDict at: (self instVarAt: i) put: (varNames at: i)]].    submorphs do:         [:m | s cr; tab; nextPutAll: 'self addMorph: '.        m printConstructorOn: s indent: 1 nodeDict: nodeDict.        s nextPutAll: '.'].    self class        compile: s contents        classified: 'initialization'        notifying: nil.! !!MorphicModel methodsFor: 'compilation'!compilePropagationMethods    | varName |    (self class organization listAtCategoryNamed: 'private - propagation' asSymbol)        do: [:sel | varName _ sel allButLast.            model class compilePropagationForVarName: varName slotName: slotName]! !!MorphicModel methodsFor: 'compilation' stamp: '6/7/97 10:43 di'!installModelIn: aWorld    self wantsSlot ifFalse: [^ self].  "No real need to install"    slotName _ aWorld model addPartNameLike: self class name withValue: self.    slotName ifNil: [^ self].  "user chose bad slot name"    self model: aWorld model slotName: slotName.    self compilePropagationMethods.    aWorld model compileAccessForSlot: slotName.! !!MorphicModel methodsFor: 'compilation'!nameFor: aMorph    "Return the name of the slot containing the given morph or nil if that morph has not been named."    | allNames start |    allNames _ self class allInstVarNames.    start _ MorphicModel allInstVarNames size + 1.    start to: allNames size do: [:i |        (self instVarAt: i) == aMorph ifTrue: [^ allNames at: i]].    ^ nil! !!MorphicModel methodsFor: 'compilation'!namePartSilently: aMorph    | stem otherNames i partName |    stem _ aMorph class name.    (stem size > 5 and: [stem endsWith: 'Morph'])        ifTrue: [stem _ stem copyFrom: 1 to: stem size - 5].    stem _ stem first asLowercase asString, stem allButFirst.    otherNames _ self class allInstVarNames.    i _ 1.    [otherNames includes: (partName _ stem, i printString)]        whileTrue: [i _ i + 1].    self class addInstVarName: partName.    self instVarAt: self class instSize put: aMorph.  "assumes added as last field"    ^ partName! !!MorphicModel methodsFor: 'compilation'!propagate: value as: partStoreSelector    model ifNil: [^ self]."    Later we can cache this for more speed as follows...    (partName == cachedPartName and: [slotName == cachedSlotName])        ifFalse: [cachedPartName _ partName.                cachedSlotName _ slotName.                cachedStoreSelector _ (slotName , partStoreSelector) asSymbol].    model perform: cachedStoreSelector with: value]."    model perform: (self slotSelectorFor: partStoreSelector) with: value! !!MorphicModel methodsFor: 'compilation'!slotSelectorFor: selectorBody    | selector |    model ifNil: [^ nil].    "Make up selector from slotname if any"    selector _ (slotName ifNil: [selectorBody]                    ifNotNil: [slotName , selectorBody]) asSymbol.    (model canUnderstand: selector) ifFalse:        [self halt: 'Compiling a null response for ' , model class name , '>>' , selector].    ^ selector! !!MorphicModel methodsFor: 'compilation'!use: cachedSelector orMakeModelSelectorFor: selectorBody in: selectorBlock    | selector |    model ifNil: [^ nil].    cachedSelector ifNil:            ["Make up selector from slotname if any"            selector _ (slotName ifNil: [selectorBody]                                ifNotNil: [slotName , selectorBody]) asSymbol.            (model class canUnderstand: selector) ifFalse:                [(self confirm: 'Shall I compile a null response for'                            , Character cr asString                            , model class name , '>>' , selector)                        ifFalse: [self halt].                model class compile: (String streamContents:                                [:s | selector keywords doWithIndex:                                        [:k :i | s nextPutAll: k , ' arg' , i printString].                                s cr; nextPutAll: '"Automatically generated null response."'.                                s cr; nextPutAll: '"Add code below for appropriate behavior..."'.])                            classified: 'input events'                            notifying: nil]]        ifNotNil:            [selector _ cachedSelector].    ^ selectorBlock value: selector! !!MorphicModel methodsFor: 'drag and drop' stamp: 'di 6/22/97 23:17'!allowSubmorphExtraction    ^ self isOpen! !!MorphicModel methodsFor: 'drag and drop' stamp: 'di 6/22/97 23:16'!isOpen    "Support drag/drop and other edits."    ^ open! !!MorphicModel methodsFor: 'drag and drop' stamp: 'di 6/22/97 23:17'!openToDragNDrop    "Support drag/drop when open to edits."    ^ self isOpen! !!MorphicModel methodsFor: 'drag and drop' stamp: 'di 6/22/97 23:17'!wantsDroppedMorph: aMorph event: evt    "Supports adding morphs by dropping."    ^ self isOpen! !!MorphicModel methodsFor: 'menu' stamp: 'di 6/20/97 15:39'!addCustomMenuItems: aCustomMenu hand: aHandMorph    super addCustomMenuItems: aCustomMenu hand: aHandMorph.    self isOpen ifTrue: [aCustomMenu add: 'close editing' action: #closeToEdits]            ifFalse: [aCustomMenu add: 'open editing' action: #openToEdits].! !!MorphicModel methodsFor: 'menu' stamp: 'di 6/20/97 15:36'!closeToEdits    "Disable this morph's ability to add and remove morphs via drag-n-drop."    open _ false! !!MorphicModel methodsFor: 'menu' stamp: 'di 6/20/97 15:36'!openToEdits    "Enable this morph's ability to add and remove morphs via drag-n-drop."    open _ true! !!MorphicModel class methodsFor: 'instance creation' stamp: 'di 6/22/97 22:28'!includeInNewMorphMenu    "Dont include until it has at least been given a name"    ^ self == MorphicModel or: [(self name beginsWith: 'MorphicModel') not]! !!MorphicModel class methodsFor: 'instance creation' stamp: 'di 6/22/97 09:26'!new    "Return a copy of the prototype, if there is one.    Otherwise create a new instance normally."    self hasPrototype ifTrue: [^ prototype fullCopy].    ^ super new! !!MorphicModel class methodsFor: 'instance creation' stamp: 'di 6/22/97 09:27'!newBounds: bounds model: thang slotName: nameOfThisPart    ^ (super new model: thang slotName: nameOfThisPart)        newBounds: bounds! !!MorphicModel class methodsFor: 'compilation'!chooseNewName    "Rename this class."    | oldName newName |    oldName _ self name.        [newName _ (FillInTheBlank request: 'Please give this Model a name'                    initialAnswer: oldName) asSymbol.        newName = oldName ifTrue: [^ self].        Smalltalk includesKey: newName]        whileTrue:        [PopUpMenu notify: 'Sorry, that name is already in use.'].    self rename: newName.! !!MorphicModel class methodsFor: 'compilation'!compileAccessorsFor: varName    self compile: ('&var    "Return the value of &var"    ^ &var'            copyReplaceAll: '&var' with: varName)        classified: 'public access' notifying: nil.    self compile: ('&varPut: newValue    "Assign newValue to &var.    Add code below to update related graphics appropriately..."    &var _ newValue.'            copyReplaceAll: '&var' with: varName)        classified: 'public access' notifying: nil.    self compile: ('&var: newValue    "Assigns newValue to &var and updates owner"    &var _ newValue.    self propagate: &var as: ''&var:'''            copyReplaceAll: '&var' with: varName)        classified: 'private - propagation' notifying: nil.! !!MorphicModel class methodsFor: 'compilation'!compilePropagationForVarName: varName slotName: slotName    self compile: (('&slot&var: newValue    "The value of &var in &slot has changed to newValue.    This value can be read elsewhere in code with        &slot &var    and it can be stored into with        &slot &varPut: someValue"    "Add code for appropriate response here..."'            copyReplaceAll: '&var' with: varName)            copyReplaceAll: '&slot' with: slotName)        classified: 'input events' notifying: nil.! !!MorphicModel class methodsFor: 'compilation'!newSubclass    | i className |    i _ 1.    [className _ (self name , i printString) asSymbol.     Smalltalk includesKey: className]        whileTrue: [i _ i + 1].    ^ self subclass: className        instanceVariableNames: ''        classVariableNames: ''        poolDictionaries: ''        category: 'Morphic-Models'! !!MorphicModel class methodsFor: 'queries'!hasPrototype    "Return true if there is a prototype for this morph."    ^ prototype ~~ nil! !!MorphicModel class methodsFor: 'prototype access'!prototype    "Return the prototype for this morph."    ^ prototype! !!MorphicModel class methodsFor: 'prototype access'!prototype: aMorph    "Store a copy of the given morph as a prototype to be copied to make new instances."    aMorph ifNil: [prototype _ nil. ^ self].    prototype _ aMorph fullCopy.    (prototype isKindOf: MorphicModel) ifTrue:         [prototype model: nil slotName: nil].! !!MorphicModel class methodsFor: 'housekeeping' stamp: 'jm 6/21/97 16:45'!removeUninstantiatedModels    "With the user's permission, remove the classes of any models that have neither instances nor subclasses."    "MorphicModel removeUninstantiatedModels"    | candidatesForRemoval ok |    candidatesForRemoval _        MorphicModel subclasses select: [:c |            (c instanceCount = 0) and: [c subclasses size = 0]].    candidatesForRemoval do: [:c |        ok _ self confirm: 'Are you certain that youwant to delete the class ', c name, '?'.        ok ifTrue: [c removeFromSystem]].! !MorphicTransform comment:'This class implements a simple translation scaling and rotation for points, as well as inverse transformations.'!!MorphicTransform methodsFor: 'accessing'!angle    ^ angle! !!MorphicTransform methodsFor: 'accessing'!offset    ^ offset! !!MorphicTransform methodsFor: 'accessing'!scale    ^ scale! !!MorphicTransform methodsFor: 'accessing'!withAngle: a    "Return a copy of me with a different Angle"    ^ self copy setAngle: a! !!MorphicTransform methodsFor: 'accessing'!withOffset: a    "Return a copy of me with a different Offset"    ^ self copy setOffset: a! !!MorphicTransform methodsFor: 'accessing'!withScale: a    "Return a copy of me with a different Scale"    ^ self copy setScale: a! !!MorphicTransform methodsFor: 'transformations'!composedWith: aTransform    "Return a new transform that has the effect of transforming points first by the receiver and then by the argument."    self isPureTranslation ifTrue:        [^ aTransform copy setOffset: offset + aTransform offset].    aTransform isPureTranslation ifTrue:        [^ self copy setOffset: offset + aTransform offset].self halt: 'general composition not yet implemented'! !!MorphicTransform methodsFor: 'transformations'!invert: aPoint    "Transform the given point from local to global coordinates."    | p3 p2 |    self isPureTranslation ifTrue: [^ aPoint - offset].    p3 _  aPoint * scale.    p2 _ ((p3 x * angle cos) + (p3 y * angle sin))        @ ((p3 y * angle cos) - (p3 x * angle sin)).    ^ (p2 - offset) asIntegerPoint! !!MorphicTransform methodsFor: 'transformations'!invertRect: aRectangle    ^ (self invert: aRectangle topLeft) corner: (self invert: aRectangle bottomRight)! !!MorphicTransform methodsFor: 'transformations'!isIdentity    "Return true if the receiver is the identity transform; that is, if applying to a point returns the point itself."    ^ self isPureTranslation and: [offset = (0@0)]! !!MorphicTransform methodsFor: 'transformations'!isPureTranslation    "Return true if the receiver specifies no rotation or scaling."    ^ angle = 0.0 and: [scale = 1.0]! !!MorphicTransform methodsFor: 'transformations'!sourceQuadFor: aRectangle    ^ aRectangle innerCorners collect:         [:p | self transform: p]! !!MorphicTransform methodsFor: 'transformations'!transform: aPoint    "Transform the given point from global to local coordinates."    | p2 p3 |    self isPureTranslation ifTrue: [^ aPoint + offset].    p2 _ aPoint + offset.    p3 _ (((p2 x * angle cos) - (p2 y * angle sin))        @ ((p2 y * angle cos) + (p2 x * angle sin)))            / scale.    ^ p3 asIntegerPoint! !!MorphicTransform methodsFor: 'transformations'!transformRect: aRectangle    ^ (self transform: aRectangle topLeft) corner: (self transform: aRectangle bottomRight)! !!MorphicTransform methodsFor: 'private'!setAngle: aFloat    angle _ aFloat.! !!MorphicTransform methodsFor: 'private'!setOffset: aPoint    offset _ aPoint.! !!MorphicTransform methodsFor: 'private'!setOffset: aPoint angle: a scale: s    offset _ aPoint.    angle _ a.    scale _ s! !!MorphicTransform methodsFor: 'private'!setScale: aFloat    scale _ aFloat.! !!MorphicTransform class methodsFor: 'instance creation'!identity    ^ self offset: 0@0 angle: 0.0 scale: 1.0! !!MorphicTransform class methodsFor: 'instance creation'!new    ^ self offset: 0@0! !!MorphicTransform class methodsFor: 'instance creation'!offset: aPoint    ^ self offset: aPoint angle: 0.0 scale: 1.0! !!MorphicTransform class methodsFor: 'instance creation'!offset: aPoint angle: a scale: s    ^ self basicNew setOffset: aPoint angle: a scale: s! !MorphWorldController comment:'I am a controller for SceneViews. I support gestures for scrolling, click-selection, and area selection of scene glyphs. (See the class comment in GestureController for more details about gestures.) I also support construction operations such as inserting new glyphs and merging glyphs to make them share a common point.The mapping of gestures to actions is as follows (see GestureController comment for more about gestures):  Click:    click on glyph                select glyph    shift-click on glyph            toggle selection of that glyph    click on background            clear selection  Double click:    double-click on glyph            inspect glyph    double-click on background        select all  Hold/Drag/Sweep:    hold (no movement)            yellow-button menu    drag (up/left movement)        scrolling hand    sweep (down/right movement)    select glyphs in region    shift-sweep                    toggle selection of glyphs in region'!!MorphWorldController methodsFor: 'control sequence' stamp: 'di 6/14/97 01:41'!controlActivity    "Do one step of the Morphic interaction loop. Called repeatedly while window is active."    self viewHasCursor        ifTrue: [Sensor currentCursor == Cursor blank ifFalse: [Cursor blank show]]        ifFalse: [Sensor currentCursor == Cursor normal ifFalse: [Cursor normal show]].    model doOneCycle.! !!MorphWorldController methodsFor: 'control sequence'!controlInitialize    "This window is becoming active."    view displayView.  "initializes the WorldMorph's canvas"    "hide the hardware cursor, since hand will draw it"    Cursor blank show.    model hands do: [:h | h initForEvents].! !!MorphWorldController methodsFor: 'control sequence' stamp: 'di 6/19/97 12:36'!controlLoop     | outAndMouseUp |    sensor leftShiftDown ifTrue:        ["Hold shift down when activating a Morphic window to take stats"        (self confirm: 'The shift key was down;do you really want to spy on Morphic?') ifTrue:            [^ MessageTally spyOn: [super controlLoop. Cursor normal show]]].    "Overridden to keep control active when mouse leaves the view..."    outAndMouseUp _ false.    [outAndMouseUp and: [Sensor anyButtonPressed]]        whileFalse:        [self controlActivity. Processor yield.        self viewHasCursor            ifTrue: [outAndMouseUp _ false]            ifFalse: [outAndMouseUp _ outAndMouseUp | Sensor noButtonPressed]]! !!MorphWorldController methodsFor: 'control sequence' stamp: 'di 6/24/97 14:12'!controlTerminate     "This window is becoming inactive..."    Cursor normal show.  "restore the normal cursor"    model hands do: [:h | h newKeyboardFocus: nil]. "Free dependents links if any"    model canvas: nil.        "free model's canvas to save space"! !!MorphWorldController methodsFor: 'control sequence' stamp: 'jm 6/17/97 10:29'!isControlActive    ^ sensor redButtonPressed or: [self viewHasCursor]! !!MorphWorldController methodsFor: 'control sequence'!isControlWanted    ^ self viewHasCursor! !MorphWorldView comment:'I am a view used to display a Scene. I may be scrolled by adjusting my offset. My default controller is SceneController.SceneViews encapsulate the notion of a changing foreground and a fixed background during interactive updates. During an interaction (such as dragging), some of the glyphs will not change location or appearance. These are part of the "background". All glyphs that may change (the "foreground" glyphs) are painted against this unchanging backdrop during the interaction.Instance Variables:    offset                the current offset of this view (used for scrolling)    enclosingRect         a rectangle large enough to contain all the objects in the scene, plus a small border (this is a cache that must be recomputed when glyphs are moved, added, or removed from the scene)    backgroundForm        a <Form> containing the fixed background    visibleForeground        the glyphs that are changing but not selected during an interaction    selectedForeground    the selected glyphs that are changing during an interaction'!!MorphWorldView methodsFor: 'all'!deEmphasizeView     "This window is becoming inactive."    self topView cacheBitsAsTwoTone ifTrue: [        "draw deEmphasized as a two-tone (monochrome) form"        model displayWorldAsTwoTone].! !!MorphWorldView methodsFor: 'all'!defaultControllerClass    ^ MorphWorldController! !!MorphWorldView methodsFor: 'all'!displayView    "This method is called by the system when the top view is framed or moved."    model viewBox: self insetDisplayBox.    self topView == ScheduledControllers scheduledControllers first view        ifTrue: [model displayWorld]        ifFalse: [model displayWorldAsTwoTone].  "just restoring the screen"! !!MorphWorldView methodsFor: 'all'!update: symbol    ^ symbol == #newColor        ifTrue: [self topView backgroundColor: model color; uncacheBits; display]        ifFalse: [super update: symbol].! !!MorphWorldView class methodsFor: 'instance creation'!fullColorWhenInactive    FullColorWhenInactive ifNil: [FullColorWhenInactive _ true].    ^ FullColorWhenInactive! !!MorphWorldView class methodsFor: 'instance creation'!fullColorWhenInactive: aBoolean    "If FullColorWhenInactive is true then WorldMorphViews will created inside StandardSystemViews that cache their contents in full-color when the window is inactive. If it is false, only a half-tone gray approximation of the colors will be cached to save space."    FullColorWhenInactive _ aBoolean.! !!MorphWorldView class methodsFor: 'instance creation'!openOn: aMorphWorld    "Open a view on the given WorldMorph."    self openOn: aMorphWorld label: 'A Morphic World'.! !!MorphWorldView class methodsFor: 'instance creation' stamp: 'di 6/24/97 14:07'!openOn: aWorldMorph label: aString    "Open a view with the given label on the given WorldMorph."    | topView |    self fullColorWhenInactive        ifTrue: [topView _ ColorSystemView new]        ifFalse: [topView _ StandardSystemView new].    topView model: nil;        label: aString;        borderWidth: 1;        minimumSize: aWorldMorph extent + (2@2);  "add border width"        addSubView: (self new initialize model: aWorldMorph);        backgroundColor: aWorldMorph color.    topView controller open.! !!MouseMenuController methodsFor: 'menu messages'!redButtonActivity    "Determine which item in the red button pop-up menu is selected. If one     is selected, then send the corresponding message to the object designated     as the menu message receiver."    | index |    redButtonMenu ~~ nil        ifTrue:             [index _ redButtonMenu startUp.            index ~= 0                 ifTrue: [self menuMessageReceiver perform:                            (redButtonMessages at: index)]]        ifFalse: [super controlActivity]! !!MouseMenuController methodsFor: 'menu messages' stamp: 'sw 1/25/96'!shiftedYellowButtonActivity    "Present the alternate (shifted) menu and take action accordingly.  .    : let #shiftedYellowButtonActivity: do the work"    | index shiftMenu |    (shiftMenu _ self shiftedYellowButtonMenu) == nil ifTrue:        [^ super controlActivity].    self shiftedYellowButtonActivity: shiftMenu! !!MouseMenuController methodsFor: 'menu messages' stamp: 'sw 1/26/96'!shiftedYellowButtonActivity: shiftMenu    "Present the alternate (shifted) menu and take action accordingly.  If we get here, shiftMenu is known to be non-nil.  "    | index  |    (index _ shiftMenu startUp) ~= 0        ifTrue:            [self menuMessageReceiver performMenuMessage: (self shiftedYellowButtonMessages at: index)]        ifFalse:            [super controlActivity]! !!MouseMenuController methodsFor: 'menu messages' stamp: 'sw 1/24/96'!unshiftedYellowButtonActivity    "Put up the regular yellow-button menu and take action as appropriate.  "    | index  |    yellowButtonMenu ~~ nil        ifTrue:             [index _ yellowButtonMenu startUp.            index ~= 0                 ifTrue: [self menuMessageReceiver performMenuMessage:                            (yellowButtonMessages at: index)]]        ifFalse:            [super controlActivity]! !MouseOverHandlesMorph comment:'This morph can be imbedded in any other morph to provide an icon-prompted momentary mode for menu access and other functions.'!!MouseOverHandlesMorph methodsFor: 'initialization' stamp: '6/10/97 13:52 jm'!initialize    super initialize.    self extent: 5@5.  "be small to minimize impact on owner's fullBounds"! !!MouseOverHandlesMorph methodsFor: 'drawing' stamp: '6/10/97 13:51 jm'!drawOn: aCanvas    "This method is overridden so that the receiver behaves like a simple morph when is isn't embedded in another morph."    owner isWorldOrHandMorph        ifTrue: [super drawOn: aCanvas].! !!MouseOverHandlesMorph methodsFor: 'geometry' stamp: '6/10/97 13:50 jm'!bounds    "This method is overridden so that the receiver behaves like a simple morph when is isn't embedded in another morph."    (owner == nil or: [owner isWorldOrHandMorph])        ifTrue: [^ bounds]        ifFalse: [^ owner bounds].! !!MouseOverHandlesMorph methodsFor: 'geometry'!containsPoint: aPoint    "This method is overridden so that, once up, the handles will stay up as long as the mouse is within the box that encloses all the handles even if it is not over any handle or over its owner."    submorphs size = 0 ifTrue: [^ super containsPoint: aPoint].    ^ self fullBounds containsPoint: aPoint! !!MouseOverHandlesMorph methodsFor: 'events' stamp: '6/10/97 13:54 jm'!handlesMouseOver: evt    ^ true! !!MouseOverHandlesMorph methodsFor: 'events' stamp: 'di 6/12/97 18:15'!mouseEnter: evt    "Add the handles."    self addHandles.! !!MouseOverHandlesMorph methodsFor: 'events'!mouseLeave: evt    "Remove the handles."    self removeHandles.! !!MouseOverHandlesMorph methodsFor: 'private' stamp: '6/10/97 12:03 di'!addHandleAt: aPoint color: aColor    "Add a handle centered at the given point with the given color. Return the handle."    | handle |    handle _ EllipseMorph        newBounds: (Rectangle center: aPoint extent: 12@12)        color: aColor.    self addMorph: handle.    ^ handle! !!MouseOverHandlesMorph methodsFor: 'private' stamp: 'di 6/14/97 01:00'!addHandles    "Add the handles."    | box |    self removeAllMorphs.  "remove old handles, if any"    box _ self fullBounds insetBy: -8.    (self addHandleAt: box topLeft color: Color red)        on: #mouseDown send: #doMenu: to: self.    (self addHandleAt: box topCenter color: Color black)        on: #mouseDown send: #doGrab:with: to: self.    (self addHandleAt: box topRight color: Color green)        on: #mouseDown send: #doDup:with: to: self.    (owner isKindOf: SketchMorph) ifTrue: [        (self addHandleAt: box bottomLeft color: Color blue)            on: #mouseDown send: #startRot:with: to: self;            on: #mouseStillDown send: #doRot:with: to: self;            on: #mouseUp send: #endRot:with: to: self.    (self addHandleAt: box bottomRight color: Color black)        on: #mouseDown send: #doGrab:with: to: self.    ] ifFalse: [        (self addHandleAt: box bottomRight color: Color yellow)            on: #mouseDown send: #startGrow:with: to: self;            on: #mouseStillDown send: #doGrow:with: to: self;            on: #mouseUp send: #endGrow:with: to: self.        (self addHandleAt: box bottomLeft color: Color black)            on: #mouseDown send: #doGrab:with: to: self].    self layoutChanged.    self changed.! !!MouseOverHandlesMorph methodsFor: 'private' stamp: 'di 6/14/97 00:15'!doDup: evt with: dupHandle    "Ask hand to duplicate my owner (including me)."    self removeAllHandlesBut: dupHandle.  "remove all other handles"    evt hand setArgument: owner; duplicateMorph.! !!MouseOverHandlesMorph methodsFor: 'private' stamp: 'jm 6/17/97 10:27'!doGrab: evt with: grabHandle    "Ask hand to grab my owner (including me)."    | rootForGrab |    self removeAllHandlesBut: grabHandle.  "remove all other handles"    rootForGrab _ owner rootForGrabOf: owner.    rootForGrab ifNotNil: [evt hand  grabMorph: rootForGrab].! !!MouseOverHandlesMorph methodsFor: 'private' stamp: 'di 6/12/97 11:50'!doGrow: evt with: growHandle    | newExtent |    newExtent _ (evt cursorPoint - resizeOffset) - owner topLeft.    owner extent: (newExtent max: minExtent).    growHandle position: owner bottomRight + resizeOffset - (growHandle extent//2).    self layoutChanged.! !!MouseOverHandlesMorph methodsFor: 'private' stamp: 'jm 9/28/97 18:27'!doMenu: evt    "Ask hand to put up the menu for my owner."    | menu |    self removeHandles.    self world doOneCycle.    menu _ evt hand buildMorphHandleMenuFor: owner.    menu addTitle: owner class name.    evt hand invokeMenu: menu event: evt.! !!MouseOverHandlesMorph methodsFor: 'private' stamp: 'di 6/12/97 12:17'!doRot: evt with: rotHandle    "Update the rotation of my owner if it is a kind of SketchMorph."    | nowDegrees |    (owner isKindOf: SketchMorph) ifTrue: [        nowDegrees _ (evt cursorPoint - owner referencePosition) degrees.        owner rotationDegrees:            (nowDegrees - rotateOffset degrees) negated.        rotHandle position: owner referencePosition +             (Point r: rotateOffset r degrees: nowDegrees) - (rotHandle extent // 2).        self layoutChanged].! !!MouseOverHandlesMorph methodsFor: 'private' stamp: '6/10/97 13:08 jm'!endGrow: evt with: rotHandle    "Finish resizing by restoring the grow handle to its normal place."    self addHandles.! !!MouseOverHandlesMorph methodsFor: 'private' stamp: '6/10/97 13:32 jm'!endRot: evt with: rotHandle    "Finish rotation be restoring the rotation handle to its normal place."    self addHandles.! !!MouseOverHandlesMorph methodsFor: 'private' stamp: 'di 6/14/97 00:08'!removeAllHandlesBut: handle    submorphs copy do: [:m | m == handle ifFalse: [m delete]].  "remove all other handles"! !!MouseOverHandlesMorph methodsFor: 'private' stamp: '6/10/97 18:06 jm'!removeHandles    self removeAllMorphs.    self layoutChanged.    self changed.! !!MouseOverHandlesMorph methodsFor: 'private' stamp: 'di 6/14/97 00:08'!startGrow: evt with: growHandle    "Initialize resizing of my owner."    self removeAllHandlesBut: growHandle.  "remove all other handles"    resizeOffset _ growHandle center - owner bottomRight.    owner isLayoutMorph        ifTrue: [minExtent _ owner minWidth@owner minHeight]        ifFalse: [minExtent _ 1@1].! !!MouseOverHandlesMorph methodsFor: 'private' stamp: 'di 6/14/97 00:09'!startRot: evt with: rotHandle    "Initialize rotation of my owner if it is a kind of SketchMorph."    (owner isKindOf: SketchMorph) ifTrue: [        self removeAllHandlesBut: rotHandle.  "remove all other handles"        rotateOffset _ rotHandle center - owner referencePosition.        rotateOffset _ Point r: rotateOffset r                    degrees: rotateOffset degrees - owner rotationDegrees negated].! !!MovieMorph methodsFor: 'initialization'!initialize    super initialize.    color _ (Color r: 1 g: 0 b: 1).    playMode _ #stop.  "#stop, #playOnce, or #loop"    msecsPerFrame _ 200.    rotationDegrees _ 0.    frameList _ EmptyArray.    currentFrameIndex _ 1.    dwellCount _ 0.! !!MovieMorph methodsFor: 'accessing'!form    ^ self currentFrame form! !!MovieMorph methodsFor: 'accessing'!rotationDegrees    ^ rotationDegrees! !!MovieMorph methodsFor: 'accessing'!rotationDegrees: angleInDegrees    | frame |    rotationDegrees ~= angleInDegrees ifTrue: [        self changed.        rotationDegrees _ angleInDegrees.        frame _ self currentFrame.        frame ifNotNil: [frame rotationDegrees: angleInDegrees].        self layoutChanged.        self changed].! !!MovieMorph methodsFor: 'drawing'!drawOn: aCanvas    | frame |    frame _ self currentFrame.    frame ~~ nil        ifTrue: [^ frame drawOn: aCanvas]        ifFalse: [^ super drawOn: aCanvas].! !!MovieMorph methodsFor: 'geometry-testing'!containsPoint: p    | frame |    frame _ self currentFrame.    ((frame ~~ nil) and: [playMode = #stop])        ifTrue: [^ frame containsPoint: p]        ifFalse: [^ super containsPoint: p].! !!MovieMorph methodsFor: 'stepping'!step    playMode = #stop ifTrue: [^ self].    dwellCount > 0 ifTrue: [        dwellCount _ dwellCount - 1.        ^ self].    currentFrameIndex < frameList size        ifTrue: [^ self setFrame: currentFrameIndex + 1].    playMode = #loop        ifTrue: [self setFrame: 1]        ifFalse: [playMode _ #stop].! !!MovieMorph methodsFor: 'stepping'!stepTime    ^ msecsPerFrame! !!MovieMorph methodsFor: 'menu'!addCustomMenuItems: aCustomMenu hand: aHandMorph    | movies |    super addCustomMenuItems: aCustomMenu hand: aHandMorph.    aCustomMenu addLine.    frameList size > 1 ifTrue: [        aCustomMenu add: 'edit drawing' action: #editDrawing.        aCustomMenu add: 'set rotation center' action: #setRotationCenter.        aCustomMenu add: 'play once' action: #playOnce.        aCustomMenu add: 'play loop' action: #playLoop.        aCustomMenu add: 'stop playing' action: #stopPlaying.        currentFrameIndex > 1 ifTrue: [            aCustomMenu add: 'previous frame' action: #previousFrame].        currentFrameIndex < frameList size ifTrue: [            aCustomMenu add: 'next frame' action: #nextFrame]].    aCustomMenu add: 'extract this frame' action: #extractFrame:.    movies _        (self world rootMorphsAt: aHandMorph targetOffset)            select: [:m | (m isKindOf: MovieMorph) or:                        [m isKindOf: SketchMorph]].    (movies size > 1) ifTrue: [        aCustomMenu add: 'insert into movie' action: #insertIntoMovie:].! !!MovieMorph methodsFor: 'menu'!advanceFrame    currentFrameIndex < frameList size        ifTrue: [self setFrame: currentFrameIndex + 1]        ifFalse: [self setFrame: 1].! !!MovieMorph methodsFor: 'menu'!editDrawing    | frame |    frame _ self currentFrame.    frame ~~ nil ifTrue: [frame editDrawingInWorld: self world].! !!MovieMorph methodsFor: 'menu'!extractFrame: evt    | f |    f _ self currentFrame.    f ifNil: [^ self].    frameList _ frameList copyWithout: f.    frameList isEmpty        ifTrue: [self position: f position]        ifFalse: [self setFrame: currentFrameIndex].    evt hand attachMorph: f.! !!MovieMorph methodsFor: 'menu'!insertIntoMovie: evt    | movies target |    movies _        (self world rootMorphsAt: evt hand targetOffset)            select: [:m | ((m isKindOf: MovieMorph) or:                         [m isKindOf: SketchMorph]) and: [m ~= self]].    movies isEmpty ifTrue: [^ self].    target _ movies first.    (target isKindOf: SketchMorph) ifTrue: [        target _ target replaceSelfWithMovie].    movies first insertFrames: frameList.    self delete.! !!MovieMorph methodsFor: 'menu'!nextFrame    currentFrameIndex < frameList size        ifTrue: [self setFrame: currentFrameIndex + 1].! !!MovieMorph methodsFor: 'menu'!playLoop    playMode _ #loop.! !!MovieMorph methodsFor: 'menu'!playOnce    self setFrame: 1.    playMode _ #playOnce.! !!MovieMorph methodsFor: 'menu'!previousFrame    currentFrameIndex > 1        ifTrue: [self setFrame: currentFrameIndex - 1].! !!MovieMorph methodsFor: 'menu'!setRotationCenter    | frame p |    frame _ self currentFrame.    frame ifNil: [^ self].    self rotationDegrees: 0.   "must set rotation center with no rotation"    self world displayWorld.    Cursor crossHair showWhile:        [p _ Sensor waitButton - self world viewBox origin].    frame rotationCenter: p - frame bounds origin.    self setFrame: currentFrameIndex.! !!MovieMorph methodsFor: 'menu'!stopPlaying    playMode _ #stop.    self setFrame: 1.! !!MovieMorph methodsFor: 'private'!currentFrame    frameList isEmpty ifTrue: [^ nil].    currentFrameIndex > frameList size        ifTrue: [currentFrameIndex _ frameList size].    currentFrameIndex < 1        ifTrue: [currentFrameIndex _ 1].    ^ frameList at: currentFrameIndex! !!MovieMorph methodsFor: 'private'!insertFrames: newFrames    "Insert the given collection of frames into this movie just after the currentrame."    frameList isEmpty ifTrue: [        frameList _ newFrames asArray copy.        self setFrame: 1.        ^ self].    frameList _        frameList            copyReplaceFrom: currentFrameIndex + 1  "insert before"            to: currentFrameIndex            with: newFrames.! !!MovieMorph methodsFor: 'private'!setFrame: newFrameIndex    | oldFrame p newFrame |    oldFrame _ self currentFrame.    oldFrame ifNil: [^ self].    self changed.    p _ oldFrame referencePosition.    currentFrameIndex _ newFrameIndex.    currentFrameIndex > frameList size        ifTrue: [currentFrameIndex _ frameList size].    currentFrameIndex < 1        ifTrue: [currentFrameIndex _ 1].    newFrame _ frameList at: currentFrameIndex.    newFrame rotationDegrees: rotationDegrees.    newFrame referencePosition: p.    oldFrame delete.    self addMorph: newFrame.    dwellCount _ newFrame framesToDwell.    self layoutChanged.    self changed.! !MultiuserTinyPaint comment:'A very simple paint program that handles multiple users (hands).Each user has their own brush size and color.'!!MultiuserTinyPaint methodsFor: 'initialization' stamp: 'jm 9/25/97 21:08'!initialize    super initialize.    color _ Color veryVeryLightGray.    drawState _ IdentityDictionary new.    self clear.! !!MultiuserTinyPaint methodsFor: 'events'!handlesMouseDown: evt    ^ true! !!MultiuserTinyPaint methodsFor: 'events' stamp: 'jm 9/25/97 21:25'!mouseDown: evt    | state |    (drawState includesKey: evt hand) ifFalse: [self createDrawStateFor: evt hand].    state _ drawState at: evt hand.    state at: LastMouseIndex put: evt cursorPoint.! !!MultiuserTinyPaint methodsFor: 'events' stamp: 'jm 9/25/97 21:29'!mouseMove: evt    | state lastP p pen |    state _ drawState at: evt hand ifAbsent: [^ self].    lastP _ state at: LastMouseIndex.    p _ evt cursorPoint.    p = lastP ifTrue: [^ self].    pen _ state at: PenIndex.    pen drawFrom: lastP - bounds origin to: p - bounds origin.    self invalidRect: (        ((lastP min: p) - pen sourceForm extent) corner:        ((lastP max: p) + pen sourceForm extent)).    state at: LastMouseIndex put: p.! !!MultiuserTinyPaint methodsFor: 'menu' stamp: 'jm 9/26/97 14:50'!addCustomMenuItems: aCustomMenu hand: aHandMorph    super addCustomMenuItems: aCustomMenu hand: aHandMorph.    aCustomMenu add: 'clear' action: #clear.    aCustomMenu add: 'pen color' action: #setPenColor:.    aCustomMenu add: 'pen size' action: #setPenSize:."    aCustomMenu add: 'fill' action: #fill:."! !!MultiuserTinyPaint methodsFor: 'menu' stamp: 'jm 9/25/97 21:33'!brushColor: aColor hand: hand    | state |    (drawState includesKey: hand) ifFalse: [self createDrawStateFor: hand].    state _ drawState at: hand.    (state at: PenIndex) color: aColor.    state at: PenColorIndex put: aColor.! !!MultiuserTinyPaint methodsFor: 'menu' stamp: 'jm 9/25/97 21:17'!clear    | newPen |    self form: ((Form extent: 400@300 depth: 8) fillColor: color).    drawState do: [:state |        newPen _ Pen newOnForm: originalForm.        newPen roundNib: (state at: PenSizeIndex).        newPen color: (state at: PenColorIndex).        state at: PenIndex put: newPen].! !!MultiuserTinyPaint methodsFor: 'menu' stamp: 'jm 9/25/97 21:32'!fill: evt    | state fillPt |    (drawState includesKey: evt hand) ifFalse: [self createDrawStateFor: evt hand].    state _ drawState at: evt hand.    Cursor blank show.    Cursor crossHair showWhile:        [fillPt _ Sensor waitButton - self world viewBox origin - self position].    originalForm shapeFill: (state at: PenColorIndex) interiorPoint: fillPt.    self changed.! !!MultiuserTinyPaint methodsFor: 'menu' stamp: 'jm 9/26/97 14:47'!penSize: anInteger hand: hand    | state |    (drawState includesKey: hand) ifFalse: [self createDrawStateFor: hand].    state _ drawState at: hand.    state at: PenSizeIndex put: anInteger.    (state at: PenIndex) roundNib: anInteger.! !!MultiuserTinyPaint methodsFor: 'menu' stamp: 'jm 9/25/97 21:11'!setPenColor: evt    evt hand changeColorTarget: self selector: #brushColor:hand:.! !!MultiuserTinyPaint methodsFor: 'menu' stamp: 'jm 9/29/97 07:49'!setPenSize: evt    | menu sizes |    menu _ MenuMorph new.    sizes _ (0 to: 5), (6 to: 12 by: 2), (15 to: 40 by: 5).    sizes do: [:w |        menu add: w printString            target: self            selector: #penSize:hand:            argumentList: (Array with: w with: evt hand)].    menu popUpAt: evt hand position event: evt.! !!MultiuserTinyPaint methodsFor: 'private' stamp: 'jm 9/25/97 21:35'!createDrawStateFor: aHand    | pen state |    pen _ Pen newOnForm: originalForm.    state _ Array new: 4.    state at: PenIndex put: pen.    state at: PenSizeIndex put: 3.    state at: PenColorIndex put: Color red.    state at: LastMouseIndex put: nil.    drawState at: aHand put: state.! !!MultiuserTinyPaint class methodsFor: 'class initialization' stamp: 'jm 9/25/97 21:16'!initialize    "MultiuserTinyPaint initialize"    "indices into the state array for a given hand"    PenIndex _ 1.    PenSizeIndex _ 2.    PenColorIndex _ 3.    LastMouseIndex _ 4.! !NetNameResolver comment:'This class implements TCP/IP style network name lookup and translation facilities.'!!NetNameResolver class methodsFor: 'class initialization' stamp: 'jm 9/17/97 16:18'!initialize    "NetNameResolver initialize"    "Note: On the Mac, the name resolver is asynchronous (i.e., Squeak can do other things while it is working), but can only handle one request at a time. On other platforms, such as Unix, the resolver is synchronous; a call to, say, the name lookup primitive will block all Squeak processes until it returns."    "Resolver Status Values"    ResolverUninitialized _ 0.    "network is not initialized"    ResolverReady _ 1.            "resolver idle, last request succeeded"    ResolverBusy _ 2.            "lookup in progress"    ResolverError _ 3.            "resolver idle, last request failed"    DefaultHostName _ ''.! !!NetNameResolver class methodsFor: 'address string utils' stamp: 'jm 9/15/97 06:19'!addressFromString: addressString    "Return the internet address represented by the given string. The string should contain four positive decimal integers delimited by periods, commas, or spaces, where each integer represents one address byte. Return nil if the string is not a host address in an acceptable format."    "NetNameResolver addressFromString: '1.2.3.4'"    "NetNameResolver addressFromString: '1,2,3,4'"    "NetNameResolver addressFromString: '1 2 3 4'"    | newAddr s byte delimiter |    newAddr _ ByteArray new: 4.    s _ ReadStream on: addressString.    s skipSeparators.    1 to: 4 do: [:i |        byte _ self readDecimalByteFrom: s.        byte = nil ifTrue: [^ nil].        newAddr at: i put: byte.        i < 4 ifTrue: [            delimiter _ s next.            ((delimiter = $.) or: [(delimiter = $,) or: [delimiter = $ ]])                ifFalse: [^ nil]]].    ^ newAddr! !!NetNameResolver class methodsFor: 'address string utils' stamp: 'jm 9/15/97 16:52'!stringFromAddress: addr    "Return a string representing the given host address as four decimal bytes delimited with decimal points."    "NetNameResolver stringFromAddress: NetNameResolver localHostAddress"    | s |    s _ WriteStream on: ''.    1 to: 3 do: [ :i | (addr at: i) printOn: s. s nextPut: $.].    (addr at: 4) printOn: s.    ^ s contents! !!NetNameResolver class methodsFor: 'lookups' stamp: 'jm 9/15/97 16:44'!addressForName: hostName timeout: secs    "Look up the given host name and return its address. Return nil if the address is not found in the given number of seconds."    "NetNameResolver addressForName: 'create.ucsb.edu' timeout: 30"    | deadline ready success |    (hostName isEmpty not and: [hostName first isDigit]) ifTrue: [        "assume a numeric host address if first character is a digit"        ^ self addressFromString: hostName].    deadline _ Time millisecondClockValue + (secs * 1000).    ready _ self waitForResolverReadyUntil: deadline.    ready ifFalse: [^ nil].    self primStartLookupOfName: hostName.    success _ self waitForCompletionUntil: deadline.    success        ifTrue: [^ self primNameLookupResult]        ifFalse: [^ nil].! !!NetNameResolver class methodsFor: 'lookups' stamp: 'jm 9/15/97 16:52'!localAddressString    "Return a string representing the local host address as four decimal bytes delimited with decimal points."    "NetNameResolver localAddressString"    ^ NetNameResolver stringFromAddress: NetNameResolver localHostAddress! !!NetNameResolver class methodsFor: 'lookups' stamp: 'jm 9/15/97 16:31'!localHostAddress    "Return the local address of this host."    "NetNameResolver localHostAddress"    ^ self primLocalAddress! !!NetNameResolver class methodsFor: 'lookups' stamp: 'jm 9/15/97 16:46'!nameForAddress: hostAddress timeout: secs    "Look up the given host address and return its name. Return nil if the lookup fails or is not completed in the given number of seconds. Depends on the given host address being known to the gateway, which may not be the case for dynamically allocated addresses."    "NetNameResolver        nameForAddress: (NetNameResolver addressFromString: '128.111.92.40')        timeout: 30"    | deadline ready success |    deadline _ Time millisecondClockValue + (secs * 1000).    ready _ self waitForResolverReadyUntil: deadline.    ready ifFalse: [^ nil].    self primStartLookupOfAddress: hostAddress.    success _ self waitForCompletionUntil: deadline.    success        ifTrue: [^ self primAddressLookupResult]        ifFalse: [^ nil].! !!NetNameResolver class methodsFor: 'lookups' stamp: 'jm 9/17/97 16:26'!promptUserForHostAddress    "Ask the user for a host name and return its address."    "NetNameResolver promptUserForHostAddress"    ^ NetNameResolver promptUserForHostAddressDefault: ''! !!NetNameResolver class methodsFor: 'lookups' stamp: 'jm 9/24/97 10:38'!promptUserForHostAddressDefault: defaultName    "Ask the user for a host name and return its address. If the default name is the empty string, use the last host name as the default."    "NetNameResolver promptUserForHostAddressDefault: ''"    | default hostName serverAddr |    Socket initializeNetwork.    defaultName isEmpty        ifTrue: [default _ DefaultHostName]        ifFalse: [default _ defaultName].    hostName _ FillInTheBlank        request: 'Host name or address?'        initialAnswer: default.    hostName isEmpty ifTrue: [^ 0].    serverAddr _ NetNameResolver addressForName: hostName timeout: 15.    serverAddr = nil ifTrue: [self error: 'Could not find the address for ', hostName].    hostName size > 0 ifTrue: [DefaultHostName _ hostName].    ^ serverAddr! !!NetNameResolver class methodsFor: 'network initialization' stamp: 'jm 9/15/97 16:58'!initializeNetwork    "Initialize the network drivers and record the semaphore to be used by the resolver. Do nothing if the network is already initialized."    "NetNameResolver initializeNetwork"    | semaIndex |    self primNameResolverStatus = ResolverUninitialized        ifFalse: [^ self].  "network is already initialized"    ResolverSemaphore _ Semaphore new.    semaIndex _ Smalltalk registerExternalObject: ResolverSemaphore.    Utilities informUser:'Initializing the network drivers; this maytake up to 30 seconds and can''t be interrupted'        during: [self primInitializeNetwork: semaIndex].! !!NetNameResolver class methodsFor: 'network initialization' stamp: 'jm 9/15/97 06:37'!primInitializeNetwork: resolverSemaIndex    "Initialize the network drivers on platforms that need it, such as the Macintosh. Since mobile computers may not always be connected to a network, this method should NOT be called automatically at startup time; rather, it should be called when first starting a networking application. It is a noop if the network driver has already been initialized. If non-zero, resolverSemaIndex is the index of a VM semaphore to be associated with the network name resolver. This semaphore will be signalled when the resolver status changes, such as when a name lookup query is completed."    "Note: some platforms (e.g., Mac) only allow only one name lookup query at a time, so a manager process should be used to serialize resolver lookup requests."    <primitive: 200>    self notify: 'Network initialization failed, perhaps becausethis machine is not connected to a network.'.! !!NetNameResolver class methodsFor: 'primitives'!primAbortLookup    "Abort the current lookup operation, freeing the name resolver for the next query."    <primitive: 205>    self primitiveFailed! !!NetNameResolver class methodsFor: 'primitives'!primAddressLookupResult    "Return the host name found by the last host address lookup. Returns nil if the last lookup was unsuccessful."    <primitive: 204>    self primitiveFailed! !!NetNameResolver class methodsFor: 'primitives'!primLocalAddress    "Return the local address of this host."    <primitive: 206>    self primitiveFailed! !!NetNameResolver class methodsFor: 'primitives'!primNameLookupResult    "Return the host address found by the last host name lookup. Returns nil if the last lookup was unsuccessful."    <primitive: 202>    self primitiveFailed! !!NetNameResolver class methodsFor: 'primitives'!primNameResolverError    "Return an integer reflecting the error status of the last network name resolver request. Zero means no error."    <primitive: 208>    self primitiveFailed! !!NetNameResolver class methodsFor: 'primitives'!primNameResolverStatus    "Return an integer reflecting the status of the network name resolver. For a list of possible values, see the comment in the 'initialize' method of this class."    <primitive: 207>    self primitiveFailed! !!NetNameResolver class methodsFor: 'primitives'!primStartLookupOfAddress: hostAddr    "Look up the given host address in the Domain Name Server to find its name. This call is asynchronous. To get the results, wait for it to complete or time out and then use primAddressLookupResult."    <primitive: 203>    self primitiveFailed! !!NetNameResolver class methodsFor: 'primitives'!primStartLookupOfName: hostName    "Look up the given host name in the Domain Name Server to find its address. This call is asynchronous. To get the results, wait for it to complete or time out and then use primNameLookupResult."    <primitive: 201>    self primitiveFailed! !!NetNameResolver class methodsFor: 'private'!readDecimalByteFrom: aStream    "Read a positive, decimal integer from the given stream. Stop when a non-digit or end-of-stream is encountered. Return nil if stream is not positioned at a decimal digit or if the integer value read exceeds 255."    | digitSeen value digit |    digitSeen _ false.    value _ 0.    [aStream atEnd] whileFalse: [        digit _ aStream next digitValue.        (digit < 0 or: [digit > 9]) ifTrue: [            aStream skip: -1.            digitSeen ifFalse: [^ nil].            ^ value].        digitSeen _ true.        value _ (value * 10) + digit].    (digitSeen and: [value <= 255]) ifFalse: [^ nil].    value > 255 ifTrue: [^ nil].  "exceeds the range of a single byte integer"    ^ value! !!NetNameResolver class methodsFor: 'private' stamp: 'jm 9/15/97 16:56'!waitForCompletionUntil: deadline    "Wait up to the given number of seconds for the resolver to be ready to accept a new request. Return true if the resolver is ready, false if the network is not initialized or the resolver does not become free within the given time period."    | status |    status _ self primNameResolverStatus.    [(status = ResolverBusy) and:     [Time millisecondClockValue < deadline]]        whileTrue: [            "wait for resolver to be available"            ResolverSemaphore waitTimeoutMSecs: (deadline - Time millisecondClockValue).            status _ self primNameResolverStatus].    status = ResolverReady        ifTrue: [^ true]        ifFalse: [self primAbortLookup. ^ false].! !!NetNameResolver class methodsFor: 'private' stamp: 'jm 9/15/97 16:56'!waitForResolverReadyUntil: deadline    "Wait up to the given number of seconds for the resolver to be ready to accept a new request. Return true if the resolver is not busy, false if the network is not initialized or the resolver does not become free within the given time period."    | status |    status _ self primNameResolverStatus.    status = ResolverUninitialized ifTrue: [^ false].    [(status = ResolverBusy) and:     [Time millisecondClockValue < deadline]]        whileTrue: [            "wait for resolver to be available"            ResolverSemaphore waitTimeoutMSecs: (deadline - Time millisecondClockValue).            status _ self primNameResolverStatus].    ^ status ~= ResolverBusy! !!NotifyStringHolderController methodsFor: 'menu messages'!debug    "Open a full DebuggerView."    | debuggerTemp topView |    topView _ view topView.    debuggerTemp _ debugger.  debugger _ nil.  "So close wont terminate"    self controlTerminate.    topView deEmphasizeView; erase.    DebuggerView openNoSuspendDebugger: debuggerTemp label: topView label.    topView controller closeAndUnscheduleNoErase.    Processor terminateActive! !!NotifyStringHolderController methodsFor: 'menu messages'!proceed    "Proceed execution of the suspended process."    | debuggerTemp |    Smalltalk okayToProceedEvenIfSpaceIsLow ifFalse: [^ self].    debuggerTemp _ debugger.  debugger _ nil.  "So close wont terminate"    self controlTerminate.    debuggerTemp proceed: view superView controller.    self controlInitialize! !Number comment:'I am an abstract representation of a number. My subclasses Float, Fraction, and Integer, and their subclasses, provide concrete representations of a numeric quantity.All my subclasses participate in a simple type coercion mechanism that supports mixed-mode arithmetic and comparisons.  It works as follows:  If    self<typeA> op: arg<typeB>fails because of incompatible types, then it is retried in the following guise:    (arg adaptTypeA: self) op: arg adaptToTypeA.This gives the arg of typeB an opportunity to resolve the incompatibility, knowing exactly what two types are involved.  If self is more general, then arg will be converted, and viceVersa.  This mechanism is extensible to any new number classes that one might wish to add to Squeak.  The only requirement is that every subclass of Number must support a pair of conversion methods specific to each of the other subclasses of Number.'!!Number methodsFor: 'arithmetic'!/ aNumber     "Answer the result of dividing the receiver by aNumber."    self subclassResponsibility! !!Number methodsFor: 'testing'!isFloat    ^ false! !!Number methodsFor: 'testing'!isFraction    ^ false! !!Number methodsFor: 'converting'!adaptFloat: aFloat    "If I am involved in arithmetic with a Float, I must know whether to convert it."    self subclassResponsibility! !!Number methodsFor: 'converting'!adaptFraction: aFraction    "If I am involved in arithmetic with a Fraction, I must know whether to convert it."    self subclassResponsibility! !!Number methodsFor: 'converting'!adaptInteger: anInteger    "If I am involved in arithmetic with an Integer, I must know whether to convert it."    self subclassResponsibility! !!Number methodsFor: 'converting'!adaptToFloat    "If I am involved in arithmetic with a Float, I must know whether to be converted."    self subclassResponsibility! !!Number methodsFor: 'converting'!adaptToFraction    "If I am involved in arithmetic with a Fraction, I must know whether to be converted."    self subclassResponsibility! !!Number methodsFor: 'converting'!adaptToInteger    "If I am involved in arithmetic with an Integer, I must know whether to be converted."    self subclassResponsibility! !!Number methodsFor: 'printing'!defaultLabelForInspector    "Answer the default label to be used for an Inspector window on the receiver."    ^ super defaultLabelForInspector, ': ', self printString! !!Object methodsFor: 'accessing' stamp: 'sw 10/9/96'!isDescendedFrom: anObject    "Answer whether the receiver is, from the containment perspective, descended from anObject.  "    ^ false! !!Object methodsFor: 'testing'!ifNil: nilBlock    "Return self, or evaluate the block if I'm == nil (q.v.)"    ^ self! !!Object methodsFor: 'testing'!ifNil: nilBlock ifNotNil: ifNotNilBlock    "Evaluate the block, unless I'm == nil (q.v.)"    ^ ifNotNilBlock value! !!Object methodsFor: 'testing'!ifNotNil: ifNotNilBlock    "Evaluate the block, unless I'm == nil (q.v.)"    ^ ifNotNilBlock value! !!Object methodsFor: 'testing'!ifNotNil: ifNotNilBlock ifNil: nilBlock     "If I got here, I am not nil, so evaluate the block ifNotNilBlock"    ^ ifNotNilBlock value! !!Object methodsFor: 'testing'!isColor    "Answer true if receiver is a Color. False by default."    ^ false! !!Object methodsFor: 'testing'!isMorph    ^ false! !!Object methodsFor: 'testing'!isText    ^ false! !!Object methodsFor: 'testing' stamp: 'sw 9/27/96'!name    "Answer a name for the receiver.  This is used generically in the title of certain inspectors, such as the referred-to inspector, and specificially by various subsystems.  By default, we let the object just print itself out..  "    ^ self printString! !!Object methodsFor: 'comparing'!hash    "Answer a SmallInteger whose value is related to the receiver's identity.    May be overridden, and should be overridden in any classes that define = "    ^ self identityHash! !!Object methodsFor: 'comparing' stamp: 'pm 9/23/97 09:36'!hashMappedBy: map    "Answer what my hash would be if oops changed according to map."    ^map newHashFor: self! !!Object methodsFor: 'comparing' stamp: 'di 9/27/97 20:27'!identityHash    "Answer a SmallInteger whose value is related to the receiver's identity.    This method must not be overridden, except by SmallInteger.    Primitive. Fails if the receiver is a SmallInteger. Essential.    See Object documentation whatIsAPrimitive.    Do not override."    <primitive: 75>    self primitiveFailed! !!Object methodsFor: 'comparing' stamp: 'di 9/27/97 20:23'!identityHashMappedBy: map    "Answer what my hash would be if oops changed according to map."    ^map newHashFor: self! !!Object methodsFor: 'copying'!clone    <primitive: 148>    self primitiveFailed! !!Object methodsFor: 'dependents access'!addDependent: anObject    "Make the given object one of the receiver's dependents."    | dependents |    dependents _ self dependents.    dependents do: [:o | o == anObject ifTrue: [^ self]].  "anObject is already a dependent"    DependentsFields at: self put: (dependents copyWith: anObject).! !!Object methodsFor: 'dependents access'!breakDependents    "Remove all of the receiver's dependents."    DependentsFields removeKey: self ifAbsent: [].! !!Object methodsFor: 'dependents access'!dependents    "Answer a collection of objects that are 'dependent' on the receiver;     that is, all objects that should be notified if the receiver changes."    (DependentsFields includesKey: self)        ifTrue: [^ DependentsFields at: self]        ifFalse: [^ #()].! !!Object methodsFor: 'dependents access'!evaluate: actionBlock wheneverChangeIn: aspectBlock    | viewerThenObject objectThenViewer |    objectThenViewer _ self.    viewerThenObject _ ObjectViewer on: objectThenViewer.    objectThenViewer become: viewerThenObject.    "--- Then ---"    objectThenViewer xxxViewedObject: viewerThenObject            evaluate: actionBlock            wheneverChangeIn: aspectBlock! !!Object methodsFor: 'dependents access'!removeDependent: anObject    "Remove the given object as one of the receiver's dependents."    | dependents newDependents |    dependents _ self dependents.    newDependents _ dependents select: [ :d | (d == anObject) not].    newDependents isEmpty        ifTrue: [DependentsFields removeKey: self ifAbsent: []]        ifFalse: [DependentsFields at: self put: newDependents].! !!Object methodsFor: 'printing' stamp: 'di 6/20/97 08:57'!fullPrintString    "Answer a String whose characters are a description of the receiver."    ^ String streamContents: [:s | self printOn: s]! !!Object methodsFor: 'printing' stamp: 'di 6/20/97 09:22'!printString    "Answer a String whose characters are a description of the receiver.    If you want to print without a character limit, use fullPrintString."    | limit limitedString |    limit _ 50000.    limitedString _ String streamContents: [:s | self printOn: s] limitedTo: limit.    limitedString size < limit ifTrue: [^ limitedString].    ^ limitedString , '...etc...'! !!Object methodsFor: 'printing' stamp: 'di 6/20/97 09:12'!storeString    "Answer a String representation of the receiver from which the receiver     can be reconstructed."    ^ String streamContents: [:s | self storeOn: s]! !!Object methodsFor: 'message handling'!perform: selector withArguments: anArray     "Primitive. Send the receiver the keyword message indicated by the     arguments. The argument, selector, is the selector of the message. The     arguments of the message are the elements of anArray. Invoke     messageNotUnderstood: if the number of arguments expected by the     selector is not the same as the length of anArray. Essential. See Object     documentation whatIsAPrimitive."    <primitive: 84>    (selector isMemberOf: Symbol)        ifFalse: [^ self error: 'selector argument must be a Symbol'].    self primitiveFailed! !!Object methodsFor: 'error handling'!confirm: queryString     "Put up a yes/no menu with caption aString. Answer true if the response is yes, false if no. This is a modal question--the user must respond yes or no."    "nil confirm: 'Are you hungry?'"    ^ SelectionMenu confirm: queryString! !!Object methodsFor: 'error handling' stamp: 'di 6/17/97 08:46'!doesNotUnderstand: aMessage      "Handle the fact that there was an attempt to send the given message to the receiver but the receiver does not understand this message (typically sent from the machine when a message is sent to the receiver and no method is defined for that selector)."    "Unless the receiver has an error handler defined for the active process (this mechanism appears vestigal so it is probably defunct), report to the user that the receiver does not understand the argument, aMessage, as a message."    "Testing: (3 activeProcess)"    | thisProcess errorString |    (Preferences autoAccessors and: [self tryToDefineVariableAccess: aMessage])        ifTrue: [^ aMessage sentTo: self].    errorString _ 'Message not understood: ', aMessage selector.    (thisProcess _ Processor activeProcess) isErrorHandled        ifTrue: [thisProcess errorHandler value: errorString value: self]        ifFalse: [DebuggerView openContext: thisContext                    label: errorString                    contents: thisContext shortStack].    ^ aMessage sentTo: self! !!Object methodsFor: 'user interface'!basicInspect    "Create and schedule an Inspector in which the user can examine the     receiver's variables. This method should not be overriden."    Inspector openOn: self withEvalPane: false! !!Object methodsFor: 'user interface'!defaultLabelForInspector    "Answer the default label to be used for an Inspector window on the receiver."    ^ self class name! !!Object methodsFor: 'user interface' stamp: 'di 6/24/97 11:47'!inspect    "Create and schedule an Inspector in which the user can examine the     receiver's variables."    | insp |    World ifNotNil:        ["Written so that Morphic can still be removed."        insp _ (Smalltalk at: #ObjectInspector) on: self.        ^ self world addMorph: insp; startStepping: insp].    Inspector openOn: self withEvalPane: true! !!Object methodsFor: 'user interface'!inspectWithLabel: aLabel    Inspector openOn: self withEvalPane: true withLabel: aLabel! !!Object methodsFor: 'system primitives' stamp: 'tk 5/5/97'!instVarNamed: aString    "Return the value of the instance variabvle in me with that name.  Slow and unclean, but very useful.  "    ^ self instVarAt: ((self class allInstVarNames) indexOf: aString)! !!Object methodsFor: 'system primitives' stamp: 'tk 5/5/97'!instVarNamed: aString put: aValue    "Store into the value of the instance variable in me of that name.  Slow and unclean, but very useful.  "    ^ self instVarAt: ((self class allInstVarNames) indexOf: aString) put: aValue! !!Object methodsFor: 'private' stamp: 'di 6/17/97 08:59'!primitiveError: aString     "This method is called when the error handling results in a recursion in calling    on error: or halt or halt:."    | context |    (String streamContents:        [:s |        s nextPutAll: '**System Error Handling Failed** '.        s cr; nextPutAll: aString.        context _ thisContext sender sender.        6 timesRepeat:             [context == nil ifFalse: [s cr; print: (context _ context sender)]].        s cr; nextPutAll: '**Type any character to restart.**'])        displayAt: 0@0.    [Sensor keyboardPressed] whileFalse.    Sensor keyboard.    ScheduledControllers searchForActiveController! !!Object methodsFor: 'flagging'!isThisEverCalled    ^ self isThisEverCalled: 'Yes, this *is* called'! !!Object methodsFor: 'translation support'!cCode: codeString    "For translation only; noop when running in Smalltalk."! !!Object methodsFor: 'translation support'!cCoerce: value to: cType    "Type coercion for translation only; just return the value when running in Smalltalk."    ^ value! !!Object methodsFor: 'translation support'!inline: inlineFlag    "For translation only; noop when running in Smalltalk."! !!Object methodsFor: 'translation support'!returnTypeC: typeString    "For translation only; noop when running in Smalltalk."! !!Object methodsFor: 'translation support'!sharedCodeNamed: label inCase: caseNumber    "For translation only; noop when running in Smalltalk."! !!Object methodsFor: 'translation support'!var: varSymbol declareC: declString    "For translation only; noop when running in Smalltalk."! !!Object methodsFor: 'objects from disk' stamp: 'tk 1/8/97'!readDataFrom: aDataStream size: varsOnDisk    "Make self be an object based on the contents of aDataStream, which was       generated by the object╒s storeDataOn: method. Return self.     Read in the instance-variables written by Object>>storeDataOn:.     NOTE: This method must match its corresponding storeDataOn:       method. Also, it must send beginReference: after instantiating       the new object but before reading any objects from aDataStream       that might reference it.    : allow fewer inst vars, instance does reading, see SmartRefStream."    | cntInstVars cntIndexedVars |    cntInstVars _ self class instSize.    self class isVariable        ifTrue: [cntIndexedVars _ varsOnDisk - cntInstVars.                cntIndexedVars < 0 ifTrue: [                    self error: 'Class has changed too much.  Define a convertxxx method']]        ifFalse: [cntIndexedVars _ 0.                cntInstVars _ varsOnDisk].     "OK if fewer than now"    aDataStream beginReference: self.    1 to: cntInstVars do:        [:i | self instVarAt: i put: aDataStream next].    1 to: cntIndexedVars do:        [:i | self basicAt: i put: aDataStream next].    "Total number read MUST be equal to varsOnDisk!!"    ^ self! !!Object methodsFor: 'objects from disk' stamp: 'tk 6/26/97 13:48'!saveOnFile    "Ask the user for a filename and save myself on a SmartReferenceStream file.  Writes out the version and class structure.  The file is fileIn-able.  Does not file out the class of the object.  tk 6/26/97 13:48"    | aFileName fileStream |    aFileName _ self class name asFileName.    "do better?"    aFileName _ FillInTheBlank request: 'File name?' initialAnswer: aFileName.    aFileName size == 0 ifTrue: [^ self beep].    fileStream _ FileStream newFileNamed: aFileName.    fileStream fileOutClass: nil andObject: self.! !!Object class methodsFor: 'class initialization'!initializeOnceOnly     "Refer to the comment in Class|initialize.  This is the initilaize message for Object class, but if called initialize, then all classes would inherit it as a class message, and clearly this is not the default desired."    self initializeDependentsFields.  "Note this will disconnect views!!"    self initializeErrorRecursion.    "Object initializeOnceOnly"! !!Object class methodsFor: 'objects from disk' stamp: 'tk 1/8/97'!createFrom: aSmartRefStream size: varsOnDisk version: instVarList    "Create an instance of me so objects on the disk can be read in.  Tricky part is computing the size if variable.  Inst vars will be filled in later.  "    ^ self isVariable        ifFalse: [self basicNew]        ifTrue: ["instVarList is names of old class's inst vars plus a version number"                 self basicNew: (varsOnDisk - (instVarList size - 1))]! !!Object class methodsFor: 'objects from disk' stamp: 'tk 1/3/97'!readDataFrom: aDataStream size: varsOnDisk    "Create an object based on the contents of aDataStream, which was       generated by the object╒s storeDataOn: method. Answer it.     This implementation reads back the instance-variables written by       Object>>storeDataOn:.     NOTE: This method must match its corresponding storeDataOn:       method. Also, it must send beginReference: after instantiating       the new object but before reading any objects from aDataStream       that might reference it.    11/23/92 jhm: Changed to basicNew & basicNew: to match basicSize and because        we then overwrite all instance & indexed vars.    : allow fewer inst vars, and total remap for others.  Let object do it."    | anObject cntInstVars cntIndexedVars |    self halt.  "Use same method in the instance side"    cntInstVars _ self instSize.    anObject _ self isVariable        ifTrue: [cntIndexedVars _ varsOnDisk - cntInstVars.                cntIndexedVars < 0 ifTrue: [self error: 'Class needs to be reshaped'].                self basicNew: cntIndexedVars]        ifFalse: [self basicNew].    ^ anObject readDataFrom: aDataStream size: varsOnDisk! !!ObjectInspector methodsFor: 'initialization' stamp: 'di 6/22/97 22:53'!defaultExtent    ^ 300@200! !!ObjectInspector methodsFor: 'initialization' stamp: 'di 6/22/97 23:15'!extent: newExtent    | w h inner labelRect |    super extent: newExtent.    inner _ self innerBounds.    labelRect _ inner topLeft corner: inner topRight + (0@self labelHeight).    w _ inner width - 2 // 3.  h _ inner height - labelRect height - 2 // 3.    fieldPane bounds: (labelRect bottomLeft + (1@1) extent: w @ (inner height-labelRect height - 2)).    valuePane bounds: (fieldPane bounds topRight corner: inner right - 1 @ (labelRect bottom + h)).    doitPane bounds: (valuePane bounds bottomLeft corner: inner bottomRight - 1)! !!ObjectInspector methodsFor: 'initialization' stamp: 'di 6/22/97 23:20'!initialize    super initialize.    fieldIndex _ 0.    fieldPane list: self computeFieldList.! !!ObjectInspector methodsFor: 'initialization' stamp: 'di 6/18/97 09:30'!initPanes    self addMorph: (fieldPane _ ListPane new model: self slotName: 'fieldPane').    self addMorph: (valuePane _ ScrollPane new model: self slotName: 'valuePane').    self addMorph: (doitPane _ ScrollPane new model: self slotName: 'doitPane').! !!ObjectInspector methodsFor: 'initialization' stamp: 'di 6/22/97 22:38'!setObject: anObject    object _ anObject! !!ObjectInspector methodsFor: 'field list, selection' stamp: 'di 6/22/97 23:12'!computeFieldList    "Answer the base field list plus an abbreviated list of indices."    fieldList _ (Array with: 'self') , object class allInstVarNames.    object class isVariable ifFalse: [^ fieldList].    ^ fieldList ,        ((object basicSize <= (self nLow + self nHigh) or: [showAllIndices])            ifTrue: [(1 to: object basicSize)                        collect: [:i | i printString]]            ifFalse: [(1 to: self nLow) , #('...') , (object basicSize-(self nHigh-1) to: object basicSize)                        collect: [:i | i printString]])! !!ObjectInspector methodsFor: 'field list, selection' stamp: 'di 6/18/97 09:27'!fieldValue    "Answer the value of the selected variable."    | basicIndex |    fieldIndex = 1 ifTrue: [^ object].    (fieldIndex - 1) <= object class instSize        ifTrue: [^ object instVarAt: fieldIndex - 1].    basicIndex _ fieldIndex - 1 - object class instSize.    ((object basicSize <= (self nLow + self nHigh) or: [basicIndex <= self nLow]) or: [showAllIndices])        ifTrue: [^ object basicAt: basicIndex].    basicIndex < object basicSize - self nHigh + 1 ifTrue: [^ nil]. "..."    ^ object basicAt: object basicSize - (self nLow + self nHigh) + basicIndex! !!ObjectInspector methodsFor: 'field list, selection' stamp: 'di 6/18/97 09:16'!nHigh    "Number of indices to show at the end of an array"    ^ 10! !!ObjectInspector methodsFor: 'field list, selection' stamp: 'di 6/18/97 09:16'!nLow    "Number of indices to show at the beginning of an array"    ^ 100! !!ObjectInspector methodsFor: 'field list, selection' stamp: 'di 6/22/97 23:24'!updateFieldValue    fieldIndex = 0 ifTrue: [^ self].    valuePane scroller firstSubmorph contents: self fieldValue printString asText! !!ObjectInspector methodsFor: 'input events' stamp: 'di 6/22/97 23:11'!fieldPaneNewSelection: fieldString    fieldIndex _ fieldList indexOf: fieldString ifAbsent: [0].    fieldIndex = 0 ifTrue: [^ self].    valuePane scroller removeAllMorphs;        addMorph: (TextMorph new contents: self fieldValue printString asText)! !!ObjectInspector methodsFor: 'stepping' stamp: 'di 6/22/97 23:26'!step    self updateFieldValue! !!ObjectInspector methodsFor: 'stepping' stamp: 'di 6/22/97 23:27'!stepTime    ^ 100 "milliseconds"! !!ObjectInspector methodsFor: 'stepping' stamp: 'di 6/22/97 23:27'!wantsSteps    ^ (fieldIndex = 0) not! !!ObjectInspector class methodsFor: 'instance creation' stamp: 'di 6/22/97 22:40'!on: anObject    ^ (self basicNew setLabel: anObject defaultLabelForInspector;                    setObject: anObject) initialize! !ObjectMemory comment:'This class describes a 32-bit direct-pointer object memory for Smalltalk.  The model is very simple in principle:  a pointer is either a SmallInteger or a 32-bit direct object pointer.SmallIntegers are tagged with a low-order bit equal to 1, and an immediate 31-bit 2s-complement signed value in the rest of the word.All object pointers point to a header, which may be followed by a number of data fields.  This object memory achieves considerable compactness by using a variable header size (the one complexity of the design).  The format of the 0th header word is as follows:    3 bits    reserved for gc (mark, old, dirty)    12 bits    object hash (for HashSets)    5 bits    compact class index    4 bits    object format    6 bits    object size in 32-bit words    2 bits    header type (0: 3-word, 1: 2-word, 2: forbidden, 3: 1-word)If a class is in the compact class table, then this is the only header information needed.  If it is not, then it will have another header word at offset -4 bytes with its class in the high 30 bits, and the header type repeated in its low 2 bits.  It the objects size is greater than 255 bytes, then it will have yet another header word at offset -8 bytes with its full word size in the high 30 bits and its header type repeated in the low two bits.The object format field provides the remaining information as given in the formatOf: method (including isPointers, isVariable, isBytes, and the low 2 size bits of byte-sized objects).This implementation includes incremental (2-generation) and full garbage collection, each with compaction and rectification of direct pointers.  It also supports a bulk-become (exchange object identity) feature that allows many objects to be becomed at once, as when all instances of a class must be grown or shrunk.'!!ObjectMemory methodsFor: 'initialization'!adjustAllOopsBy: bytesToShift    "Adjust all oop references by the given number of bytes. This is done just after reading in an image when the new base address of the object heap is different from the base address in the image."    | oop last |    bytesToShift = 0 ifTrue: [ ^ nil ].    oop _ self firstObject.    [oop < endOfMemory] whileTrue: [        (self isFreeObject: oop) ifFalse: [            self adjustFieldsAndClassOf: oop by: bytesToShift.         ].        last _ oop.        oop _ self objectAfter: oop.    ].! !!ObjectMemory methodsFor: 'initialization'!adjustFieldsAndClassOf: oop by: offsetBytes    "Adjust all pointers in this object by the given offset."    | fieldAddr fieldOop classHeader newClassOop |    fieldAddr _ oop + (self lastPointerOf: oop).    [fieldAddr > oop] whileTrue: [        fieldOop _ self longAt: fieldAddr.        (self isIntegerObject: fieldOop) ifFalse: [            self longAt: fieldAddr put: (fieldOop + offsetBytes).        ].        fieldAddr _ fieldAddr - 4.    ].    (self headerType: oop) ~= HeaderTypeShort ifTrue: [        "adjust class header if not a compact class"        classHeader _ self longAt: (oop - 4).        newClassOop _            (classHeader bitAnd: AllButTypeMask) + offsetBytes.        self longAt: (oop - 4) put: (newClassOop bitOr: (classHeader bitAnd: TypeMask)).    ].! !!ObjectMemory methodsFor: 'initialization'!initializeMemoryFirstFree: firstFree     "Initialize endOfMemory to the top of oop storage space, reserving some space for forwarding blocks, and create the freeBlock from which space is allocated. Also create a fake free chunk at endOfMemory to act as a sentinal for memory scans."    "Note: The amount of space reserved for forwarding blocks should be chosen to ensure that incremental compactions can usually be done in a single pass. However, there should be enough forwarding blocks so a full compaction can be done in a reasonable number of passes, say ten. (A full compaction requires N object-moving passes, where N = number of non-garbage objects / number of forwarding blocks)."    | fwdBlockBytes |    "reserve space for forwarding blocks"    fwdBlockBytes _ MinimumForwardTableBytes.    (memoryLimit - fwdBlockBytes) >= (firstFree + BaseHeaderSize) ifFalse: [        "reserve enough space for a minimal free block of BaseHeaderSize bytes"        fwdBlockBytes _ memoryLimit - (firstFree + BaseHeaderSize).    ].    "set endOfMemory and initialize freeBlock"    endOfMemory _ memoryLimit - fwdBlockBytes.    freeBlock _ firstFree.    self setSizeOfFree: freeBlock to: (endOfMemory - firstFree).  "bytes available for oops"    "make a fake free chunk at endOfMemory for use as a sentinal in memory scans"    self setSizeOfFree: endOfMemory to: BaseHeaderSize.    checkAssertions ifTrue: [        ((freeBlock < endOfMemory) and: [endOfMemory < memoryLimit])            ifFalse: [ self error: 'error in free space computation' ].            (self oopFromChunk: endOfMemory) = endOfMemory            ifFalse: [ self error: 'header format must have changed' ].        (self objectAfter: freeBlock) = endOfMemory            ifFalse: [ self error: 'free block not properly initialized' ].    ].! !!ObjectMemory methodsFor: 'initialization' stamp: 'jm 9/14/97 12:51'!initializeObjectMemory: bytesToShift    "Initialize object memory variables at startup time. Assume endOfMemory is initially set (by the image-reading code) to the end of the last object in the image. Initialization redefines endOfMemory to be the end of the object allocation area based on the total available memory, but reserving some space for forwarding blocks."    "Assume: image reader initializes the following variables:        memory        endOfMemory        memoryLimit        specialObjectsOop        lastHash    "    self inline: false.    checkAssertions _ false.  "set this early to allow assertions in initialization code to use it"    "set the start of the young object space"    youngStart _ endOfMemory.    self initializeMemoryFirstFree: endOfMemory.        "initializes endOfMemory, freeBlock"    "image may be at a different address; adjust oops for new location"    self adjustAllOopsBy: bytesToShift.    specialObjectsOop _ specialObjectsOop + bytesToShift.    "heavily used special objects"    nilObj    _ self splObj: NilObject.    falseObj    _ self splObj: FalseObject.    trueObj    _ self splObj: TrueObject.    rootTableCount _ 0.    child _ 0.    field _ 0.    parentField _ 0.    freeLargeContexts _ NilContext.    freeSmallContexts _ NilContext.    allocationCount _ 0.    lowSpaceThreshold _ 0.    signalLowSpace _ false.    compStart _ 0.    compEnd _ 0.    fwdTableNext _ 0.    fwdTableLast _ 0.    remapBufferCount _ 0.    allocationsBetweenGCs _ 4000.  "do incremental GC after this many allocations"    tenuringThreshold _ 2000.  "tenure all suriving objects if count is over this threshold"    "garbage collection statistics"    statFullGCs _ 0.    statFullGCMSecs _ 0.    statIncrGCs _ 0.    statIncrGCMSecs _ 0.    statTenures _ 0.! !!ObjectMemory methodsFor: 'interpreter access'!fetchByte: byteIndex ofObject: oop    ^ self byteAt: (self cCoerce: oop to: 'char *') + BaseHeaderSize + byteIndex! !!ObjectMemory methodsFor: 'interpreter access'!fetchClassOf: oop    | ccIndex |    self inline: true.    (self isIntegerObject: oop)        ifTrue: [ ^ self splObj: ClassInteger ].    ccIndex _ (((self baseHeader: oop) >> 12) bitAnd: 16r1F) - 1.    ccIndex < 0        ifTrue: [ ^ (self classHeader: oop) bitAnd: AllButTypeMask ]        ifFalse: [            "look up compact class"            ^ self fetchPointer: ccIndex                ofObject: (self fetchPointer: CompactClasses ofObject: specialObjectsOop)        ].! !!ObjectMemory methodsFor: 'interpreter access'!fetchPointer: fieldIndex ofObject: oop    ^ self longAt: (self cCoerce: oop to: 'char *') + BaseHeaderSize + (fieldIndex << 2)! !!ObjectMemory methodsFor: 'interpreter access'!fetchWord: fieldIndex ofObject: oop    ^ self longAt: (self cCoerce: oop to: 'char *') + BaseHeaderSize + (fieldIndex << 2)! !!ObjectMemory methodsFor: 'interpreter access'!fetchWordLengthOf: objectPointer    | sz |    sz _ self sizeBitsOf: objectPointer.    ^ (sz - BaseHeaderSize) >> 2! !!ObjectMemory methodsFor: 'interpreter access'!instantiateClass: classPointer indexableSize: size    | hash header1 header2 cClass byteSize format inc binc header3 hdrSize fillWord newObj sizeHiBits |"    NOTE: This method supports the backward-compatible split instSize field of the    class format word.  The sizeHiBits will go away and other shifts change by 2    when the split fields get merged in an (incompatible) image change."    self inline: false.    checkAssertions ifTrue: [        size < 0 ifTrue: [ self error: 'cannot have a negative indexable field count' ]].    hash _ self newObjectHash.    header1 _ self formatOfClass: classPointer. "Low 2 bits are 0"    sizeHiBits _ (header1 bitAnd: 16r60000) >> 9.    header1 _ (header1 bitAnd: 16r1FFFF) bitOr: (hash << 17 bitAnd: 16r1FFE0000).    header2 _ classPointer.    header3 _ 0.    cClass _ header1 bitAnd: 16r1F000. "compact class field from format word"    byteSize _ (header1 bitAnd: 16rFC) + sizeHiBits. "size in bytes -- low 2 bits are 0"    format _ (header1 >> 8) bitAnd: 16rF.    format < 8 ifTrue: [        "Bitmaps and Arrays"        inc _ size * 4.    ] ifFalse: [        "Strings and Methods"        inc _ (size + 3) bitAnd: 16r1FFFFFFC. "round up"        binc _ 3 - ((size + 3) bitAnd: 3). "odd bytes"        "low bits of byte size go in format field"        header1 _ header1 bitOr: (binc << 8).    ].    (byteSize + inc) > 255 ifTrue: [        "requires size header word"        header3 _ byteSize + inc.        header1 _ header1 - (byteSize bitAnd: 16rFF).  "Clear qsize field"    ] ifFalse: [        header1 _ header1 + inc.    ].    byteSize _ byteSize + inc.    header3 > 0 ifTrue: [        "requires full header"        hdrSize _ 3.    ] ifFalse: [        cClass = 0            ifTrue: [ hdrSize _ 2 ]            ifFalse: [ hdrSize _ 1 ].    ].    format < 4  "if pointers, fill with nil oop"        ifTrue: [ fillWord _ nilObj ]        ifFalse: [ fillWord _ 0 ].    newObj _ self allocate: byteSize headerSize: hdrSize h1: header1 h2: header2 h3: header3 fill: fillWord.    ^ newObj! !!ObjectMemory methodsFor: 'interpreter access'!instantiateSmallClass: classPointer sizeInBytes: sizeInBytes fill: fillValue    "This version of instantiateClass assumes that the total object size is under 256 bytes, the limit for objects with only one or two header words. Note that the size is specified in bytes and should include four bytes for the base header word."    | hash header1 header2 hdrSize |    hash _ self newObjectHash.    header1 _ ((hash << 17) bitAnd: 16r1FFE0000) bitOr:               (self formatOfClass: classPointer).    header1 _ header1 + (sizeInBytes - (header1 bitAnd: 16rFC)).    header2 _ classPointer.    (header1 bitAnd: 16r1F000) = 0 "is compact class field from format word zero?"        ifTrue: [ hdrSize _ 2 ]        ifFalse: [ hdrSize _ 1 ].    ^ self allocate: sizeInBytes headerSize: hdrSize h1: header1 h2: header2 h3: 0 fill: fillValue! !!ObjectMemory methodsFor: 'interpreter access'!integerObjectOf: value    value < 0        ifTrue: [^ ((16r80000000 + value) << 1) + 1]        ifFalse: [^ (value << 1) + 1]! !!ObjectMemory methodsFor: 'interpreter access'!integerValueOf: objectPointer    "Translator produces 'objectPointer >> 1'"    ((objectPointer bitAnd: 16r80000000) ~= 0)        ifTrue: ["negative"                ^ ((objectPointer bitAnd: 16r7FFFFFFF) >> 1)                    - 16r3FFFFFFF - 1  "Faster than -16r40000000 (a LgInt)"]        ifFalse: ["positive"                ^ objectPointer >> 1]! !!ObjectMemory methodsFor: 'interpreter access'!isIntegerObject: objectPointer    ^ (objectPointer bitAnd: 1) > 0! !!ObjectMemory methodsFor: 'interpreter access'!isIntegerValue: intValue    "Return true if the given value can be represented as a Smalltalk integer value."    "Details: This trick is from Tim Rowledge. Use a shift and XOR to set the sign bit if and only if the top two bits of the given value are the same, then test the sign bit. Note that the top two bits are equal for exactly those integers in the range that can be represented in 31-bits."    ^ (intValue bitXor: (intValue << 1)) >= 0! !!ObjectMemory methodsFor: 'interpreter access'!nilObject  "For access from BitBlt module"    ^ nilObj! !!ObjectMemory methodsFor: 'interpreter access'!popRemappableOop    "Pop and return the possibly remapped object from the remap buffer."    | oop |    oop _ remapBuffer at: remapBufferCount.    remapBufferCount _ remapBufferCount - 1.    ^ oop! !!ObjectMemory methodsFor: 'interpreter access'!pushRemappableOop: oop    "Record the given object in a the remap buffer. Objects in this buffer are remapped when a compaction occurs. This facility is used by the interpreter to ensure that objects in temporary variables are properly remapped."    remapBuffer at: (remapBufferCount _ remapBufferCount + 1) put: oop.! !!ObjectMemory methodsFor: 'interpreter access'!splObj: index    "Return one of the objects in the SpecialObjectsArray"    ^ self fetchPointer: index ofObject: specialObjectsOop! !!ObjectMemory methodsFor: 'interpreter access'!storeByte: byteIndex ofObject: oop withValue: valueByte    ^ self byteAt: (self cCoerce: oop to: 'char *') + BaseHeaderSize + byteIndex        put: valueByte! !!ObjectMemory methodsFor: 'interpreter access'!storePointer: fieldIndex ofObject: oop withValue: valuePointer    "Note must check here for stores of young objects into old ones."    (oop < youngStart) ifTrue: [        self possibleRootStoreInto: oop value: valuePointer.    ].    ^ self longAt: (self cCoerce: oop to: 'char *') + BaseHeaderSize + (fieldIndex << 2)        put: valuePointer! !!ObjectMemory methodsFor: 'interpreter access'!storePointerUnchecked: fieldIndex ofObject: oop withValue: valuePointer    "Like storePointer:ofObject:withValue:, but the caller guarantees that the object being stored into is a young object or is already marked as a root."    ^ self longAt: (self cCoerce: oop to: 'char *') + BaseHeaderSize + (fieldIndex << 2)            put: valuePointer! !!ObjectMemory methodsFor: 'interpreter access'!storeWord: fieldIndex ofObject: oop withValue: valueWord    ^ self longAt: (self cCoerce: oop to: 'char *') + BaseHeaderSize + (fieldIndex << 2)        put: valueWord! !!ObjectMemory methodsFor: 'memory access'!checkAddress: byteAddress    "Keep this method around for debugging the C code."    byteAddress < (self startOfMemory) ifTrue: [        self error: 'bad address: negative'.    ].    byteAddress >= memoryLimit ifTrue: [        self error: 'bad address: past end of heap'.    ].! !!ObjectMemory methodsFor: 'memory access'!checkedByteAt: byteAddress    "Assumes zero-based array indexing."    self checkAddress: byteAddress.    ^ self byteAt: byteAddress! !!ObjectMemory methodsFor: 'memory access'!checkedByteAt: byteAddress put: byte    "Assumes zero-based array indexing."    self checkAddress: byteAddress.    self byteAt: byteAddress put: byte.! !!ObjectMemory methodsFor: 'memory access'!checkedLongAt: byteAddress    "Assumes zero-based array indexing. For testing in Smalltalk, this method should be overridden in a subclass."    self checkAddress: byteAddress.    self checkAddress: byteAddress + 3.    ^ self longAt: byteAddress! !!ObjectMemory methodsFor: 'memory access'!checkedLongAt: byteAddress put: a32BitInteger    "Assumes zero-based array indexing. For testing in Smalltalk, this method should be overridden in a subclass."    self checkAddress: byteAddress.    self checkAddress: byteAddress + 3.    self longAt: byteAddress put: a32BitInteger.! !!ObjectMemory methodsFor: 'header access'!baseHeader: oop    ^ self longAt: oop! !!ObjectMemory methodsFor: 'header access'!classHeader: oop    ^ self longAt: oop - 4! !!ObjectMemory methodsFor: 'header access'!formatOf: oop"       0      no fields        1      fixed fields only (possibly containing pointers)        2      indexable fields only (possibly containing pointers)        3      both fixed and indexable fields (possibly containing pointers)         4      unused  -- may use for contexts (size = stackPointer for scanning purposes)        5      unused        6      indexable word fields only (no pointers)        7      unused     8-11      indexable byte fields only (no pointers) (low 2 bits are low 2 bits of size)   12-15     compiled methods:                   # of literal oops specified in method header,                   followed by indexable bytes (same interpretation of low 2 bits as above)"    ^ ((self baseHeader: oop) >> 8) bitAnd: 16rF! !!ObjectMemory methodsFor: 'header access'!hashBitsOf: oop    ^ ((self baseHeader: oop) >> 17) bitAnd: 16rFFF! !!ObjectMemory methodsFor: 'header access'!headerType: oop    ^ (self longAt: oop) bitAnd: TypeMask! !!ObjectMemory methodsFor: 'header access'!isBytes: oop    "Answer true if the argument contains indexable bytes. See comment in formatOf:"    "Note: Includes CompiledMethods."    ^ (self formatOf: oop)  >= 8! !!ObjectMemory methodsFor: 'header access'!isFreeObject: oop    ^ (self headerType: oop) = HeaderTypeFree! !!ObjectMemory methodsFor: 'header access'!isPointers: oop    "Answer true if the argument has only fields that can hold oops. See comment in formatOf:"    ^ (self formatOf: oop) <= 4! !!ObjectMemory methodsFor: 'header access'!isWords: oop    "Answer true if the argument contains only indexable words (no oops). See comment in formatOf:"    ^ (self formatOf: oop) = 6! !!ObjectMemory methodsFor: 'header access'!isWordsOrBytes: oop    "Answer true if the contains only indexable words or bytes (no oops). See comment in formatOf:"    "Note: Excludes CompiledMethods."    | fmt |    fmt _ self formatOf: oop.    ^ fmt = 6 or: [(fmt >= 8) and: [fmt <= 11]]! !!ObjectMemory methodsFor: 'header access'!newObjectHash    "Answer a new 16-bit pseudo-random number for use as an identity hash."    lastHash _ 13849 + (27181 * lastHash) bitAnd: 65535.    ^ lastHash! !!ObjectMemory methodsFor: 'header access'!rightType: headerWord    "Computer the correct header type for an object based on the size and compact class fields of the given base header word, rather than its type bits. This is used during marking, when the header type bits are used to record the state of tracing."    (headerWord bitAnd: 16rFC) = 0  "zero size field in header word"        ifTrue: [ ^ HeaderTypeSizeAndClass ]        ifFalse: [            (headerWord bitAnd: 16r1F000) = 0  "zero compact class field  in header word"                ifTrue: [ ^ HeaderTypeClass ]                ifFalse: [ ^ HeaderTypeShort ]].! !!ObjectMemory methodsFor: 'header access'!setSizeOfFree: chunk to: byteSize    "Set the header of the given chunk to make it be a free chunk of the given size."    self longAt: chunk put: ((byteSize bitAnd: FreeSizeMask) bitOr: HeaderTypeFree).! !!ObjectMemory methodsFor: 'header access'!sizeBitsOf: oop    "Answer the number of bytes in the given object, including its base header, rounded up to an integral number of words."    "Note: byte indexable objects need to have low bits subtracted from this size."    | header |    header _ self baseHeader: oop.    (header bitAnd: TypeMask) = HeaderTypeSizeAndClass        ifTrue: [ ^ (self sizeHeader: oop) bitAnd: AllButTypeMask ]        ifFalse: [ ^ header bitAnd: 16rFC ].! !!ObjectMemory methodsFor: 'header access'!sizeBitsOfSafe: oop    "Compute the size of the given object from the cc and size fields in its header. This works even if its type bits are not correct."    | header type |    header _ self baseHeader: oop.    type _ self rightType: header.    type = HeaderTypeSizeAndClass        ifTrue: [ ^ (self sizeHeader: oop) bitAnd: AllButTypeMask ]        ifFalse: [ ^ header bitAnd: 16rFC ].! !!ObjectMemory methodsFor: 'header access'!sizeHeader: oop    ^ self longAt: oop - 8! !!ObjectMemory methodsFor: 'header access'!sizeOfFree: oop    "Return the size of the given chunk in bytes. Argument MUST be a free chunk."    ^ (self longAt: oop) bitAnd: FreeSizeMask! !!ObjectMemory methodsFor: 'object enumeration'!accessibleObjectAfter: oop    "Return the accessible object following the given object or free chunk in the heap. Return nil when heap is exhausted."    | obj |    self inline: false.    obj _ self objectAfter: oop.    [obj < endOfMemory] whileTrue: [        (self isFreeObject: obj) ifFalse: [ ^obj ].        obj _ self objectAfter: obj.    ].    ^ nil! !!ObjectMemory methodsFor: 'object enumeration'!firstAccessibleObject    "Return the first accessible object in the heap."    | obj |    obj _ self firstObject.    [obj < endOfMemory] whileTrue: [        (self isFreeObject: obj) ifFalse: [ ^obj ].        obj _ self objectAfter: obj.    ].    self error: 'heap is empty'! !!ObjectMemory methodsFor: 'object enumeration'!firstObject    "Return the first object or free chunk in the heap."    ^ self oopFromChunk: self startOfMemory! !!ObjectMemory methodsFor: 'object enumeration'!initialInstanceOf: classPointer    "Support for instance enumeration. Return the first instance of the given class, or nilObj if it has no instances."    | thisObj thisClass |    thisObj _ self firstAccessibleObject.    [thisObj = nil] whileFalse: [        thisClass _ self fetchClassOf: thisObj.        thisClass = classPointer ifTrue: [ ^thisObj ].        thisObj _ self accessibleObjectAfter: thisObj.    ].    ^nilObj! !!ObjectMemory methodsFor: 'object enumeration'!instanceAfter: objectPointer    "Support for instance enumeration. Return the next instance of the class of the given object, or nilObj if the enumeration is complete."    | classPointer thisObj thisClass |    classPointer _ (self fetchClassOf: objectPointer).    thisObj _ self accessibleObjectAfter: objectPointer.    [thisObj = nil] whileFalse: [        thisClass _ self fetchClassOf: thisObj.        thisClass = classPointer ifTrue: [ ^thisObj ].        thisObj _ self accessibleObjectAfter: thisObj.    ].    ^nilObj! !!ObjectMemory methodsFor: 'object enumeration'!lastPointerOf: objectPointer    "Return the byte offset of the last pointer field of the given object. Works with CompiledMethods, as well as ordinary objects. Can be used even when the type bits are not correct."    | fmt sz methodHeader |    self inline: true.    fmt _ self formatOf: objectPointer.    fmt < 4 ifTrue: [        sz _ self sizeBitsOfSafe: objectPointer.        ^ sz - BaseHeaderSize  "all pointers"    ].    fmt < 12 ifTrue: [ ^0 ].  "no pointers"    "CompiledMethod: contains both pointers and bytes:"    methodHeader _ self longAt: objectPointer + BaseHeaderSize.    ^ ((methodHeader >> 10) bitAnd: 16rFF) * 4 + BaseHeaderSize! !!ObjectMemory methodsFor: 'object enumeration'!objectAfter: oop    "Return the object or free chunk immediately following the given object or free chunk in memory. Return endOfMemory when enumeration is complete."    | sz |    self inline: true.    checkAssertions ifTrue: [        oop >= endOfMemory ifTrue: [ self error: 'no objects after the end of memory' ].    ].    (self isFreeObject: oop)        ifTrue: [ sz _ self sizeOfFree: oop ]        ifFalse: [ sz _ self sizeBitsOf: oop ].    ^ self oopFromChunk: (oop + sz)! !!ObjectMemory methodsFor: 'object enumeration'!startOfMemory    "Return the start of object memory."    ^ self cCode: '(int) memory'! !!ObjectMemory methodsFor: 'oop/chunk conversion'!chunkFromOop: oop    "Compute the chunk of this oop by subtracting its extra header bytes."    | extra |    extra _ self extraHeaderBytes: oop.    ^ oop - extra! !!ObjectMemory methodsFor: 'oop/chunk conversion'!extraHeaderBytes: oopOrChunk    "Return the number of extra bytes used by the given object's header."    "Warning: This method should not be used during marking, when the header type bits of an object may be incorrect."    | type extra |    self inline: true.    type _ self headerType: oopOrChunk.    type > 1 ifTrue: [        extra _ 0.  "free chunk (type 2) or 1-word header (type 3); most common"    ] ifFalse: [        type = 1            ifTrue: [ extra _ 4.  "2-word header (type 1)" ]            ifFalse: [ extra _ 8.  "3-word header (type 0)" ].    ].    ^ extra! !!ObjectMemory methodsFor: 'oop/chunk conversion'!oopFromChunk: chunk    "Compute the oop of this chunk by adding its extra header bytes."    | extra |    extra _ self extraHeaderBytes: chunk.    ^ chunk + extra! !!ObjectMemory methodsFor: 'allocation'!allocate: byteSize headerSize: hdrSize h1: baseHeader h2: classOop h3: extendedSize fill: fillWord    "Allocate a new object of the given size and number of header words. (Note: byteSize already includes space for the base header word.) Initialize the header fields of the new object and fill the remainder of the object with the given value."    | newObj remappedClassOop end i |    self inline: true.    "remap classOop in case GC happens during allocation"    hdrSize > 1 ifTrue: [ self pushRemappableOop: classOop ].      newObj _ self allocateChunk: byteSize + ((hdrSize - 1) * 4).    hdrSize > 1 ifTrue: [ remappedClassOop _ self popRemappableOop ].    hdrSize = 3 ifTrue: [        self longAt: newObj      put: (extendedSize bitOr: HeaderTypeSizeAndClass).        self longAt: newObj + 4 put: (remappedClassOop bitOr: HeaderTypeSizeAndClass).        self longAt: newObj + 8 put: (baseHeader bitOr: HeaderTypeSizeAndClass).        newObj _ newObj + 8.    ].    hdrSize = 2 ifTrue: [        self longAt: newObj      put: (remappedClassOop bitOr: HeaderTypeClass).        self longAt: newObj + 4 put: (baseHeader bitOr: HeaderTypeClass).        newObj _ newObj + 4.    ].    hdrSize = 1 ifTrue: [        self longAt: newObj put: (baseHeader bitOr: HeaderTypeShort).    ].    "clear new object"    end _ newObj + byteSize.    i _ newObj + 4.    [i < end] whileTrue: [        self longAt: i put: fillWord.        i _ i + 4.    ].    checkAssertions ifTrue: [        self okayOop: newObj.        self oopHasOkayClass: newObj.        (self objectAfter: newObj) = freeBlock            ifFalse: [ self error: 'allocate bug: did not set header of new oop correctly' ].        (self objectAfter: freeBlock) = endOfMemory            ifFalse: [ self error: 'allocate bug: did not set header of freeBlock correctly' ].    ].    ^ newObj! !!ObjectMemory methodsFor: 'allocation' stamp: 'jm 9/14/97 11:14'!allocateChunk: byteSize     "Allocate a chunk of the given size. Sender must be sure that the requested size includes enough space for the header word(s)."    "Details: To limit the time per incremental GC, do one every so many allocations."    | enoughSpace newFreeSize newChunk |    self inline: true.    allocationCount >= allocationsBetweenGCs ifTrue: [        "do an incremental GC every so many allocations to keep pauses short"        self incrementalGC.    ].    enoughSpace _ self sufficientSpaceToAllocate: byteSize.    enoughSpace ifFalse: [        "signal that space is running low, put proceed with allocation if possible"        signalLowSpace _ true.        lowSpaceThreshold _ 0.  "disable additional interrupts until lowSpaceThreshold is reset by image"        interruptCheckCounter _ 0.    ].    (self sizeOfFree: freeBlock) < (byteSize + BaseHeaderSize) ifTrue: [        self error: 'out of memory'.    ].    "if we get here, there is enough space for allocation to succeed"    newFreeSize _ (self sizeOfFree: freeBlock) - byteSize.    newChunk _ freeBlock.    freeBlock _ freeBlock + byteSize.    "Assume: client will initialize object header of free chunk, so following is not needed:"    "self setSizeOfFree: newChunk to: byteSize."    self setSizeOfFree: freeBlock to: newFreeSize.    allocationCount _ allocationCount + 1.    ^ newChunk! !!ObjectMemory methodsFor: 'allocation'!allocateOrRecycleContext: smallContextWanted    "Return a recycled context or a newly allocated one if none is available for recycling. The argument indicates that a small context is wanted."    | cntxt |    self inline: true.    smallContextWanted ifTrue: [        freeSmallContexts ~= NilContext ifTrue: [            cntxt _ freeSmallContexts.            freeSmallContexts _ self fetchPointer: 0 ofObject: cntxt.        ] ifFalse: [            cntxt _ self instantiateSmallClass: (self splObj: ClassMethodContext)                                 sizeInBytes: SmallContextSize                                         fill: nilObj.        ].    ] ifFalse: [        freeLargeContexts ~= NilContext ifTrue: [            cntxt _ freeLargeContexts.            freeLargeContexts _ self fetchPointer: 0 ofObject: cntxt.        ] ifFalse: [            cntxt _ self instantiateSmallClass: (self splObj: ClassMethodContext)                                sizeInBytes: LargeContextSize                                        fill: nilObj.        ].    ].    ^ cntxt! !!ObjectMemory methodsFor: 'allocation'!clone: oop    "Return a shallow copy of the given object."    "Assume: Oop is a real object, not a small integer."    | extraHdrBytes bytes newChunk remappedOop fromIndex toIndex lastFrom newOop header hash |    self inline: false.    extraHdrBytes _ self extraHeaderBytes: oop.    bytes _ self sizeBitsOf: oop.    bytes _ bytes + extraHdrBytes.    "allocate space for the copy, remapping oop in case of a GC"    self pushRemappableOop: oop.    newChunk _ self allocateChunk: bytes.    remappedOop _ self popRemappableOop.    "copy old to new including all header words"    toIndex _ newChunk - 4.  "loop below uses pre-increment"    fromIndex _ (remappedOop - extraHdrBytes) - 4.    lastFrom _ fromIndex + bytes.    [fromIndex < lastFrom] whileTrue: [        self longAt: (toIndex _ toIndex + 4)            put: (self longAt: (fromIndex _ fromIndex + 4)).    ].    newOop _ newChunk + extraHdrBytes.  "convert from chunk to oop"    "fix base header: compute new hash and clear Mark and Root bits"    hash _ self newObjectHash.    header _ (self longAt: newOop) bitAnd: 16r1FFFF.        "use old ccIndex, format, size, and header-type fields"    header _ header bitOr: ((hash << 17) bitAnd: 16r1FFE0000).    self longAt: newOop put: header.    ^ newOop! !!ObjectMemory methodsFor: 'allocation'!recycleContextIfPossible: cntxOop methodContextClass: methodCntxClass    "If possible, save the given context on a list of free contexts to be recycled."    "Note: The context is not marked free, so it can be reused with minimal fuss. It's fields are nil-ed out when it is re-used. The recycled context lists are cleared at every garbage collect."    "Note: This code was found to be critical to good send/return speed, so it has been ruthlessly hand-tuned."    | cntxHeader ccField isMethodCntx |    self inline: true.    "only recycle young contexts (which should be most of them)"    cntxOop >= youngStart ifTrue: [        "is the context of class methodCntxClass?"        cntxHeader _ self baseHeader: cntxOop.        ccField _ cntxHeader bitAnd: 16r1F000.        ccField = 0 ifTrue: [            isMethodCntx _ ((self classHeader: cntxOop) bitAnd: AllButTypeMask) = methodCntxClass.        ] ifFalse: [            "compare ccField with compact class bits from format word of methodCntxClass"            isMethodCntx _ ccField = ((self formatOfClass: methodCntxClass) bitAnd: 16r1F000).        ].        isMethodCntx ifTrue: [            "Note: The following test depends on the format of object headers             and the fact that both small and large contexts are small enough             for their size to be encoded in the base object header. If these             assumptions is false, contexts won't be recycled properly, but the             code should not break."            (cntxHeader bitAnd: 16rFC) = SmallContextSize ifTrue: [                self storePointerUnchecked: 0 ofObject: cntxOop withValue: freeSmallContexts.                freeSmallContexts _ cntxOop.                ] ifFalse: [                self storePointerUnchecked: 0 ofObject: cntxOop withValue: freeLargeContexts.                freeLargeContexts _ cntxOop.                ].        ].    ].! !!ObjectMemory methodsFor: 'allocation'!sufficientSpaceAfterGC: minFree    "Return true if there is enough free space after doing a garbage collection. If not, signal that space is low."    self inline: false.    self incrementalGC.  "try to recover some space"    (self sizeOfFree: freeBlock) < minFree ifTrue: [        signalLowSpace ifTrue: [ ^ false ].  "give up; problem is already noted"        self fullGC.  "try harder"        "for stability, require more free space after doing an expensive full GC"        (self sizeOfFree: freeBlock) < (minFree + 15000) ifTrue: [ ^ false ].  "still not enough"    ].    ^ true! !!ObjectMemory methodsFor: 'allocation'!sufficientSpaceToAllocate: bytes    "Return true if there is enough space to allocate the given number of bytes, perhaps after doing a garbage collection."    | minFree |    self inline: true.    minFree _ lowSpaceThreshold + bytes + BaseHeaderSize.    "check for low-space"    (self sizeOfFree: freeBlock) >= minFree ifTrue: [        ^ true.    ] ifFalse: [        ^ self sufficientSpaceAfterGC: minFree.    ].! !!ObjectMemory methodsFor: 'garbage collection'!beRootIfOld: oop    "Record that the given oop in the old object area may point to an object in the young area."    | header |    self inline: false.    ((oop < youngStart) and: [(self isIntegerObject: oop) not]) ifTrue: [        "oop is in the old object area"        header _ self longAt: oop.        (header bitAnd: RootBit) = 0 ifTrue: [            "record oop as root only if not already recorded"            rootTableCount < RootTableSize ifTrue: [                "record root only if there is room in the roots table"                rootTableCount _ rootTableCount + 1.                rootTable at: rootTableCount put: oop.                self longAt: oop put: (header bitOr: RootBit).            ].        ].    ].! !!ObjectMemory methodsFor: 'garbage collection'!clearRootsTable    "Clear the root bits of the current roots, then empty the roots table."    "Caution: This should only be done when the young object space is empty."    | oop |    "reset the roots table (after this, all objects are old so there are no roots)"    1 to: rootTableCount do: [ :i |        "clear root bits of current root table entries"        oop _ rootTable at: i.        self longAt: oop put: ((self longAt: oop) bitAnd: AllButRootBit).        rootTable at: i put: 0.    ].    rootTableCount _ 0.! !!ObjectMemory methodsFor: 'garbage collection'!fullCompaction    "Move all accessible objects down to leave one big free chunk at the end of memory."    "Assume: Incremental GC has just been done to maximimize forwarding table space."    "need not move objects below the first free chunk"    compStart _ self lowestFreeAfter: (self startOfMemory).    compStart = freeBlock ifTrue: [        "memory is already compact; only free chunk is at the end"        ^ self initializeMemoryFirstFree: freeBlock    ].    "work up through memory until all free space is at the end"    [compStart < freeBlock] whileTrue: [        "free chunk returned by incCompBody becomes start of next compaction"        compStart _ self incCompBody.  "bubble of free space moves up each time"    ].! !!ObjectMemory methodsFor: 'garbage collection' stamp: 'jm 9/14/97 12:52'!fullGC    "Do a mark/sweep garbage collection of the entire object memory. Free inaccessible objects but do not move them."    | startTime |    self inline: false.    startTime _ self ioMicroMSecs.    self clearRootsTable.    youngStart _ self startOfMemory.  "process all of memory"    self markPhase.    self sweepPhase.    self fullCompaction.    allocationCount _ 0.    statFullGCs _ statFullGCs + 1.    statFullGCMSecs _ statFullGCMSecs + (self ioMicroMSecs - startTime).    youngStart _ freeBlock.  "reset the young object boundary"    self postGCAction.! !!ObjectMemory methodsFor: 'garbage collection'!incrementalCompaction    "Move objects down to make one big free chunk. Compact the last N objects (where N = number of forwarding table entries) of the young object area."    "Assume: compStart was set during the sweep phase"    compStart = freeBlock ifTrue: [        "Note: If compStart = freeBlock then either the young space is already compact         or there are enough forwarding table entries to do a one-pass incr. compaction."        self initializeMemoryFirstFree: freeBlock.    ] ifFalse: [        self incCompBody.    ].! !!ObjectMemory methodsFor: 'garbage collection' stamp: 'jm 9/14/97 12:55'!incrementalGC    "Do a mark/sweep garbage collection of just the young object area of object memory (i.e., objects above youngStart), using the root table to identify objects containing pointers to young objects from the old object area."    | survivorCount startTime |    self inline: false.    rootTableCount >= RootTableSize ifTrue: [        "root table overflow; cannot do an incremental GC (this should be very rare)"        ^ self fullGC    ].    "incremental GC and compaction"    startTime _ self ioMicroMSecs.    self markPhase.    survivorCount _ self sweepPhase.    self incrementalCompaction.    allocationCount _ 0.    statIncrGCs _ statIncrGCs + 1.    statIncrGCMSecs _ statIncrGCMSecs + (self ioMicroMSecs - startTime).    survivorCount > tenuringThreshold ifTrue: [        "move up the young space boundary if there are too many survivors;         this limits the number of objects that must be processed on future         incremental GC's"        statTenures _ statTenures + 1.        self clearRootsTable.        youngStart _ freeBlock.  "reset the young object boundary"    ].    self postGCAction.! !!ObjectMemory methodsFor: 'garbage collection'!lowestFreeAfter: chunk    "Return the first free block after the given chunk in memory."    | oop oopHeader oopHeaderType oopSize |    self inline: false.    oop _ self oopFromChunk: chunk.    [oop < endOfMemory] whileTrue: [        oopHeader _ self baseHeader: oop.        oopHeaderType _ oopHeader bitAnd: TypeMask.        (oopHeaderType = HeaderTypeFree)            ifTrue: [ ^ oop ]            ifFalse: [                oopHeaderType = HeaderTypeSizeAndClass                    ifTrue: [ oopSize _ (self sizeHeader: oop) bitAnd: AllButTypeMask ]                    ifFalse: [ oopSize _ oopHeader bitAnd: 16rFC ].            ].        oop _ self oopFromChunk: (oop + oopSize).    ].    self error: 'expected to find at least one free object'.! !!ObjectMemory methodsFor: 'garbage collection'!possibleRootStoreInto: oop value: valueObj    "Called when storing the given value object into the given old object. If valueObj is young, record the fact that oldObj is now a root for incremental garbage collection."    "Warning: No young objects should be recorded as roots."    | header |    self inline: false.    ((valueObj >= youngStart) and:     [(self isIntegerObject: valueObj) not]) ifTrue: [        header _ self longAt: oop.        (header bitAnd: RootBit) = 0 ifTrue: [            "record oop as root only if not already recorded"            rootTableCount < RootTableSize ifTrue: [                "record root only if there is room in the roots table"                rootTableCount _ rootTableCount + 1.                rootTable at: rootTableCount put: oop.                self longAt: oop put: (header bitOr: RootBit).            ].        ].    ].! !!ObjectMemory methodsFor: 'gc -- mark and sweep'!aComment    "The mark phase is based on a pointer reversing traversal. This is a little tricky because the class, which is needed by the traversal, may be in either the header (as a compact class index) or in the word above the header. See memo 'Revised object format'.    Compact classes are marked and traced separately.    How do you know that you are returning from having marked a class? Parent pointer has 10 in low bits.Here are the states an object may be in, followed by what to do next in brackets []:  Start Object: parentField is set, [obj _ child]:    obj is pointed at by a field in parent that is being traced now. obj is marked.        [(parent goes up to the next field) field addr _ obj. go to Upward]    obj is pointed at by a field in parent that is being traced now. obj is unmarked. obj has no pointers.        [put 10 into low bits of header. field addr _ obj. go to Start Field (to process class word)]    obj is pointed at by a field in parent that is being traced now. obj is unmarked. obj has pointers.        [put 10 into low bits of header. point to last field. go to Start Field]  Start Field:     Field ends in 10. It is the header. Short Class is not 0.        [Set low bits to correct value. (have parent pointer) go to Upward]    Field ends in 10. It is the header. Short Class is 0.        [child _ word above header. low bits of child _ 01. class word _ parentField. parentField _ loc of class word. go to Start Obj]    Field is Integer.        [point one word up, go to Start Field]    Field is oop.        [child _ field. field _ parentField. parentField _ loc of field. go to Start Obj]  Upward [restore low bits of header (at field addr)]:    parentField is 3. (bits 11, int 1).        [done!!]    parentField ends in 00.        [child _ field addr. field addr _ parentField. parentField _ field addr contents.        field addr contents _ child (addr of prev object. its oop). field addr - 4. go to Start Field]    parentField ends in 01. Were tracing the class.        [child _ field addr. field addr _ parentField (loc of class word). parentField _ field addr contents.        field addr contents _ child (addr of prev object. its oop). field addr + 4 (header). go to Upward]"! !!ObjectMemory methodsFor: 'gc -- mark and sweep'!markAndTrace: oop    "Mark all objects reachable from the given one. Trace from the given object even if it is old or already marked. Mark it only if it is a young object."    "Tracer state variables:        child        object being examined        field        next field of child to examine        parentField    field where child was stored in its referencing object"    | header lastFieldOffset action |    "record tracing status in object's header"    header _ self longAt: oop.    header _ (header bitAnd: AllButTypeMask) bitOr: HeaderTypeGC.    oop >= youngStart ifTrue: [ header _ header bitOr: MarkBit ].  "mark only if young"    self longAt: oop put: header.    "initialize the tracer state machine"    parentField _ GCTopMarker.    child _ oop.    lastFieldOffset _ self lastPointerOf: oop.    field _ oop + lastFieldOffset.    action _ StartField.    "run the tracer state machine until all objects reachable from oop are marked"    [action = Done] whileFalse: [        action = StartField    ifTrue: [ action _ self startField ].        action = StartObj        ifTrue: [ action _ self startObj ].        action = Upward        ifTrue: [ action _ self upward ].    ].! !!ObjectMemory methodsFor: 'gc -- mark and sweep'!markPhase    "Mark phase of the mark and sweep garbage collector. Set the mark bits of all reachable objects. Free chunks are untouched by this process."    "Assume: All non-free objects are initially unmarked. Root objects were unmarked when they were made roots. (Make sure this stays true!!!!)."    | oop |    self inline: false.    "clear the recycled context lists"    freeSmallContexts _ NilContext.    freeLargeContexts _ NilContext.    "trace the interpreter's objects, including the active stack and special objects array"    self markAndTraceInterpreterOops.    "trace the roots"    1 to: rootTableCount do: [ :i |         oop _ rootTable at: i.        (self isIntegerObject: oop) ifFalse: [ self markAndTrace: oop ].    ].! !!ObjectMemory methodsFor: 'gc -- mark and sweep'!startField    "Examine and possibly trace the next field of the object being traced. See comment in markAndTrace for explanation of tracer state variables."    | typeBits childType |    child _ self longAt: field.    typeBits _ child bitAnd: TypeMask.    (typeBits bitAnd: 1) = 1 ifTrue: [        "field contains a SmallInteger; skip it"        field _ field - 4.        ^ StartField    ].    typeBits = 0 ifTrue: [        "normal oop, go down"        self longAt: field put: parentField.        parentField _ field.        ^ StartObj    ].    typeBits = 2 ifTrue: [        "reached the header; do we need to process the class word?"        (child bitAnd: 16r1F000) ~= 0 ifTrue: [            "object's class is compact; we're done"            "restore the header type bits"            child _ child bitAnd: AllButTypeMask.            childType _ self rightType: child.            self longAt: field put: (child bitOr: childType).            ^ Upward        ] ifFalse: [            "object has a full class word; process that class"            child _ self longAt: (field - 4).  "class word"            child _ child bitAnd: AllButTypeMask.  "clear type bits"            self longAt: (field - 4) put: parentField.            parentField _ (field - 4) bitOr: 1.  "point at class word; mark as working on the class."            ^ StartObj        ].    ].! !!ObjectMemory methodsFor: 'gc -- mark and sweep'!startObj    "Start tracing the object 'child' and answer the next action. The object may be anywhere in the middle of being swept itself. See comment in markAndTrace for explanation of tracer state variables."    | oop header lastFieldOffset |    oop _ child.    oop < youngStart ifTrue: [        "old object; skip it"         field _ oop.        ^ Upward    ].    header _ self longAt: oop.    (header bitAnd: MarkBit) = 0 ifTrue: [        "unmarked; mark and trace"        header _ header bitAnd: AllButTypeMask.        header _ (header bitOr: MarkBit) bitOr: HeaderTypeGC.        self longAt: oop put: header.        lastFieldOffset _ self lastPointerOf: oop.        field _ oop + lastFieldOffset.        ^ StartField    "trace its fields and class"    ] ifFalse: [        "already marked; skip it"        field _ oop.        ^ Upward    ].! !!ObjectMemory methodsFor: 'gc -- mark and sweep'!sweepPhase    "Sweep memory from youngStart through the end of memory. Free all inaccessible objects and coalesce adjacent free chunks. Clear the mark bits of accessible objects. Compute the starting point for the first pass of incremental compaction (compStart). Return the number of surviving objects."    "Details: Each time a non-free object is encountered, decrement the number of available forward table entries. If all entries are spoken for (i.e., entriesAvailable reaches zero), set compStart to the last free chunk before that object or, if there is no free chunk before the given object, the first free chunk after it. Thus, at the end of the sweep phase, compStart through compEnd spans the highest collection of non-free objects that can be accomodated by the forwarding table. This information is used by the first pass of incremental compaction to ensure that space is initially freed at the end of memory. Note that there should always be at least one free chunk--the one at the end of the heap."    | entriesAvailable survivors freeChunk firstFree oop oopHeader oopHeaderType hdrBytes oopSize freeChunkSize |    self inline: false.    entriesAvailable _ self fwdTableInit.    survivors _ 0.    freeChunk _ nil.    firstFree _ nil.  "will be updated later"    oop _ self oopFromChunk: youngStart.    [oop < endOfMemory] whileTrue: [        "get oop's header, header type, size, and header size"        oopHeader _ self baseHeader: oop.        oopHeaderType _ oopHeader bitAnd: TypeMask.        (oopHeaderType = HeaderTypeShort) ifTrue: [            oopSize _ oopHeader bitAnd: 16rFC.            hdrBytes _ 0.        ] ifFalse: [            (oopHeaderType = HeaderTypeClass) ifTrue: [                oopSize _ oopHeader bitAnd: 16rFC.                hdrBytes _ 4.            ] ifFalse: [                (oopHeaderType = HeaderTypeSizeAndClass) ifTrue: [                    oopSize _ (self sizeHeader: oop) bitAnd: AllButTypeMask.                    hdrBytes _ 8.                ] ifFalse: [  "free chunk"                    oopSize _ oopHeader bitAnd: FreeSizeMask.                    hdrBytes _ 0.                ].            ].        ].        (oopHeader bitAnd: MarkBit) = 0 ifTrue: [            "object is not marked; free it"            freeChunk ~= nil ifTrue: [                "enlarge current free chunk to include this oop"                freeChunkSize _ freeChunkSize + oopSize + hdrBytes.            ] ifFalse: [                "start a new free chunk"                freeChunk _ oop - hdrBytes.  "chunk may start 4 or 8 bytes before oop"                freeChunkSize _ oopSize + (oop - freeChunk).  "adjust size for possible extra header bytes"                firstFree = nil ifTrue: [ firstFree _ freeChunk ].            ].        ] ifFalse: [            "object is marked; clear its mark bit and possibly adjust the compaction start"            self longAt: oop put: (oopHeader bitAnd: AllButMarkBit).            entriesAvailable > 0 ifTrue: [                entriesAvailable _ entriesAvailable - 1.            ] ifFalse: [                "start compaction at the last free chunk before this object"                firstFree _ freeChunk.            ].            freeChunk ~= nil ifTrue: [                "record the size of the last free chunk"                self longAt: freeChunk                        put: ((freeChunkSize bitAnd: FreeSizeMask) bitOr: HeaderTypeFree).            ].            freeChunk _ nil.            survivors _ survivors + 1.        ].        oop _ self oopFromChunk: (oop + oopSize).  "get next oop"    ].    freeChunk ~= nil ifTrue: [        "record size of final free chunk"        self longAt: freeChunk                put: ((freeChunkSize bitAnd: FreeSizeMask) bitOr: HeaderTypeFree).    ].    oop = endOfMemory        ifFalse: [ self error: 'sweep failed to find exact end of memory' ].    firstFree = nil        ifTrue: [ self error: 'expected to find at least one free object' ]        ifFalse: [ compStart _ firstFree ].    ^ survivors! !!ObjectMemory methodsFor: 'gc -- mark and sweep'!upward    "Return from marking an object below. Incoming:        field = oop we just worked on, needs to be put away        parentField = where to put it in our object    NOTE: Type field of object below has already been restored!!!!!!"    | type header |    (parentField bitAnd: 1) = 1 ifTrue: [        parentField = GCTopMarker ifTrue: [            "top of the chain"            header _ (self longAt: field) bitAnd: AllButTypeMask.            type _ self rightType: header.            self longAt: field put: header + type.  "install type on class oop"            ^ Done        ] ifFalse: [            "was working on the extended class word"            child _ field.    "oop of class"            field _ parentField - 1.  "class word, ** clear the low bit **"            parentField _ self longAt: field.            header _ self longAt: field+4.  "base header word"            type _ self rightType: header.            self longAt: field put: child + type.  "install type on class oop"            field _ field + 4.  "point at header"            "restore type bits"            header _ header bitAnd: AllButTypeMask.            self longAt: field put: (header + type).            ^ Upward        ].    ] ifFalse: [        "normal"        child _ field.  "who we worked on below"        field _ parentField.  "where to put it"        parentField _ self longAt: field.        self longAt: field put: child.        field _ field - 4.  "point at header"        ^ StartField    ].! !!ObjectMemory methodsFor: 'gc -- compaction'!beRootWhileForwarding: oop    "Record that the given oop in the old object area points to an object in the young area when oop may be forwarded. Like beRoot:"    "Warning: No young objects should be recorded as roots. Callers are responsible for ensuring this constraint is not violated."    | header forwarding fwdBlock newHeader |    header _ self longAt: oop.    (header bitAnd: MarkBit) ~= 0 ifTrue: [        forwarding _ true.        fwdBlock _ header bitAnd: AllButMarkBitAndTypeMask.        checkAssertions ifTrue: [ self fwdBlockValidate: fwdBlock ].        header _ self longAt: fwdBlock + 4.    ] ifFalse: [        forwarding _ false.    ].    (header bitAnd: RootBit) = 0 ifTrue: [        "record oop as root only if not already recorded"        rootTableCount < RootTableSize ifTrue: [            "record root only if there is room in the roots table"            rootTableCount _ rootTableCount + 1.            rootTable at: rootTableCount put: oop.            newHeader _ header bitOr: RootBit.            forwarding                ifTrue: [ self longAt: (fwdBlock + 4) put: newHeader ]                ifFalse: [ self longAt: oop put: newHeader ].        ].    ].! !!ObjectMemory methodsFor: 'gc -- compaction'!fwdBlockGet    "Return the address of a two-word forwarding block or nil if no more entries are available."    fwdTableNext _ fwdTableNext + 8.    fwdTableNext <= fwdTableLast        ifTrue: [ ^ fwdTableNext ]        ifFalse: [ ^ nil ].  "no more forwarding blocks available"! !!ObjectMemory methodsFor: 'gc -- compaction'!fwdBlockValidate: addr    "Raise an error if the given address is not a valid forward table entry."    (( addr > endOfMemory) and:     [(addr <= fwdTableNext) and:     [(addr bitAnd: 3) = 0]])        ifFalse: [ self error: 'invalid fwd table entry' ].! !!ObjectMemory methodsFor: 'gc -- compaction'!fwdTableInit    "Set the limits for a table of two-word forwarding blocks above the last used oop. The pointer fwdTableNext moves up to fwdTableLast. Used for compaction of memory and become-ing objects. Returns the number of forwarding blocks available."    self inline: false.    "set endOfMemory to just after a minimum-sized free block"    self setSizeOfFree: freeBlock to: BaseHeaderSize.    endOfMemory _ freeBlock + BaseHeaderSize.    "make a fake free chunk at endOfMemory for use as a sentinal in memory scans"    self setSizeOfFree: endOfMemory to: BaseHeaderSize.    "use all memory free between freeBlock and memoryLimit for forwarding table"    fwdTableNext _ endOfMemory + BaseHeaderSize.    fwdTableLast _ memoryLimit - 8.  "last forwarding table entry"    (checkAssertions and: [(fwdTableLast bitAnd: MarkBit) ~= 0]) ifTrue: [        "Note: Address bits must not interfere with the mark bit in header of         an object, which shows that the object is forwarded."        self error: 'fwd table must be in low half of the 32-bit address space'.    ].    "return the number of forwarding blocks available"    ^ (fwdTableLast - fwdTableNext) // 8  "round down"! !!ObjectMemory methodsFor: 'gc -- compaction'!incCompBody    "Move objects to consolidate free space into one big chunk. Return the newly created free chunk."    | bytesFreed |    self inline: false.    "reserve memory for forwarding table"    self fwdTableInit.    "assign new oop locations, reverse their headers, and initialize forwarding blocks"    bytesFreed _ self incCompMakeFwd.    "update pointers to point at new oops"    self mapPointersInObjectsFrom: youngStart to: endOfMemory.    "move the objects and restore their original headers; return the new free chunk"    ^ self incCompMove: bytesFreed! !!ObjectMemory methodsFor: 'gc -- compaction'!incCompMakeFwd    "Create and initialize forwarding blocks for all non-free objects following compStart. If the supply of forwarding blocks is exhausted, set compEnd to the first chunk above the area to be compacted; otherwise, set it to endOfMemory. Return the number of bytes to be freed."    | bytesFreed oop fwdBlock newOop |    bytesFreed _ 0.    oop _ self oopFromChunk: compStart.    [oop < endOfMemory] whileTrue: [        (self isFreeObject: oop) ifTrue: [            bytesFreed _ bytesFreed + (self sizeOfFree: oop).        ] ifFalse: [            "create a forwarding block for oop"            fwdBlock _ self fwdBlockGet.            fwdBlock = nil ifTrue: [                "stop; we have used all available forwarding blocks"                compEnd _ self chunkFromOop: oop.                ^ bytesFreed            ].            newOop _ oop - bytesFreed.            self initForwardBlock: fwdBlock mapping: oop to: newOop.        ].        oop _ self objectAfterWhileForwarding: oop.    ].    compEnd _ endOfMemory.    ^ bytesFreed! !!ObjectMemory methodsFor: 'gc -- compaction'!incCompMove: bytesFreed    "Move all non-free objects between compStart and compEnd to their new locations, restoring their headers in the process. Create a new free block at the end of memory. Return the newly created free chunk."    "Note: The free block used by the allocator always must be the last free block in memory. It may take several compaction passes to make all free space bubble up to the end of memory."    | oop next fwdBlock newOop header bytesToMove firstWord lastWord newFreeChunk sz |    newOop _ nil.    oop _ self oopFromChunk: compStart.    [oop < compEnd] whileTrue: [        next _ self objectAfterWhileForwarding: oop.        (self isFreeObject: oop) ifFalse: [            "a moving object; unwind its forwarding block"            fwdBlock _ (self longAt: oop) bitAnd: AllButMarkBitAndTypeMask.            checkAssertions ifTrue: [ self fwdBlockValidate: fwdBlock ].            newOop _ self longAt: fwdBlock.            header _ self longAt: fwdBlock + 4.            self longAt: oop put: header.  "restore the original header"            bytesToMove _ oop - newOop.            "move the oop (including any extra header words)"            sz _ self sizeBitsOf: oop.            firstWord _ oop - (self extraHeaderBytes: oop).            lastWord _ (oop + sz) - BaseHeaderSize.            firstWord to: lastWord by: 4 do: [ :w |                self longAt: (w - bytesToMove) put: (self longAt: w).            ].        ].        oop _ next.    ].    newOop = nil ifTrue: [        "no objects moved"        oop _ self oopFromChunk: compStart.        ((self isFreeObject: oop) and: [(self objectAfter: oop) = (self oopFromChunk: compEnd)])            ifTrue: [ newFreeChunk _ oop ]            ifFalse: [ newFreeChunk _ freeBlock ].    ] ifFalse: [        "initialize the newly freed memory chunk"        "newOop is the last object moved; free chunk starts right after it"        newFreeChunk _ newOop + (self sizeBitsOf: newOop).        self setSizeOfFree: newFreeChunk to: bytesFreed.    ].    checkAssertions ifTrue: [        (self objectAfter: newFreeChunk) = (self oopFromChunk: compEnd)            ifFalse: [ self error: 'problem creating free chunk after compaction' ].    ].    (self objectAfter: newFreeChunk) = endOfMemory ifTrue: [        self initializeMemoryFirstFree: newFreeChunk.    ] ifFalse: [        "newFreeChunk is not at end of memory; re-install freeBlock"        self initializeMemoryFirstFree: freeBlock.    ].    ^ newFreeChunk! !!ObjectMemory methodsFor: 'gc -- compaction'!initForwardBlock: fwdBlock mapping: oop to: newOop    "Initialize the given forwarding block to map oop to newOop, and replace oop's header with a pointer to the fowarding block."    "Details: The mark bit is used to indicate that an oop is forwarded. When an oop is forwarded, its header (minus the mark bit) contains the address of its forwarding block. The first word of the forwarding block is the new oop; the second word is the oop's orginal header. The type bits of the forwarding header are the same as those of the original header."    | originalHeader originalHeaderType |    self inline: true.    originalHeader _ self longAt: oop.    checkAssertions ifTrue: [        fwdBlock = nil            ifTrue: [ self error: 'ran out of forwarding blocks in become' ].        (originalHeader bitAnd: MarkBit) ~= 0            ifTrue: [ self error: 'object already has a forwarding table entry' ].    ].    originalHeaderType _ originalHeader bitAnd: TypeMask.    self longAt: fwdBlock put: newOop.    self longAt: fwdBlock + 4 put: originalHeader.    self longAt: oop put: (fwdBlock bitOr: (MarkBit bitOr: originalHeaderType)).! !!ObjectMemory methodsFor: 'gc -- compaction'!isObjectForwarded: oop    "Return true if the given object has a forwarding table entry during a compaction or become operation."    ^ (oop bitAnd: 1) = 0 "(isIntegerObject: oop) not" and:       [ ((self longAt: oop) bitAnd: MarkBit) ~= 0 ]! !!ObjectMemory methodsFor: 'gc -- compaction'!lastPointerWhileForwarding: oop    "The given object may have its header word in a forwarding block. Find the offset of the last pointer in the object in spite of this obstacle."    | header fwdBlock fmt size methodHeader |    self inline: true.    header _ self longAt: oop.    (header bitAnd: MarkBit) ~= 0 ifTrue: [        "oop is forwarded; get its real header from its forwarding table entry"        fwdBlock _ header bitAnd: AllButMarkBitAndTypeMask.        checkAssertions ifTrue: [ self fwdBlockValidate: fwdBlock ].        header _ self longAt: fwdBlock + 4.    ].    fmt _ (header >> 8) bitAnd: 16rF.    fmt < 4 ifTrue: [        "do sizeBitsOf: using the header we obtained"        (header bitAnd: TypeMask) = HeaderTypeSizeAndClass            ifTrue: [ size _ (self sizeHeader: oop) bitAnd: 16rFFFFFFC ]            ifFalse: [ size _ header bitAnd: 16rFC ].        ^ size - BaseHeaderSize    ].    fmt < 12 ifTrue: [ ^ 0 ].  "no pointers"    methodHeader _ self longAt: oop + BaseHeaderSize.    ^ ((methodHeader >> 10) bitAnd: 16rFF) * 4 + BaseHeaderSize! !!ObjectMemory methodsFor: 'gc -- compaction'!mapPointersInObjectsFrom: memStart to: memEnd    "Use the forwarding table to update the pointers of all non-free objects in the given range of memory. Also remap pointers in root objects which may contains pointers into the given memory range."    | oop |    self inline: false.    "update interpreter variables"    self mapInterpreterOops.    "update pointers in root objects"    1 to: rootTableCount do: [ :i |         oop _ rootTable at: i.        ((oop < memStart) or: [oop >= memEnd]) ifTrue: [            "Note: must not remap the fields of any object twice!!"            "remap this oop only if not in the memory range covered below"            self remapFieldsAndClassOf: oop.        ].    ].    "update pointers in the given memory range"    oop _ self oopFromChunk: memStart.    [oop < memEnd] whileTrue: [        (self isFreeObject: oop) ifFalse: [            self remapFieldsAndClassOf: oop.        ].        oop _ self objectAfterWhileForwarding: oop.    ].! !!ObjectMemory methodsFor: 'gc -- compaction'!objectAfterWhileForwarding: oop    "Return the oop of the object after the given oop when the actual header of the oop may be in the forwarding table."    | header fwdBlock realHeader sz |    self inline: true.    header _ self longAt: oop.    (header bitAnd: MarkBit) = 0 ifTrue: [ ^ self objectAfter: oop ].  "oop not forwarded"    "Assume: mark bit cannot be set on a free chunk, so if we get here,     oop is not free and it has a forwarding table entry"    fwdBlock _ header bitAnd: AllButMarkBitAndTypeMask.    checkAssertions ifTrue: [ self fwdBlockValidate: fwdBlock ].    realHeader _ self longAt: fwdBlock + 4.    "following code is like sizeBitsOf:"    (realHeader bitAnd: TypeMask) = HeaderTypeSizeAndClass        ifTrue: [ sz _ (self sizeHeader: oop) bitAnd: 16rFFFFFFC ]        ifFalse: [ sz _ realHeader bitAnd: 16rFC ].    ^ self oopFromChunk: (oop + sz)! !!ObjectMemory methodsFor: 'gc -- compaction'!remap: oop    "Map the given oop to its new value during a compaction or become: operation. If it has no forwarding table entry, return the oop itself."    | fwdBlock |    self inline: false.    (self isObjectForwarded: oop) ifTrue: [        "get the new value for oop from its forwarding block"        fwdBlock _ (self longAt: oop) bitAnd: AllButMarkBitAndTypeMask.        checkAssertions ifTrue: [ self fwdBlockValidate: fwdBlock ].        ^ self longAt: fwdBlock    ].    ^ oop! !!ObjectMemory methodsFor: 'gc -- compaction'!remapClassOf: oop    "Update the class of the given object, if necessary, using its forwarding table entry."    "Note: Compact classes need not be remapped since the compact class field is just an index into the compact class table. The header type bits show if this object has a compact class; we needn't look up the oop's real header."    | classHeader classOop fwdBlock newClassOop newClassHeader |    (self headerType: oop) = HeaderTypeShort ifTrue: [ ^nil ].  "compact classes needn't be mapped"    classHeader _ self longAt: (oop - 4).    classOop _ classHeader bitAnd: AllButTypeMask.    (self isObjectForwarded: classOop) ifTrue: [        fwdBlock _ (self longAt: classOop) bitAnd: AllButMarkBitAndTypeMask.        checkAssertions ifTrue: [ self fwdBlockValidate: fwdBlock ].        newClassOop _ self longAt: fwdBlock.        newClassHeader _ newClassOop bitOr: (classHeader bitAnd: TypeMask).        self longAt: (oop - 4) put: newClassHeader.        "The following ensures that become: into an old object's class makes it a root.          It does nothing during either incremental or full compaction because          oop will never be < youngStart."        ((oop < youngStart) and: [newClassOop >= youngStart])            ifTrue: [ self beRootWhileForwarding: oop ].    ].! !!ObjectMemory methodsFor: 'gc -- compaction'!remapFieldsAndClassOf: oop    "Replace all forwarded pointers in this object with their new oops, using the forwarding table. Remap its class as well, if necessary."    "Note: The given oop may be forwarded itself, which means that its real header is in its forwarding table entry."    | fieldOffset fieldOop fwdBlock newOop |    self inline: true.    fieldOffset _ self lastPointerWhileForwarding: oop.    [fieldOffset >= BaseHeaderSize] whileTrue: [        fieldOop _ self longAt: (oop + fieldOffset).        (self isObjectForwarded: fieldOop) ifTrue: [            "update this oop from its forwarding block"            fwdBlock _ (self longAt: fieldOop) bitAnd: AllButMarkBitAndTypeMask.            checkAssertions ifTrue: [ self fwdBlockValidate: fwdBlock ].            newOop _ self longAt: fwdBlock.            self longAt: (oop + fieldOffset) put: newOop.            "The following ensures that become: into old object makes it a root.              It does nothing during either incremental or full compaction because              oop will never be < youngStart."            ((oop < youngStart) and: [newOop >= youngStart])                ifTrue: [ self beRootWhileForwarding: oop ].        ].        fieldOffset _ fieldOffset - 4.    ].    self remapClassOf: oop.! !!ObjectMemory methodsFor: 'become'!allYoung: array1 and: array2    "Return true if all the oops in both arrays, and the arrays themselves, are in the young object space."    | fieldOffset |    array1 < youngStart ifTrue: [ ^ false ].    array2 < youngStart ifTrue: [ ^ false ].    fieldOffset _ self lastPointerOf: array1.  "same size as array2"    [fieldOffset >= BaseHeaderSize] whileTrue: [        (self longAt: array1 + fieldOffset) < youngStart ifTrue: [ ^ false ].        (self longAt: array2 + fieldOffset) < youngStart ifTrue: [ ^ false ].        fieldOffset _ fieldOffset - 4.    ].    ^ true! !!ObjectMemory methodsFor: 'become'!become: array1 with: array2    "All references to each object in array1 are swapped with all references to the corresponding object in array2. That is, all pointers to one object are replaced with with pointers to the other. The arguments must be arrays of the same length. Returns true if the primitive succeeds."    "Implementation: Uses forwarding blocks to update references as done in compaction."    (self fetchClassOf: array1) = (self splObj: ClassArray) ifFalse: [ ^ false ].    (self fetchClassOf: array2) = (self splObj: ClassArray) ifFalse: [ ^ false ].    (self lastPointerOf: array1) = (self lastPointerOf: array2) ifFalse: [ ^ false ].    (self containOnlyOops: array1 and: array2) ifFalse: [ ^ false ].    (self prepareForwardingTableForBecoming: array1 with: array2) ifFalse: [        ^ false  "fail; not enough space for forwarding table"    ].    (self allYoung: array1 and: array2) ifTrue: [        "sweep only the young objects plus the roots"        self mapPointersInObjectsFrom: youngStart to: endOfMemory.    ] ifFalse: [        "sweep all objects"        self mapPointersInObjectsFrom: (self startOfMemory) to: endOfMemory.    ].    self restoreHeadersAfterBecoming: array1 with: array2.    self initializeMemoryFirstFree: freeBlock.  "re-initialize memory used for forwarding table"    ^ true  "success"! !!ObjectMemory methodsFor: 'become'!containOnlyOops: array1 and: array2    "Return true if neither array contains a small integer. You can't become: integers!!"    | fieldOffset |    fieldOffset _ self lastPointerOf: array1.  "same size as array2"    [fieldOffset >= BaseHeaderSize] whileTrue: [        (self isIntegerObject: (self longAt: array1 + fieldOffset)) ifTrue: [ ^ false ].        (self isIntegerObject: (self longAt: array2 + fieldOffset)) ifTrue: [ ^ false ].        fieldOffset _ fieldOffset - 4.    ].    ^ true! !!ObjectMemory methodsFor: 'become'!exchangeHashBits: oop1 with: oop2    | hdr1 hdr2 |    hdr1 _ self longAt: oop1.    hdr2 _ self longAt: oop2.    self longAt: oop1 put:        ((hdr1 bitAnd: AllButHashBits) bitOr: (hdr2 bitAnd: HashBits)).    self longAt: oop2 put:        ((hdr2 bitAnd: AllButHashBits) bitOr: (hdr1 bitAnd: HashBits)).! !!ObjectMemory methodsFor: 'become'!prepareForwardingTableForBecoming: array1 with: array2    "Ensure that there are enough forwarding blocks to accomodate this become, then prepare forwarding blocks for the pointer swap. Return true if successful."    "Details: Doing a GC might generate enough space for forwarding blocks if we're short. However, this is an uncommon enough case that it is better handled by primitive fail code at the Smalltalk level."    | entriesNeeded entriesAvailable fieldOffset oop1 oop2 fwdBlock |    entriesNeeded _ 2 * ((self lastPointerOf: array1) // 4).  "need enough entries for both directions"    entriesAvailable _ self fwdTableInit.    entriesAvailable < entriesNeeded ifTrue: [        self initializeMemoryFirstFree: freeBlock.  "re-initialize the free block"        ^ false    ].    fieldOffset _ self lastPointerOf: array1.    [fieldOffset >= BaseHeaderSize] whileTrue: [        oop1 _ self longAt: array1 + fieldOffset.        oop2 _ self longAt: array2 + fieldOffset.        fwdBlock _ self fwdBlockGet.        self initForwardBlock: fwdBlock mapping: oop1 to: oop2.        fwdBlock _ self fwdBlockGet.        self initForwardBlock: fwdBlock mapping: oop2 to: oop1.        fieldOffset _ fieldOffset - 4.    ].    ^ true! !!ObjectMemory methodsFor: 'become'!restoreHeaderOf: oop    "Restore the original header of the given oop from its forwarding block."    | fwdHeader fwdBlock |    fwdHeader _ self longAt: oop.    fwdBlock _ fwdHeader bitAnd: AllButMarkBitAndTypeMask.    checkAssertions ifTrue: [        (fwdHeader bitAnd: MarkBit) = 0 ifTrue: [            self error: 'attempting to restore the header of an object that has no forwarding block'.        ].        self fwdBlockValidate: fwdBlock.    ].    self longAt: oop put: (self longAt: fwdBlock + 4).  "restore orginal header"! !!ObjectMemory methodsFor: 'become'!restoreHeadersAfterBecoming: list1 with: list2    "Restore the headers of all oops in both lists. Exchange their hash bits so becoming objects in identity sets and dictionaries doesn't change their hash value."    | fieldOffset oop1 oop2 |    fieldOffset _ self lastPointerOf: list1.    [fieldOffset >= BaseHeaderSize] whileTrue: [        oop1 _ self longAt: list1 + fieldOffset.        oop2 _ self longAt: list2 + fieldOffset.        self restoreHeaderOf: oop1.        self restoreHeaderOf: oop2.        self exchangeHashBits: oop1 with: oop2.        fieldOffset _ fieldOffset - 4.    ].! !!ObjectMemory class methodsFor: 'initialization' stamp: 'jm 9/14/97 11:21'!initialize    "ObjectMemory initialize"    self initializeSpecialObjectIndices.    self initializeObjectHeaderConstants.    LargeContextSize _ 156.    SmallContextSize _ 76.    NilContext _ 1.  "the oop for the integer 0; used to mark the end of context lists"    MinimumForwardTableBytes _ 16000.  "bytes reserved for forwarding table (8 bytes/entry)"    RemapBufferSize _ 25.    RootTableSize _ 1000.  "number of root table entries (4 bytes/entry)"    "tracer actions"    StartField _ 1.    StartObj _ 2.    Upward _ 3.    Done _ 4.! !!ObjectMemory class methodsFor: 'initialization'!initializeObjectHeaderConstants    BaseHeaderSize _ 4.    "masks for type field"    TypeMask _ 3.    AllButTypeMask _ 16rFFFFFFFF - TypeMask.    "type field values"    HeaderTypeSizeAndClass _ 0.    HeaderTypeClass _ 1.    HeaderTypeFree _ 2.    HeaderTypeShort _ 3.    "type field values used during the mark phase of GC"    HeaderTypeGC _ 2.    GCTopMarker _ 3.  "neither an oop, nor an oop+1, this value signals that we have crawled back up to the top of the marking phase."    "mask for a free chunk size"    FreeSizeMask _ 16r1FFFFFFC.    "base header word bit fields"    HashBits _ 16r1FFE0000.    AllButHashBits _ 16rFFFFFFFF - HashBits.    HashBitsOffset _ 17.    "masks for root and mark bits"    MarkBit _ 16r80000000.    RootBit _ 16r40000000.    AllButMarkBit _ 16rFFFFFFFF - MarkBit.    AllButRootBit _ 16rFFFFFFFF - RootBit.    AllButMarkBitAndTypeMask _ AllButTypeMask - MarkBit.! !!ObjectMemory class methodsFor: 'initialization' stamp: 'jm 8/22/97 13:06'!initializeSpecialObjectIndices    "Initialize indices into specialObjects array."    NilObject _ 0.    FalseObject _ 1.    TrueObject _ 2.    SchedulerAssociation _ 3.    ClassBitmap _ 4.    ClassInteger _ 5.    ClassString _ 6.    ClassArray _ 7.    "SmalltalkDictionary _ 8."  "Do not delete!!"    ClassFloat _ 9.    ClassMethodContext _ 10.    ClassBlockContext _ 11.    ClassPoint _ 12.    ClassLargePositiveInteger _ 13.    TheDisplay _ 14.    ClassMessage _ 15.    ClassCompiledMethod _ 16.    TheLowSpaceSemaphore _ 17.    ClassSemaphore _ 18.    ClassCharacter _ 19.    SelectorDoesNotUnderstand _ 20.    SelectorCannotReturn _ 21.    TheInputSemaphore _ 22.    SpecialSelectors _ 23.    CharacterTable _ 24.    SelectorMustBeBoolean _ 25.    ClassByteArray _ 26.    ClassProcess _ 27.    CompactClasses _ 28.    TheTimerSemaphore _ 29.    TheInterruptSemaphore _ 30.    ExternalObjectsArray _ 38.! !!ObjectMemory class methodsFor: 'translation'!declareCVarsIn: aCCodeGenerator    aCCodeGenerator var: 'memory'        declareC: 'unsigned char *memory'.    aCCodeGenerator var: 'remapBuffer'        declareC: 'int remapBuffer[', (RemapBufferSize + 1) printString, ']'.    aCCodeGenerator var: 'rootTable'        declareC: 'int rootTable[', (RootTableSize + 1) printString, ']'.! !ObjectTracer class comment:'An ObjectTracer can be wrapped around another object, and then give you a chance to inspect it whenever it receives messages from the outside.  For instance...    (ObjectTracer on: Display) flash: (50@50 extent: 50@50)will give control to a debugger just before the message flash is sent.Obviously this facility can be embellished in many useful ways.See also the even more perverse subclass, ObjectViewer, and its example.'!!ObjectTracer methodsFor: 'very few messages'!doesNotUnderstand: aMessage     "All external messages (those not caused by the re-send) get trapped here"    "Present a dubugger before proceeding to re-send the message"    DebuggerView openContext: thisContext                label: 'About to perform: ', aMessage selector                contents: thisContext shortStack.    ^ aMessage sentTo: tracedObject.! !!ObjectTracer methodsFor: 'very few messages'!xxxUnTrace    tracedObject become: self! !!ObjectTracer methodsFor: 'very few messages'!xxxViewedObject    "This message name must not clash with any other (natch)."    ^ tracedObject! !!ObjectTracer methodsFor: 'very few messages'!xxxViewedObject: anObject    "This message name must not clash with any other (natch)."    tracedObject _ anObject! !!ObjectTracer class methodsFor: 'instance creation'!on: anObject    ^ self new xxxViewedObject: anObject! !ObjectViewer class comment:'ObjectViewers offers the same kind of interception of messages (via doesnotUnderstand:) as ObjectTracers, but instead of just being wrappers, they actually replace the object being viewed.  This makes them a lot more dangerous to use, but one can do amazing things.  For instance, the example below actually intercepts the InputSensor object, and prints the mouse coordinates asynchronously, every time they change:    Sensor evaluate: [Sensor cursorPoint printString displayAt: 0@0]        wheneverChangeIn: [Sensor cursorPoint].To exit from this example, execute:    Sensor xxxUnTrace'!!ObjectViewer methodsFor: 'very few messages'!doesNotUnderstand: aMessage     "Check for change after sending aMessage"    | returnValue newValue |    recursionFlag ifTrue: [^ aMessage sentTo: tracedObject].    recursionFlag _ true.    returnValue _ aMessage sentTo: tracedObject.    newValue _ valueBlock value.    newValue = lastValue ifFalse:        [changeBlock value.        lastValue _ newValue].    recursionFlag _ false.    ^ returnValue! !!ObjectViewer methodsFor: 'very few messages'!xxxViewedObject: viewedObject evaluate: block1 wheneverChangeIn: block2    "This message name must not clash with any other (natch)."    tracedObject _ viewedObject.    valueBlock _ block2.    changeBlock _ block1.    recursionFlag _ false! !!ObjectViewer class methodsFor: 'instance creation'!on: viewedObject evaluate: block1 wheneverChangeIn: block2    ^ self new xxxViewedObject: viewedObject evaluate: block1 wheneverChangeIn: block2! !OpaqueMaskColor class comment:'The pixel value of an OpaqueMaskColor is all-ones in any depth. This allows it to be used in combination with the AND mode of BitBlt to create masks that work at any depth. Clients typically use "Color opaqueMask" to get an instance of me.'!!OpaqueMaskColor methodsFor: 'equality'!= aColor    ^ aColor isOpaqueMask! !!OpaqueMaskColor methodsFor: 'equality'!hash    ^ 1023! !!OpaqueMaskColor methodsFor: 'queries'!isColor    "I'm not a real color."    ^ false! !!OpaqueMaskColor methodsFor: 'queries'!isOpaqueMask    ^ true! !!OpaqueMaskColor methodsFor: 'transformations'!* aFactor    ^ self! !!OpaqueMaskColor methodsFor: 'transformations'!+ aColor    ^ self! !!OpaqueMaskColor methodsFor: 'transformations'!- aColor    ^ self! !!OpaqueMaskColor methodsFor: 'transformations'!/ aFactor    ^ self! !!OpaqueMaskColor methodsFor: 'transformations'!darker    ^ self! !!OpaqueMaskColor methodsFor: 'transformations'!lighter    ^ self! !!OpaqueMaskColor methodsFor: 'transformations'!mixed: proportion with: aColor    ^ self! !!OpaqueMaskColor methodsFor: 'printing'!shortPrintString    ^ 'OpaqueMask'! !!OpaqueMaskColor methodsFor: 'printing'!storeOn: aStream    aStream nextPutAll: '(Color opaqueMask)'.! !!OpaqueMaskColor methodsFor: 'conversions'!bitPatternForDepth: depth    ^ Bitmap with: (self pixelWordForDepth: depth)! !!OpaqueMaskColor methodsFor: 'conversions'!pixelValueForDepth: depth    ^ (1 bitShift: depth) - 1! !!OpaqueMaskColor methodsFor: 'conversions'!pixelWordForDepth: depth    ^ 16rFFFFFFFF! !!OpaqueMaskColor methodsFor: 'private'!setRed: r green: g blue: b    "Ignored."! !!OrderedCollection methodsFor: 'accessing'!inspect    "Open an OrderedCollectionInspector on the receiver.    Use basicInspect to get a normal type of inspector."    OrderedCollectionInspector openOn: self withEvalPane: true! !!OrderedCollection methodsFor: 'copying'!copyFrom: startIndex to: endIndex     "Answer a copy of the receiver that contains elements from position    startIndex to endIndex."    | targetCollection |    endIndex < startIndex ifTrue: [^self species new: 0].    targetCollection _ self species new: endIndex + 1 - startIndex.    startIndex to: endIndex do: [:index | targetCollection add: (self at: index)].    ^ targetCollection! !!OrderedCollection methodsFor: 'copying'!copyReplaceFrom: start to: stop with: replacementCollection     "Answer a copy of the receiver with replacementCollection's elements in    place of the receiver's start'th to stop'th elements. This does not expect    a 1-1 map from replacementCollection to the start to stop elements, so it    will do an insert or append."    | newOrderedCollection delta startIndex stopIndex |    "if start is less than 1, ignore stop and assume this is inserting at the front.     if start greater than self size, ignore stop and assume this is appending.     otherwise, it is replacing part of me and start and stop have to be within my     bounds. "    delta _ 0.    startIndex _ start.    stopIndex _ stop.    start < 1        ifTrue: [startIndex _ stopIndex _ 0]        ifFalse: [startIndex > self size                ifTrue: [startIndex _ stopIndex _ self size + 1]                ifFalse:                     [(stopIndex < (startIndex - 1) or: [stopIndex > self size])                        ifTrue: [self errorOutOfBounds].                    delta _ stopIndex - startIndex + 1]].    newOrderedCollection _         self species new: self size + replacementCollection size - delta.    1 to: startIndex - 1 do: [:index | newOrderedCollection add: (self at: index)].    1 to: replacementCollection size do:         [:index | newOrderedCollection add: (replacementCollection at: index)].    stopIndex + 1 to: self size do: [:index | newOrderedCollection add: (self at: index)].    ^newOrderedCollection! !!OrderedCollection methodsFor: 'copying' stamp: 'di 9/22/97 12:17'!copyWithout: oldElement     "Answer a copy of the receiver that does not contain any elements equal    to oldElement."    ^ self select: [:each | each ~= oldElement]! !!OrderedCollection methodsFor: 'copying' stamp: 'di 9/22/97 12:22'!copyWithoutAll: aList    "Answer a copy of the receiver that does not contain any elements equal    to those in aList."    ^ self select: [:each | (aList includes: each) not]! !!OrderedCollection methodsFor: 'copying' stamp: 'sw 1/26/96'!reversed    "Answer a copy of the receiver with element order reversed.  "    | newCol |    newCol _ self species new.    self reverseDo:        [:elem | newCol addLast: elem].    ^ newCol"#(2 3 4 'fred') reversed"! !!OrderedCollection methodsFor: 'private'!makeRoomAtLast    | newLast delta |    newLast _ self size.    array size - self size = 0 ifTrue: [self grow].    (delta _ firstIndex - 1) = 0 ifTrue: [^ self].    "we might be here under false premises or grow did the job for us"    1 to: newLast do:        [:index |        array at: index put: (array at: index + delta).        array at: index + delta put: nil].    firstIndex _ 1.    lastIndex _ newLast! !!PaintBox methodsFor: 'paint commands'!getColor    ^ currentColor color! !!PaintBox methodsFor: 'paint commands'!getNib    ^ (currentBrush findA: SketchMorph) rotatedForm! !!PaintBox methodsFor: 'paint commands' stamp: 'tk 6/3/97'!getRotations    "Translate to what the SketchMorph wants.  "    | rot |    rot _ rotate specialNameInModel.    rot = 'doRotate' ifTrue: [^ #normal].    rot = 'toAndFro' ifTrue: [^ #leftRight].    rot = 'noRotate' ifTrue: [^ #none].    "back and forth, mirror"! !!PaintBox methodsFor: 'paint commands' stamp: 'tk 4/16/97'!getSpecial    "See if paint, fill, fill gradient, replace all but, replace only.  Return a symbol.  "    action specialNameInModel = 'repOnly' ifTrue: [^ #replaceOnly:].    action specialNameInModel = 'repAllBut' ifTrue: [^ #replaceAllBut:].    action specialNameInModel = 'paint' ifTrue: [            (currentBrush specialNameInModel beginsWith: 'trans') ifTrue: [^ #transBrush:].                "transparent brush"            currentBrush specialNameInModel = 'fill' ifTrue: [^ #areaFill:].        "    currentBrush specialNameInModel = 'gradientFill' ifTrue: [^ #gradientFill:].            currentBrush specialNameInModel = 'gradientFillY' ifTrue: [^ #gradientFillY:].            currentBrush specialNameInModel = 'gradientFillXY' ifTrue: [^ #gradientFillXY:].    "            ^ #paint:].    action specialNameInModel = 'pickUp' ifTrue: [^ #pickup:].    action specialNameInModel = 'stamp' ifTrue: [^ #stamp:].    ^ #paint:! !!PaintBox methodsFor: 'paint commands'!setAction: anActionChip    "Make that chip be the current one.  Select and deselect."    action ifNil: [action _ anActionChip].    action borderColor: Color gray; borderWidth: 1.    "deselect old one"    action _ anActionChip.        "A RectangleMorph"    action borderColor: Color black; borderWidth: 2.    "select new one"! !!PaintBox methodsFor: 'paint commands'!setCurrentBrush: aDrawing    "Make that brush be the current one.  Select and deselect."    currentBrush ifNil: [currentBrush _ aDrawing].    currentBrush borderColor: Color gray; borderWidth: 1.    "deselect old one"    currentBrush _ aDrawing.        "A ButtonDownMorph"    currentBrush borderColor: Color black; borderWidth: 2.    "select new one"    (brushIndicator findA: SketchMorph) wearCostume:         (currentBrush findA: SketchMorph).    "Show it"    "brushIndicator label: currentBrush label."    "Since you chose a brush, you probably want to Paint"    paint == action ifFalse: [self setAction: paint].! !!PaintBox methodsFor: 'paint commands'!setCurrentColor: aColorChip    "Make that chip be the current one.  Select and deselect."    | str |    currentColor ifNil: [currentColor _ aColorChip].    currentColor borderColor: Color gray; borderWidth: 1.    "deselect old one"    currentColor _ aColorChip.        "A ButtonDownMorph"    currentColor borderColor: Color black; borderWidth: 2.    "select new one"    colorIndicator color: currentColor color.    "Show the color"    str _ (colorIndicator findA: StringMorph).    currentColor color = Color transparent         ifFalse: [str contents: '']        ifTrue: [str contents: 'Transparent'].        "For Transparent"! !!PaintBox methodsFor: 'paint commands'!setRotation: anActionChip    "Make that chip be the current one.  Select and deselect."    anActionChip class == Symbol         ifFalse: [            rotate ifNil: [rotate _ anActionChip].            rotate borderColor: Color gray; borderWidth: 1.    "deselect old one"            rotate _ anActionChip.        "A RectangleMorph"            rotate borderColor: Color black; borderWidth: 2]    "select new one"        ifTrue: ["from the sketch"            anActionChip == #normal ifTrue: ["continuous 360 degree rotation"                self setRotation: doRotate].            anActionChip == #leftRight ifTrue: ["quantize angle to left or right facing"                self setRotation: toAndFro].            anActionChip == #upDown ifTrue: ["quantize angle to up or down facing"                self setRotation: doRotate].    "no button for it yet!!!!"            anActionChip == #none ifTrue: ["do not rotate"                self setRotation: noRotate]].! !!PaintBox methodsFor: 'mouse events'!backgroundMouseDown: evt morph: m    "Edit this method to add mouse-driven behavior."! !!PaintBox methodsFor: 'mouse events'!backgroundMouseMove: evt morph: m    (m containsPoint: evt cursorPoint)        ifTrue: [(m findA: StringMorph) color: self buttonPressedColor.            m borderColor: Color black.            m borderWidth: 2]        ifFalse: [(m findA: StringMorph) color: self buttonUpColor.            m borderColor: Color gray.            m borderWidth: 1].! !!PaintBox methodsFor: 'mouse events' stamp: 'jm 9/28/97 19:35'!backgroundMouseUp: evt morph: m    "Edit this method to add mouse-driven behavior."    | field pic rect ss |    (m containsPoint: evt cursorPoint)        ifFalse: [(m findA: StringMorph) color: self buttonUpColor.            m borderColor: Color gray.            m borderWidth: 1.            ^ self].    (ss _ self world findA: SketchEditorMorph) ifNotNil: [ss save].    "save old drawing"    "field _ self world findA: PlayfieldMorph."    field ifNil: [        (m findA: StringMorph) color: self buttonUpColor.        m borderColor: Color gray.        m borderWidth: 1.        ^ self].    pic _ field backgroundSketch.    pic ifNotNil: [pic editDrawingInWorld: self world]        "need to resubmit it?"        ifNil: [rect _ self world paintArea.    "Let it tell us"            pic _ self world hands first drawingClass new form:                 (Form extent: rect extent depth: Display depth).            pic bounds: rect.            "self world addMorphBack: pic.  done below"            pic _ field backgroundSketch: pic.    "returns a different guy"            pic ifNotNil: [pic editDrawingInWorld: self world]].! !!PaintBox methodsFor: 'mouse events'!brush1aMouseDown: evt morph: m    "Edit this method to add mouse-driven behavior."    self setCurrentBrush: m! !!PaintBox methodsFor: 'mouse events'!brush1aMouseMove: evt morph: m    "Edit this method to add mouse-driven behavior."! !!PaintBox methodsFor: 'mouse events'!brush1aMouseUp: evt morph: m    "Edit this method to add mouse-driven behavior."! !!PaintBox methodsFor: 'mouse events'!brush1bMouseDown: evt morph: m    "Edit this method to add mouse-driven behavior."    self setCurrentBrush: m! !!PaintBox methodsFor: 'mouse events'!brush1bMouseMove: evt morph: m    "Edit this method to add mouse-driven behavior."! !!PaintBox methodsFor: 'mouse events'!brush1bMouseUp: evt morph: m    "Edit this method to add mouse-driven behavior."! !!PaintBox methodsFor: 'mouse events'!brush2aMouseDown: evt morph: m    "Edit this method to add mouse-driven behavior."    self setCurrentBrush: m! !!PaintBox methodsFor: 'mouse events'!brush2aMouseMove: evt morph: m    "Edit this method to add mouse-driven behavior."! !!PaintBox methodsFor: 'mouse events'!brush2aMouseUp: evt morph: m    "Edit this method to add mouse-driven behavior."! !!PaintBox methodsFor: 'mouse events'!brush2bMouseDown: evt morph: m    "Edit this method to add mouse-driven behavior."    self setCurrentBrush: m! !!PaintBox methodsFor: 'mouse events'!brush2bMouseMove: evt morph: m    "Edit this method to add mouse-driven behavior."! !!PaintBox methodsFor: 'mouse events'!brush2bMouseUp: evt morph: m    "Edit this method to add mouse-driven behavior."! !!PaintBox methodsFor: 'mouse events'!brush3aMouseDown: evt morph: m    "Edit this method to add mouse-driven behavior."    self setCurrentBrush: m! !!PaintBox methodsFor: 'mouse events'!brush3aMouseMove: evt morph: m    "Edit this method to add mouse-driven behavior."! !!PaintBox methodsFor: 'mouse events'!brush3aMouseUp: evt morph: m    "Edit this method to add mouse-driven behavior."! !!PaintBox methodsFor: 'mouse events'!brush3bMouseDown: evt morph: m    "Edit this method to add mouse-driven behavior."    self setCurrentBrush: m! !!PaintBox methodsFor: 'mouse events'!brush3bMouseMove: evt morph: m    "Edit this method to add mouse-driven behavior."! !!PaintBox methodsFor: 'mouse events'!brush3bMouseUp: evt morph: m    "Edit this method to add mouse-driven behavior."! !!PaintBox methodsFor: 'mouse events'!brush4aMouseDown: evt morph: m    "Edit this method to add mouse-driven behavior."    self setCurrentBrush: m! !!PaintBox methodsFor: 'mouse events'!brush4aMouseMove: evt morph: m    "Edit this method to add mouse-driven behavior."! !!PaintBox methodsFor: 'mouse events'!brush4aMouseUp: evt morph: m    "Edit this method to add mouse-driven behavior."! !!PaintBox methodsFor: 'mouse events'!brush4bMouseDown: evt morph: m    "Edit this method to add mouse-driven behavior."    self setCurrentBrush: m! !!PaintBox methodsFor: 'mouse events'!brush4bMouseMove: evt morph: m    "Edit this method to add mouse-driven behavior."! !!PaintBox methodsFor: 'mouse events'!brush4bMouseUp: evt morph: m    "Edit this method to add mouse-driven behavior."! !!PaintBox methodsFor: 'mouse events'!brush5aMouseDown: evt morph: m    "Edit this method to add mouse-driven behavior."    self setCurrentBrush: m! !!PaintBox methodsFor: 'mouse events'!brush5aMouseMove: evt morph: m    "Edit this method to add mouse-driven behavior."! !!PaintBox methodsFor: 'mouse events'!brush5aMouseUp: evt morph: m    "Edit this method to add mouse-driven behavior."! !!PaintBox methodsFor: 'mouse events'!brush5bMouseDown: evt morph: m    "Edit this method to add mouse-driven behavior."    self setCurrentBrush: m! !!PaintBox methodsFor: 'mouse events'!brush5bMouseMove: evt morph: m    "Edit this method to add mouse-driven behavior."! !!PaintBox methodsFor: 'mouse events'!brush5bMouseUp: evt morph: m    "Edit this method to add mouse-driven behavior."! !!PaintBox methodsFor: 'mouse events'!brush6aMouseDown: evt morph: m    "Edit this method to add mouse-driven behavior."    self setCurrentBrush: m! !!PaintBox methodsFor: 'mouse events'!brush6aMouseMove: evt morph: m    "Edit this method to add mouse-driven behavior."! !!PaintBox methodsFor: 'mouse events'!brush6aMouseUp: evt morph: m    "Edit this method to add mouse-driven behavior."! !!PaintBox methodsFor: 'mouse events'!brush6bMouseDown: evt morph: m    "Edit this method to add mouse-driven behavior."    self setCurrentBrush: m! !!PaintBox methodsFor: 'mouse events'!brush6bMouseMove: evt morph: m    "Edit this method to add mouse-driven behavior."! !!PaintBox methodsFor: 'mouse events'!brush6bMouseUp: evt morph: m    "Edit this method to add mouse-driven behavior."! !!PaintBox methodsFor: 'mouse events'!brushIndicatorMouseDown: evt morph: m    "Edit this method to add mouse-driven behavior."! !!PaintBox methodsFor: 'mouse events'!brushIndicatorMouseMove: evt morph: m    "Edit this method to add mouse-driven behavior."! !!PaintBox methodsFor: 'mouse events'!brushIndicatorMouseUp: evt morph: m    "Edit this method to add mouse-driven behavior."! !!PaintBox methodsFor: 'mouse events'!cancel    ^cancel! !!PaintBox methodsFor: 'mouse events'!cancelMouseDown: evt morph: m    "Edit this method to add mouse-driven behavior."! !!PaintBox methodsFor: 'mouse events'!cancelMouseMove: evt morph: m    (m containsPoint: evt cursorPoint)        ifTrue: [(m findA: StringMorph) color: self buttonPressedColor.            m borderColor: Color black.            m borderWidth: 2]        ifFalse: [(m findA: StringMorph) color: self buttonUpColor.            m borderColor: Color gray.            m borderWidth: 1].! !!PaintBox methodsFor: 'mouse events'!cancelMouseUp: evt morph: m    "Edit this method to add mouse-driven behavior."    | ss |    (m findA: StringMorph) color: self buttonUpColor.    m borderColor: Color gray.    m borderWidth: 1.    (m fullContainsPoint: evt cursorPoint) ifTrue: [        (ss _ self world findA: SketchEditorMorph)             ifNotNil: [ss cancel]            ifNil: [PopUpMenu notify:                 'You are currently not painting.  Start by clicking "New"']].! !!PaintBox methodsFor: 'mouse events'!chip10MouseDown: evt morph: m    "Edit this method to add mouse-driven behavior."    self setCurrentColor: m! !!PaintBox methodsFor: 'mouse events'!chip10MouseMove: evt morph: m    "Edit this method to add mouse-driven behavior."! !!PaintBox methodsFor: 'mouse events'!chip10MouseUp: evt morph: m    "Edit this method to add mouse-driven behavior."! !!PaintBox methodsFor: 'mouse events'!chip11MouseDown: evt morph: m    "Edit this method to add mouse-driven behavior."    self setCurrentColor: m! !!PaintBox methodsFor: 'mouse events'!chip11MouseMove: evt morph: m    "Edit this method to add mouse-driven behavior."! !!PaintBox methodsFor: 'mouse events'!chip11MouseUp: evt morph: m    "Edit this method to add mouse-driven behavior."! !!PaintBox methodsFor: 'mouse events'!chip12MouseDown: evt morph: m    "Edit this method to add mouse-driven behavior."    self setCurrentColor: m! !!PaintBox methodsFor: 'mouse events'!chip12MouseMove: evt morph: m    "Edit this method to add mouse-driven behavior."! !!PaintBox methodsFor: 'mouse events'!chip12MouseUp: evt morph: m    "Edit this method to add mouse-driven behavior."! !!PaintBox methodsFor: 'mouse events'!chip13MouseDown: evt morph: m    "Edit this method to add mouse-driven behavior."    self setCurrentColor: m! !!PaintBox methodsFor: 'mouse events'!chip13MouseMove: evt morph: m    "Edit this method to add mouse-driven behavior."! !!PaintBox methodsFor: 'mouse events'!chip13MouseUp: evt morph: m    "Edit this method to add mouse-driven behavior."! !!PaintBox methodsFor: 'mouse events'!chip14MouseDown: evt morph: m    "Edit this method to add mouse-driven behavior."    self setCurrentColor: m! !!PaintBox methodsFor: 'mouse events'!chip14MouseMove: evt morph: m    "Edit this method to add mouse-driven behavior."! !!PaintBox methodsFor: 'mouse events'!chip14MouseUp: evt morph: m    "Edit this method to add mouse-driven behavior."! !!PaintBox methodsFor: 'mouse events'!chip15MouseDown: evt morph: m    "Edit this method to add mouse-driven behavior."    self setCurrentColor: m! !!PaintBox methodsFor: 'mouse events'!chip15MouseMove: evt morph: m    "Edit this method to add mouse-driven behavior."! !!PaintBox methodsFor: 'mouse events'!chip15MouseUp: evt morph: m    "Edit this method to add mouse-driven behavior."! !!PaintBox methodsFor: 'mouse events'!chip16MouseDown: evt morph: m    "Edit this method to add mouse-driven behavior."    self setCurrentColor: m! !!PaintBox methodsFor: 'mouse events'!chip16MouseMove: evt morph: m    "Edit this method to add mouse-driven behavior."! !!PaintBox methodsFor: 'mouse events'!chip16MouseUp: evt morph: m    "Edit this method to add mouse-driven behavior."! !!PaintBox methodsFor: 'mouse events'!chip1MouseDown: evt morph: m    "Edit this method to add mouse-driven behavior."    self setCurrentColor: m! !!PaintBox methodsFor: 'mouse events'!chip1MouseMove: evt morph: m    "Edit this method to add mouse-driven behavior."! !!PaintBox methodsFor: 'mouse events'!chip1MouseUp: evt morph: m    "Edit this method to add mouse-driven behavior."! !!PaintBox methodsFor: 'mouse events'!chip2MouseDown: evt morph: m    "Edit this method to add mouse-driven behavior."    self setCurrentColor: m! !!PaintBox methodsFor: 'mouse events'!chip2MouseMove: evt morph: m    "Edit this method to add mouse-driven behavior."! !!PaintBox methodsFor: 'mouse events'!chip2MouseUp: evt morph: m    "Edit this method to add mouse-driven behavior."! !!PaintBox methodsFor: 'mouse events'!chip3MouseDown: evt morph: m    "Edit this method to add mouse-driven behavior."    self setCurrentColor: m! !!PaintBox methodsFor: 'mouse events'!chip3MouseMove: evt morph: m    "Edit this method to add mouse-driven behavior."! !!PaintBox methodsFor: 'mouse events'!chip3MouseUp: evt morph: m    "Edit this method to add mouse-driven behavior."! !!PaintBox methodsFor: 'mouse events'!chip4MouseDown: evt morph: m    "Edit this method to add mouse-driven behavior."    self setCurrentColor: m! !!PaintBox methodsFor: 'mouse events'!chip4MouseMove: evt morph: m    "Edit this method to add mouse-driven behavior."! !!PaintBox methodsFor: 'mouse events'!chip4MouseUp: evt morph: m    "Edit this method to add mouse-driven behavior."! !!PaintBox methodsFor: 'mouse events'!chip5MouseDown: evt morph: m    "Edit this method to add mouse-driven behavior."    self setCurrentColor: m! !!PaintBox methodsFor: 'mouse events'!chip5MouseMove: evt morph: m    "Edit this method to add mouse-driven behavior."! !!PaintBox methodsFor: 'mouse events'!chip5MouseUp: evt morph: m    "Edit this method to add mouse-driven behavior."! !!PaintBox methodsFor: 'mouse events'!chip6MouseDown: evt morph: m    "Edit this method to add mouse-driven behavior."    self setCurrentColor: m! !!PaintBox methodsFor: 'mouse events'!chip6MouseMove: evt morph: m    "Edit this method to add mouse-driven behavior."! !!PaintBox methodsFor: 'mouse events'!chip6MouseUp: evt morph: m    "Edit this method to add mouse-driven behavior."! !!PaintBox methodsFor: 'mouse events'!chip7MouseDown: evt morph: m    "Edit this method to add mouse-driven behavior."    self setCurrentColor: m! !!PaintBox methodsFor: 'mouse events'!chip7MouseMove: evt morph: m    "Edit this method to add mouse-driven behavior."! !!PaintBox methodsFor: 'mouse events'!chip7MouseUp: evt morph: m    "Edit this method to add mouse-driven behavior."! !!PaintBox methodsFor: 'mouse events'!chip8MouseDown: evt morph: m    "Edit this method to add mouse-driven behavior."    self setCurrentColor: m! !!PaintBox methodsFor: 'mouse events'!chip8MouseMove: evt morph: m    "Edit this method to add mouse-driven behavior."! !!PaintBox methodsFor: 'mouse events'!chip8MouseUp: evt morph: m    "Edit this method to add mouse-driven behavior."! !!PaintBox methodsFor: 'mouse events'!chip9MouseDown: evt morph: m    "Edit this method to add mouse-driven behavior."    self setCurrentColor: m! !!PaintBox methodsFor: 'mouse events'!chip9MouseMove: evt morph: m    "Edit this method to add mouse-driven behavior."! !!PaintBox methodsFor: 'mouse events'!chip9MouseUp: evt morph: m    "Edit this method to add mouse-driven behavior."! !!PaintBox methodsFor: 'mouse events'!colorIndicatorMouseDown: evt morph: m    "Edit this method to add mouse-driven behavior."! !!PaintBox methodsFor: 'mouse events'!colorIndicatorMouseMove: evt morph: m    "Edit this method to add mouse-driven behavior."! !!PaintBox methodsFor: 'mouse events'!colorIndicatorMouseUp: evt morph: m    "Edit this method to add mouse-driven behavior."! !!PaintBox methodsFor: 'mouse events'!doRotateMouseDown: evt morph: m    "Edit this method to add mouse-driven behavior."! !!PaintBox methodsFor: 'mouse events'!doRotateMouseMove: evt morph: m    (m containsPoint: evt cursorPoint)        ifTrue: [(m findA: StringMorph) color: self buttonPressedColor.            m borderColor: Color black.            m borderWidth: 2]        ifFalse: [(m findA: StringMorph) color: self buttonUpColor.            m borderColor: Color gray.            m borderWidth: 1].! !!PaintBox methodsFor: 'mouse events'!doRotateMouseUp: evt morph: m    (m findA: StringMorph) color: self buttonUpColor.    (m fullContainsPoint: evt cursorPoint)         ifTrue: [self setRotation: m]        ifFalse: [self setRotation: rotate].! !!PaintBox methodsFor: 'mouse events'!fillMouseDown: evt morph: m    "Edit this method to add mouse-driven behavior."    self setCurrentBrush: m! !!PaintBox methodsFor: 'mouse events'!fillMouseMove: evt morph: m    "Edit this method to add mouse-driven behavior."! !!PaintBox methodsFor: 'mouse events'!fillMouseUp: evt morph: m    "Edit this method to add mouse-driven behavior."! !!PaintBox methodsFor: 'mouse events'!newObject    ^newObject! !!PaintBox methodsFor: 'mouse events'!newObjectMouseDown: evt morph: m    "Edit this method to add mouse-driven behavior."! !!PaintBox methodsFor: 'mouse events'!newObjectMouseMove: evt morph: m    (m containsPoint: evt cursorPoint)        ifTrue: [(m findA: StringMorph) color: self buttonPressedColor.            m borderColor: Color black.            m borderWidth: 2]        ifFalse: [(m findA: StringMorph) color: self buttonUpColor.            m borderColor: Color gray.            m borderWidth: 1].! !!PaintBox methodsFor: 'mouse events' stamp: 'di 6/19/97 12:09'!newObjectMouseUp: evt morph: m    "Save the current drawing and start a new one"    | ss |    (m findA: StringMorph) color: self buttonUpColor.    m borderColor: Color gray.    m borderWidth: 1.    (m fullContainsPoint: evt cursorPoint) ifTrue: [        (ss _ self world findA: SketchEditorMorph) ifNotNil: [ss save].        self world displayWorld.        self world hands first makeNewDrawing].    ! !!PaintBox methodsFor: 'mouse events'!noRotateMouseDown: evt morph: m! !!PaintBox methodsFor: 'mouse events'!noRotateMouseMove: evt morph: m    (m containsPoint: evt cursorPoint)        ifTrue: [(m findA: StringMorph) color: self buttonPressedColor.            m borderColor: Color black.            m borderWidth: 2]        ifFalse: [(m findA: StringMorph) color: self buttonUpColor.            m borderColor: Color gray.            m borderWidth: 1].! !!PaintBox methodsFor: 'mouse events'!noRotateMouseUp: evt morph: m    (m findA: StringMorph) color: self buttonUpColor.    (m fullContainsPoint: evt cursorPoint)         ifTrue: [self setRotation: m]        ifFalse: [self setRotation: rotate].! !!PaintBox methodsFor: 'mouse events'!paintMouseDown: evt morph: m    "Edit this method to add mouse-driven behavior."! !!PaintBox methodsFor: 'mouse events'!paintMouseMove: evt morph: m    (m containsPoint: evt cursorPoint)        ifTrue: [(m findA: StringMorph) color: self buttonPressedColor.            m borderColor: Color black.            m borderWidth: 2]        ifFalse: [(m findA: StringMorph) color: self buttonUpColor.            m borderColor: Color gray.            m borderWidth: 1].! !!PaintBox methodsFor: 'mouse events'!paintMouseUp: evt morph: m    "Edit this method to add mouse-driven behavior."    (m findA: StringMorph) color: self buttonUpColor.    (m fullContainsPoint: evt cursorPoint)         ifTrue: [self setAction: m]        ifFalse: [self setAction: action].! !!PaintBox methodsFor: 'mouse events'!pickColorMouseDown: evt morph: m! !!PaintBox methodsFor: 'mouse events'!pickColorMouseMove: evt morph: m    "Edit this method to add mouse-driven behavior."! !!PaintBox methodsFor: 'mouse events'!pickColorMouseUp: evt morph: m    "Edit this method to add mouse-driven behavior."    currentColor color = Color transparent ifTrue: [^ self].    "can't change"    currentColor color: evt hand chooseColor.    colorIndicator color: currentColor color.    "Show the color"! !!PaintBox methodsFor: 'mouse events'!pickupMouseDown: evt morph: m    "Edit this method to add mouse-driven behavior."! !!PaintBox methodsFor: 'mouse events'!pickupMouseMove: evt morph: m    (m containsPoint: evt cursorPoint)        ifTrue: [(m findA: StringMorph) color: self buttonPressedColor.            m borderColor: Color black.            m borderWidth: 2]        ifFalse: [(m findA: StringMorph) color: self buttonUpColor.            m borderColor: Color gray.            m borderWidth: 1].! !!PaintBox methodsFor: 'mouse events' stamp: 'tk 4/23/97'!pickupMouseUp: evt morph: m    "Pickup is implemented totally here in the palette!!!!  Later keep the stamp form here too.  "    | ss |    (m findA: StringMorph) color: self buttonUpColor.    m borderColor: Color gray.    m borderWidth: 1.    (m fullContainsPoint: evt cursorPoint)         ifTrue: [            ss _ self world findA: SketchEditorMorph.            ss ifNotNil: [self setAction: m.                    ss pickup: nil.                    self setAction: stamp]     "choose Stamp tool next"                ifNil: [PopUpMenu notify:                     'First start painting by choosing "new drawing"']]        ifFalse: [self setAction: action].! !!PaintBox methodsFor: 'mouse events'!repAllButColorMouseDown: evt morph: m    "Edit this method to add mouse-driven behavior."! !!PaintBox methodsFor: 'mouse events'!repAllButColorMouseMove: evt morph: m    "Edit this method to add mouse-driven behavior."! !!PaintBox methodsFor: 'mouse events'!repAllButColorMouseUp: evt morph: m    "Edit this method to add mouse-driven behavior."    m color: evt hand chooseColor.    self setAction: repAllBut.! !!PaintBox methodsFor: 'mouse events'!repAllButMouseDown: evt morph: m    "Edit this method to add mouse-driven behavior."! !!PaintBox methodsFor: 'mouse events'!repAllButMouseMove: evt morph: m    (m containsPoint: evt cursorPoint)        ifTrue: [(m findA: StringMorph) color: self buttonPressedColor.            m borderColor: Color black.            m borderWidth: 2]        ifFalse: [(m findA: StringMorph) color: self buttonUpColor.            m borderColor: Color gray.            m borderWidth: 1].! !!PaintBox methodsFor: 'mouse events'!repAllButMouseUp: evt morph: m    (m findA: StringMorph) color: self buttonUpColor.    m borderColor: Color gray.    m borderWidth: 1.    (m fullContainsPoint: evt cursorPoint)         ifTrue: [self setAction: m]        ifFalse: [self setAction: action].! !!PaintBox methodsFor: 'mouse events'!repOnlyColorMouseDown: evt morph: m    "Edit this method to add mouse-driven behavior."! !!PaintBox methodsFor: 'mouse events'!repOnlyColorMouseMove: evt morph: m    "Edit this method to add mouse-driven behavior."! !!PaintBox methodsFor: 'mouse events'!repOnlyColorMouseUp: evt morph: m    "Edit this method to add mouse-driven behavior."    m color: evt hand chooseColor.    self setAction: repOnly.! !!PaintBox methodsFor: 'mouse events'!repOnlyMouseDown: evt morph: m    "Edit this method to add mouse-driven behavior."! !!PaintBox methodsFor: 'mouse events'!repOnlyMouseMove: evt morph: m    (m containsPoint: evt cursorPoint)        ifTrue: [(m findA: StringMorph) color: self buttonPressedColor.            m borderColor: Color black.            m borderWidth: 2]        ifFalse: [(m findA: StringMorph) color: self buttonUpColor.            m borderColor: Color gray.            m borderWidth: 1].! !!PaintBox methodsFor: 'mouse events'!repOnlyMouseUp: evt morph: m    (m findA: StringMorph) color: self buttonUpColor.    m borderColor: Color gray.    m borderWidth: 1.    (m fullContainsPoint: evt cursorPoint)         ifTrue: [self setAction: m]        ifFalse: [self setAction: action].! !!PaintBox methodsFor: 'mouse events'!saveMouseDown: evt morph: m    "Edit this method to add mouse-driven behavior."! !!PaintBox methodsFor: 'mouse events'!saveMouseMove: evt morph: m    (m containsPoint: evt cursorPoint)        ifTrue: [(m findA: StringMorph) color: self buttonPressedColor.            m borderColor: Color black.            m borderWidth: 2]        ifFalse: [(m findA: StringMorph) color: self buttonUpColor.            m borderColor: Color gray.            m borderWidth: 1].! !!PaintBox methodsFor: 'mouse events'!saveMouseUp: evt morph: m    "Edit this method to add mouse-driven behavior."    | ss |    (m findA: StringMorph) color: self buttonUpColor.    m borderColor: Color gray.    m borderWidth: 1.    (m fullContainsPoint: evt cursorPoint) ifTrue: [        (ss _ self world findA: SketchEditorMorph)             ifNotNil: [ss save]            ifNil: [PopUpMenu notify: 'First start painting by choosing "New"']].! !!PaintBox methodsFor: 'mouse events'!stampMouseDown: evt morph: m    "Edit this method to add mouse-driven behavior."! !!PaintBox methodsFor: 'mouse events'!stampMouseMove: evt morph: m    (m containsPoint: evt cursorPoint)        ifTrue: [(m findA: StringMorph) color: self buttonPressedColor.            m borderColor: Color black.            m borderWidth: 2]        ifFalse: [(m findA: StringMorph) color: self buttonUpColor.            m borderColor: Color gray.            m borderWidth: 1].! !!PaintBox methodsFor: 'mouse events'!stampMouseUp: evt morph: m    "Edit this method to add mouse-driven behavior."    (m findA: StringMorph) color: self buttonUpColor.    m borderColor: Color gray.    m borderWidth: 1.    (m fullContainsPoint: evt cursorPoint) ifTrue: [        self setAction: m].! !!PaintBox methodsFor: 'mouse events'!toAndFroMouseDown: evt morph: m    "Edit this method to add mouse-driven behavior."! !!PaintBox methodsFor: 'mouse events'!toAndFroMouseMove: evt morph: m    (m containsPoint: evt cursorPoint)        ifTrue: [(m findA: StringMorph) color: self buttonPressedColor.            m borderColor: Color black.            m borderWidth: 2]        ifFalse: [(m findA: StringMorph) color: self buttonUpColor.            m borderColor: Color gray.            m borderWidth: 1].! !!PaintBox methodsFor: 'mouse events'!toAndFroMouseUp: evt morph: m    (m findA: StringMorph) color: self buttonUpColor.    (m fullContainsPoint: evt cursorPoint)         ifTrue: [self setRotation: m]        ifFalse: [self setRotation: rotate].! !!PaintBox methodsFor: 'mouse events'!transp1MouseDown: evt morph: m    "Edit this method to add mouse-driven behavior."    self setCurrentBrush: m! !!PaintBox methodsFor: 'mouse events'!transp1MouseMove: evt morph: m    "Edit this method to add mouse-driven behavior."! !!PaintBox methodsFor: 'mouse events'!transp1MouseUp: evt morph: m    "Edit this method to add mouse-driven behavior."! !!PaintBox methodsFor: 'mouse events'!transp2MouseDown: evt morph: m    "Edit this method to add mouse-driven behavior."    self setCurrentBrush: m! !!PaintBox methodsFor: 'mouse events'!transp2MouseMove: evt morph: m    "Edit this method to add mouse-driven behavior."! !!PaintBox methodsFor: 'mouse events'!transp2MouseUp: evt morph: m    "Edit this method to add mouse-driven behavior."! !!PaintBox methodsFor: 'mouse events'!transp3MouseDown: evt morph: m    "Edit this method to add mouse-driven behavior."    self setCurrentBrush: m! !!PaintBox methodsFor: 'mouse events'!transp3MouseMove: evt morph: m    "Edit this method to add mouse-driven behavior."! !!PaintBox methodsFor: 'mouse events'!transp3MouseUp: evt morph: m    "Edit this method to add mouse-driven behavior."! !!PaintBox methodsFor: 'mouse events'!transp4MouseDown: evt morph: m    "Edit this method to add mouse-driven behavior."    self setCurrentBrush: m! !!PaintBox methodsFor: 'mouse events'!transp4MouseMove: evt morph: m    "Edit this method to add mouse-driven behavior."! !!PaintBox methodsFor: 'mouse events'!transp4MouseUp: evt morph: m    "Edit this method to add mouse-driven behavior."! !!PaintBox methodsFor: 'mouse events'!undoMouseMove: evt morph: m    (m containsPoint: evt cursorPoint)        ifTrue: [(m findA: StringMorph) color: self buttonPressedColor.            m borderColor: Color black.            m borderWidth: 2]        ifFalse: [(m findA: StringMorph) color: self buttonUpColor.            m borderColor: Color gray.            m borderWidth: 1].! !!PaintBox methodsFor: 'mouse events'!undoMouseUp: evt morph: m    "Edit this method to add mouse-driven behavior."    | ss |    (m findA: StringMorph) color: self buttonUpColor.    m borderColor: Color gray.    m borderWidth: 1.    (m fullContainsPoint: evt cursorPoint) ifTrue: [        (ss _ self world findA: SketchEditorMorph)             ifNotNil: [ss undo]            ifNil: [PopUpMenu notify: 'First start painting by choosing "New"']].! !!PaintBox methodsFor: 'public access'!action    "Return the value of action"    ^ action! !!PaintBox methodsFor: 'public access'!actionPut: newValue    "Assign newValue to action.    Add code below to update related graphics appropriately..."    action _ newValue.! !!PaintBox methodsFor: 'public access'!background    ^background! !!PaintBox methodsFor: 'public access'!buttonPressedColor    ^ Color red! !!PaintBox methodsFor: 'public access'!buttonUpColor    ^ Color black! !!PaintBox methodsFor: 'public access'!chip13    ^chip13! !!PaintBox methodsFor: 'public access'!chip14    ^chip14! !!PaintBox methodsFor: 'public access'!chip15    ^chip15! !!PaintBox methodsFor: 'public access'!chip16    ^chip16! !!PaintBox methodsFor: 'public access'!currentBrush    "Return the value of currentBrush"    ^ currentBrush! !!PaintBox methodsFor: 'public access'!currentBrushPut: newValue    "Assign newValue to currentBrush.    Add code below to update related graphics appropriately..."    currentBrush _ newValue.! !!PaintBox methodsFor: 'public access'!currentColor    "Return the value of currentColor"    ^ currentColor! !!PaintBox methodsFor: 'public access'!currentColorPut: newValue    "Assign newValue to currentColor.    Add code below to update related graphics appropriately..."    currentColor _ newValue.! !!PaintBox methodsFor: 'public access' stamp: 'tk 5/5/97'!delete    "Clean up -- I am no longer the current palette.  "    | ss |    owner ifNotNil: [        (ss _ self world findA: SketchEditorMorph) ifNotNil: [ss save]].    super delete! !!PaintBox methodsFor: 'public access'!paint    ^ paint! !!PaintBox methodsFor: 'public access'!repAllButColor    ^repAllButColor! !!PaintBox methodsFor: 'public access'!repOnlyColor    ^repOnlyColor! !!PaintBox methodsFor: 'public access'!rotate    "Return the value of rotate"    ^ rotate! !!PaintBox methodsFor: 'public access'!rotatePut: newValue    "Assign newValue to rotate.    Add code below to update related graphics appropriately..."    rotate _ newValue.! !!PaintBox methodsFor: 'public access'!save    ^save! !!PaintBox methodsFor: 'public access' stamp: 'tk 5/5/97'!thumbnailOn: aMorph    "Try to show mineature of this guy.  "    (aMorph isKindOf: SketchMorph) ifTrue: [        thumbnail morphToView: aMorph.        thumbnail step.        self world displayWorld].    ! !!PaintBox methodsFor: 'private - propagation'!action: newValue    "Assigns newValue to action and updates owner"    action _ newValue.    self propagate: action as: 'action:'! !!PaintBox methodsFor: 'private - propagation'!currentBrush: newValue    "Assigns newValue to currentBrush and updates owner"    currentBrush _ newValue.    self propagate: currentBrush as: 'currentBrush:'! !!PaintBox methodsFor: 'private - propagation'!currentColor: newValue    "Assigns newValue to currentColor and updates owner"    currentColor _ newValue.    self propagate: currentColor as: 'currentColor:'! !!PaintBox methodsFor: 'private - propagation'!rotate: newValue    "Assigns newValue to rotate and updates owner"    rotate _ newValue.    self propagate: rotate as: 'rotate:'! !!PaintBox methodsFor: 'private - propagation' stamp: '6/7/97 10:42 di'!wantsSlot    "For now do it the old way, until we sort this out"    ^ true! !!PaintBox methodsFor: 'private' stamp: 'tk 6/3/97'!fix1    "Update the buttons.  "| old new aSymbol b |#(cancel) do: [:name |    old _ self instVarNamed: name.    new _ StringButtonMorph new.    new contents: (old findA: StringMorph) contents;        color: self buttonOffColor;        target: self;        actionSelector: aSymbol.    self addMorphBack: b].! !!PaintBox methodsFor: 'private' stamp: 'tk 6/3/97'!fix2    "Update the buttons.      PaintBox allInstancesDo: [:pp | pp fix2].        "    " PaintBox prototype removeUselessCalls.""| var name | var _ repAllBut.  name _ 'repAllBut'.var on: #mouseDown send: nil to: nil.var on: #mouseStillDown send: (name,'MouseMove:morph:') asSymbol to: self.var on: #mouseUp send: (name,'MouseUp:morph:') asSymbol to: self."cancel on: #mouseStillDown send: #cancelMouseMove:morph: to: self.save on: #mouseStillDown send: #saveMouseMove:morph: to: self.paint on: #mouseStillDown send: #paintMouseMove:morph: to: self.paint on: #mouseUp send: #paintMouseUp:morph: to: self.pickup on: #mouseStillDown send: #pickupMouseMove:morph: to: self.action on: #mouseStillDown send: nil to: nil.stamp on: #mouseStillDown send: #stampMouseMove:morph: to: self.repOnly on: #mouseStillDown send: #repOnlyMouseMove:morph: to: self.repAllBut on: #mouseStillDown send: #repAllButMouseMove:morph: to: self.doRotate on: #mouseStillDown send: #doRotateMouseMove:morph: to: self.noRotate on: #mouseStillDown send: #noRotateMouseMove:morph: to: self.toAndFro on: #mouseStillDown send: #toAndFroMouseMove:morph: to: self.newObject on: #mouseStillDown send: #cancelMouseMove:morph: to: self.background on: #mouseStillDown send: #cancelMouseMove:morph: to: self.! !!PaintBox methodsFor: 'private' stamp: 'tk 6/29/97 11:48'!fix3    "Block out grabbing of paintBox"    self on: #mouseDown send: #yourself to: self! !!PaintBox class methodsFor: 'instance creation' stamp: 'di 6/22/97 09:14'!includeInNewMorphMenu    "Not to be instantiated from the menu"    ^ false! !!Paragraph methodsFor: 'accessing'!backgroundColor    backColor == nil ifTrue: [^ Color white].    ^ backColor! !!Paragraph methodsFor: 'accessing'!replaceFrom: start to: stop with: aText displaying: displayBoolean    "Replace the receiver's text starting at position start, stopping at stop, by     the characters in aText. It is expected that most requirements for     modifications to the receiver will call this code. Certainly all cut's or     paste's."     | compositionScanner obsoleteLines obsoleteLastLine firstLineIndex lastLineIndex    startLine stopLine replacementRange visibleRectangle startIndex newLine done    newStop obsoleteY newY moveRectangle |    text replaceFrom: start to: stop with: aText.        "Update the text."    lastLine = 0 ifTrue:        ["if lines have never been set up, measure them and display        all the lines falling in the visibleRectangle"        self composeAll.        displayBoolean ifTrue: [^ self displayLines: (1 to: lastLine)]].    "save -- things get pretty mashed as we go along"    obsoleteLines _ lines copy.    obsoleteLastLine _ lastLine.    "find the starting and stopping lines"    firstLineIndex _ startLine _ self lineIndexOfCharacterIndex: start.    stopLine _ self lineIndexOfCharacterIndex: stop.    "how many characters being inserted or deleted        -- negative if aText size is < characterInterval size."    replacementRange _ aText size - (stop - start + 1).    "Give ourselves plenty of elbow room."    compositionRectangle _ compositionRectangle withHeight: (textStyle lineGrid * 9999).    "build a boundingBox of the actual screen space in question -- we'll need it later"    visibleRectangle _ (clippingRectangle intersect: compositionRectangle)                            intersect: destinationForm boundingBox.    compositionScanner _ CompositionScanner new in: self.        "Initialize a scanner."    "If the starting line is not also the first line, then measuring must commence from line preceding the one in which characterInterval start appears.  For example, deleting a line with only a carriage return may move characters following the deleted portion of text into the line preceding the deleted line."    startIndex _ (lines at: firstLineIndex) first.    startLine > 1        ifTrue:     [newLine _ compositionScanner composeLine: startLine - 1                        fromCharacterIndex: (lines at: startLine - 1) first                        inParagraph: self.                (lines at: startLine - 1) = newLine                    ifFalse:    ["start in line preceding the one with the starting character"                            startLine _ startLine - 1.                            self lineAt: startLine put: newLine.                            startIndex _ newLine last + 1]].    startIndex > text size ifTrue:        ["nil lines after a deletion -- remeasure last line below"        self trimLinesTo: (firstLineIndex - 1 max: 0).        text size = 0 ifTrue:            ["entire text deleted -- clear visibleRectangle and return."            destinationForm fill: visibleRectangle rule: rule fillColor: self backgroundColor.            self updateCompositionHeight.            ^self]].    "Now we really get to it."    done _ false.    lastLineIndex _ stopLine.    [done or: [startIndex > text size]]        whileFalse:         [self lineAt: firstLineIndex put:            (newLine _ compositionScanner composeLine: firstLineIndex                            fromCharacterIndex: startIndex inParagraph: self).        [(lastLineIndex > obsoleteLastLine            or: ["no more old lines to compare with?"                newLine last <                    (newStop _ (obsoleteLines at: lastLineIndex) last + replacementRange)])                  or: [done]]            whileFalse:             [newStop = newLine last                ifTrue:    ["got the match"                        "get source and dest y's for moving the unchanged lines"                        obsoleteY _ self topAtLineIndex: lastLineIndex + 1                                    using: obsoleteLines and: obsoleteLastLine.                        newY _ self topAtLineIndex: firstLineIndex + 1.                        stopLine _ firstLineIndex.                        done _ true.                            "Fill in the new line vector with the old unchanged lines.                            Update their starting and stopping indices on the way."                        ((lastLineIndex _ lastLineIndex + 1) to: obsoleteLastLine) do:                            [:upDatedIndex |                             self lineAt: (firstLineIndex _ firstLineIndex + 1)                                 put: ((obsoleteLines at: upDatedIndex)                                      slide: replacementRange)].                            "trim off obsolete lines, if any"                        self trimLinesTo: firstLineIndex]                ifFalse:    [lastLineIndex _ lastLineIndex + 1]].        startIndex _ newLine last + 1.        firstLineIndex _ firstLineIndex + 1].    "Now the lines are up to date -- Whew!!.  What remains is to move    the 'unchanged' lines and display those which have changed."    displayBoolean   "Not much to do if not displaying"        ifFalse: [^ self updateCompositionHeight].    startIndex > text size ifTrue:        ["If at the end of previous lines simply display lines from the line in        which the first character of the replacement occured through the        end of the paragraph."        self updateCompositionHeight.        self displayLines:            (startLine to: (stopLine _ firstLineIndex min: lastLine)).        destinationForm  "Clear out area at the bottom"            fill: ((visibleRectangle left @ (self topAtLineIndex: lastLine + 1)                        extent: visibleRectangle extent)                    intersect: visibleRectangle)            rule: rule fillColor: self backgroundColor]        ifFalse:        [newY ~= obsoleteY ifTrue:            ["Otherwise first move the unchanged lines within            the visibleRectangle with a good old bitblt."            moveRectangle _                visibleRectangle left @ (obsoleteY max: visibleRectangle top)                    corner: visibleRectangle corner.            destinationForm copyBits: moveRectangle from: destinationForm                at: moveRectangle origin + (0 @ (newY-obsoleteY))                clippingBox: visibleRectangle                rule: Form over fillColor: nil].        "Then display the altered lines."        self displayLines: (startLine to: stopLine).        newY < obsoleteY            ifTrue:            [(self topAtLineIndex: obsoleteLastLine+1 using: obsoleteLines and: obsoleteLastLine) > visibleRectangle bottom                ifTrue:                ["A deletion may have 'pulled' previously undisplayed lines                into the visibleRectangle.  If so, display them."                self displayLines:                    ((self lineIndexOfTop: visibleRectangle bottom - (obsoleteY - newY))                        to: (self lineIndexOfTop: visibleRectangle bottom))].            "Clear out obsolete material at the bottom of the visibleRectangle."            destinationForm                fill: ((visibleRectangle left @ ((self bottomAtLineIndex: lastLine) + 1)                        extent: visibleRectangle extent)                    intersect: visibleRectangle)  "How about just corner: ??"                rule: rule fillColor: self backgroundColor].        (newY > obsoleteY and: [obsoleteY < visibleRectangle top])            ifTrue:                ["An insertion may have 'pushed' previously undisplayed lines                into the visibleRectangle.  If so, display them."                self displayLines:                    ((self lineIndexOfTop: visibleRectangle top)                        to: (self lineIndexOfTop: visibleRectangle top + (newY-obsoleteY)))].        self updateCompositionHeight]! !!Paragraph methodsFor: 'displaying'!displayOn: aDisplayMedium at: aDisplayPoint clippingBox: clipRectangle rule: ruleInteger fillColor: aForm    "Default display message when aDisplayPoint is in absolute screen    coordinates."    rule _ ruleInteger.    mask _ aForm.    clippingRectangle _ clipRectangle.    compositionRectangle _ aDisplayPoint extent: compositionRectangle extent.    (lastLine == nil or: [lastLine < 1]) ifTrue: [self composeAll].    self displayOn: aDisplayMedium lines: (1 to: lastLine)! !!Paragraph methodsFor: 'composition'!composeAll    "Compose a collection of characters into a collection of lines."    | startIndex stopIndex lineIndex maximumRightX compositionScanner |    lines _ Array new: 32.    lastLine _ 0.    maximumRightX _ 0.    text size = 0        ifTrue:            [compositionRectangle _ compositionRectangle withHeight: 0.            ^maximumRightX].    startIndex _ lineIndex _ 1.    stopIndex _ text size.    compositionScanner _ CompositionScanner new in: self.    [startIndex > stopIndex] whileFalse:         [self lineAt: lineIndex                 put: (compositionScanner composeLine: lineIndex                                         fromCharacterIndex: startIndex                                         inParagraph: self).         maximumRightX _ compositionScanner rightX max: maximumRightX.         startIndex _ (lines at: lineIndex) last + 1.         lineIndex _ lineIndex + 1].    self updateCompositionHeight.    self trimLinesTo: lineIndex - 1.    ^ maximumRightX! !!Paragraph methodsFor: 'selecting'!caretFormForDepth: depth    "Return a caret form for the given depth."    "(Paragraph new caretFormForDepth: Display depth) displayOn: Display at: 0@0 rule: Form reverse"    | box f bb map |    box _ CaretForm boundingBox.    f _ Form extent: box extent depth: depth.    map _ (Color cachedColormapFrom: CaretForm depth to: depth) copy.    map at: 1 put: (Color transparent pixelValueForDepth: depth).    map at: 2 put: (Color quickHighLight: depth) first.  "pixel value for reversing"    bb _ BitBlt toForm: f.    bb        sourceForm: CaretForm;        sourceRect: box;        destOrigin: 0@0;        colorMap: map;         combinationRule: Form over;        copyBits.    ^ f! !!Paragraph methodsFor: 'selecting'!clickAt: clickPoint for: model     "Give sensitive text a chance to fire.  Display flash: (100@100 extent: 100@100)."    | startBlock action range box |    action _ false.    startBlock _ self characterBlockAtPoint: clickPoint.    (text attributesAt: startBlock stringIndex)         do: [:att | att mayActOnClick ifTrue:                [range _ text rangeOf: att startingAt: startBlock stringIndex.                box _ ((self characterBlockForIndex: range first) topLeft)                    corner: ((self characterBlockForIndex: range last) bottomRight).                Utilities awaitMouseUpIn: box repeating: []                        ifSucceed: [(att actOnClickFor: model) ifTrue: [action _ true]].                ]].    ^ action! !!Paragraph methodsFor: 'selecting' stamp: 'di 6/23/97 23:14'!hiliteRect: rect    (rect ~~ nil) ifTrue:        [ destinationForm            fill: rect            rule: Form reverse            fillColor: destinationForm highLight.        "destinationForm            fill: (rect translateBy: 1@1)            rule: Form reverse            fillColor: destinationForm highLight" ].! !!Paragraph methodsFor: 'selecting'!reverseFrom: characterBlock1 to: characterBlock2     "Reverse area between the two character blocks given as arguments."    | visibleRectangle initialRectangle interiorRectangle finalRectangle lineNo baseline caret |    characterBlock1 = characterBlock2 ifTrue:        [lineNo _ self lineIndexOfCharacterIndex: characterBlock1 stringIndex.        baseline _ lineNo = 0 ifTrue: [textStyle baseline]                            ifFalse: [(lines at: lineNo) baseline].        caret _ self caretFormForDepth: Display depth.        ^ caret  "Use a caret to indicate null selection"                displayOn: destinationForm                at: characterBlock1 topLeft + (-3 @ baseline)                clippingBox: clippingRectangle                rule: (false "Display depth>8" ifTrue: [9 "not-reverse"]                                    ifFalse: [Form reverse])                fillColor: nil].    visibleRectangle _         (clippingRectangle intersect: compositionRectangle)            "intersect: destinationForm boundingBox" "not necessary".    characterBlock1 top = characterBlock2 top        ifTrue: [characterBlock1 left < characterBlock2 left                    ifTrue:                         [initialRectangle _                             (characterBlock1 topLeft corner: characterBlock2 bottomLeft)                                intersect: visibleRectangle]                    ifFalse:                         [initialRectangle _                             (characterBlock2 topLeft corner: characterBlock1 bottomLeft)                                intersect: visibleRectangle]]        ifFalse: [characterBlock1 top < characterBlock2 top                    ifTrue:                         [initialRectangle _                             (characterBlock1 topLeft                                 corner: visibleRectangle right @ characterBlock1 bottom)                                intersect: visibleRectangle.                        characterBlock1 bottom = characterBlock2 top                            ifTrue:                                 [finalRectangle _                                     (visibleRectangle left @ characterBlock2 top                                         corner: characterBlock2 bottomLeft)                                        intersect: visibleRectangle]                            ifFalse:                                 [interiorRectangle _                                     (visibleRectangle left @ characterBlock1 bottom                                        corner: visibleRectangle right                                                         @ characterBlock2 top)                                        intersect: visibleRectangle.                                finalRectangle _                                     (visibleRectangle left @ characterBlock2 top                                         corner: characterBlock2 bottomLeft)                                        intersect: visibleRectangle]]                ifFalse:                     [initialRectangle _                         (visibleRectangle left @ characterBlock1 top                             corner: characterBlock1 bottomLeft)                            intersect: visibleRectangle.                    characterBlock1 top = characterBlock2 bottom                        ifTrue:                             [finalRectangle _                                 (characterBlock2 topLeft                                     corner: visibleRectangle right                                                 @ characterBlock2 bottom)                                    intersect: visibleRectangle]                        ifFalse:                             [interiorRectangle _                                 (visibleRectangle left @ characterBlock2 bottom                                     corner: visibleRectangle right @ characterBlock1 top)                                    intersect: visibleRectangle.                            finalRectangle _                                 (characterBlock2 topLeft                                     corner: visibleRectangle right                                                 @ characterBlock2 bottom)                                    intersect: visibleRectangle]]].    self hiliteRect: initialRectangle.    self hiliteRect: interiorRectangle.    self hiliteRect: finalRectangle.! !!Paragraph methodsFor: 'selecting' stamp: 'di 10/2/97 09:25'!selectionRectsFrom: characterBlock1 to: characterBlock2     "Return an array of rectangles representing the area between the two character blocks given as arguments."    | visibleRectangle initialRectangle interiorRectangle finalRectangle lineNo baseline |    characterBlock1 = characterBlock2 ifTrue:        [lineNo _ self lineIndexOfCharacterIndex: characterBlock1 stringIndex.        baseline _ lineNo = 0 ifTrue: [textStyle baseline]                            ifFalse: [(lines at: lineNo) baseline].        ^ Array with: (characterBlock1 topLeft extent: 1 @ baseline)].    visibleRectangle _ clippingRectangle intersect: compositionRectangle.    characterBlock1 top = characterBlock2 top        ifTrue: [characterBlock1 left < characterBlock2 left                    ifTrue:                         [initialRectangle _                             (characterBlock1 topLeft corner: characterBlock2 bottomLeft)                                intersect: visibleRectangle]                    ifFalse:                         [initialRectangle _                             (characterBlock2 topLeft corner: characterBlock1 bottomLeft)                                intersect: visibleRectangle]]        ifFalse: [characterBlock1 top < characterBlock2 top                    ifTrue:                         [initialRectangle _                             (characterBlock1 topLeft                                 corner: visibleRectangle right @ characterBlock1 bottom)                                intersect: visibleRectangle.                        characterBlock1 bottom = characterBlock2 top                            ifTrue:                                 [finalRectangle _                                     (visibleRectangle left @ characterBlock2 top                                         corner: characterBlock2 bottomLeft)                                        intersect: visibleRectangle]                            ifFalse:                                 [interiorRectangle _                                     (visibleRectangle left @ characterBlock1 bottom                                        corner: visibleRectangle right                                                         @ characterBlock2 top)                                        intersect: visibleRectangle.                                finalRectangle _                                     (visibleRectangle left @ characterBlock2 top                                         corner: characterBlock2 bottomLeft)                                        intersect: visibleRectangle]]                ifFalse:                     [initialRectangle _                         (visibleRectangle left @ characterBlock1 top                             corner: characterBlock1 bottomLeft)                            intersect: visibleRectangle.                    characterBlock1 top = characterBlock2 bottom                        ifTrue:                             [finalRectangle _                                 (characterBlock2 topLeft                                     corner: visibleRectangle right                                                 @ characterBlock2 bottom)                                    intersect: visibleRectangle]                        ifFalse:                             [interiorRectangle _                                 (visibleRectangle left @ characterBlock2 bottom                                     corner: visibleRectangle right @ characterBlock1 top)                                    intersect: visibleRectangle.                            finalRectangle _                                 (characterBlock2 topLeft                                     corner: visibleRectangle right                                                 @ characterBlock2 bottom)                                    intersect: visibleRectangle]]].    ^ (Array with: initialRectangle with: interiorRectangle with: finalRectangle)            select: [:rect | rect notNil]! !!Paragraph methodsFor: 'scrolling'!scrollUncheckedBy: heightToMove withSelectionFrom: startBlock to: stopBlock     "Scroll by the given amount.  Copy bits where possible, display the rest.    If selection blocks are not nil, then select the newly visible text as well."    | savedClippingRectangle delta |    delta _ 0 @ (0 - heightToMove).    compositionRectangle _ compositionRectangle translateBy: delta.    startBlock == nil ifFalse:        [startBlock moveBy: delta.        stopBlock moveBy: delta].    savedClippingRectangle _ clippingRectangle.    clippingRectangle _ clippingRectangle intersect: Display boundingBox.    heightToMove abs >= clippingRectangle height      ifTrue:         ["Entire visible region must be repainted"        self displayLines: (1 to: lastLine) affectedRectangle: clippingRectangle]      ifFalse:        ["Copy bits where possible / display the rest"        destinationForm            copyBits: clippingRectangle from: destinationForm            at: clippingRectangle topLeft + delta            clippingBox: clippingRectangle            rule: Form over fillColor: nil.        "Set clippingRectangle to 'vacated' area for lines 'pulled' into view."        clippingRectangle _ heightToMove < 0            ifTrue:  "On the top"                [clippingRectangle topLeft corner: clippingRectangle topRight + delta]            ifFalse:  "At the bottom"                [clippingRectangle bottomLeft + delta corner: clippingRectangle bottomRight].        self displayLines: (1 to: lastLine)   "Refresh vacated region"            affectedRectangle: clippingRectangle].    startBlock == nil ifFalse:        [self reverseFrom: startBlock to: stopBlock].    "And restore the clippingRectangle to its original value. "    clippingRectangle _ savedClippingRectangle! !!Paragraph methodsFor: 'utilities'!fit    "Make the bounding rectangle of the receiver contain all the text without     changing the width of the receiver's composition rectangle."    [(self lineIndexOfTop: clippingRectangle top) = 1]        whileFalse: [self scrollBy: (0-1)*textStyle lineGrid].    self updateCompositionHeight.    clippingRectangle _ clippingRectangle withBottom: compositionRectangle bottom! !!Paragraph methodsFor: 'converting'!asForm    "Answer a Form made up of the bits that represent the receiver's displayable text."    | theForm oldBackColor oldForeColor |    theForm _ (ColorForm extent: compositionRectangle extent)        offset: offset;        colors: (Array            with: (backColor == nil ifTrue: [Color transparent] ifFalse: [backColor])            with: (foreColor == nil ifTrue: [Color black] ifFalse: [foreColor])).    oldBackColor _ backColor.    oldForeColor _ foreColor.    backColor _ Color white.    foreColor _ Color black.    self displayOn: theForm        at: 0@0        clippingBox: theForm boundingBox        rule: Form over        fillColor: nil.    backColor _ oldBackColor.    foreColor _ oldForeColor.    ^ theForm"Example:| p |p _ 'Abc' asParagraph.p foregroundColor: Color red backgroundColor: Color black.p asForm displayOn: Display at: 30@30 rule: Form over"! !!Paragraph methodsFor: 'private'!bottomAtLineIndex: lineIndex     "Answer the bottom y of given line."    | y |    y _ compositionRectangle top.    lastLine = 0 ifTrue: [^ y + textStyle lineGrid].    1 to: (lineIndex min: lastLine) do:        [:i | y _ y + (lines at: i) lineHeight].    ^ y! !!Paragraph methodsFor: 'private' stamp: 'tk 9/30/96'!compositionRectangle: compositionRect text: aText style: aTextStyle offset: aPoint    compositionRectangle _ compositionRect copy.    text _ aText.    textStyle _ aTextStyle.    rule _ DefaultRule.    mask _ nil.        "was DefaultMask "    marginTabsLevel _ 0.    destinationForm _ Display.    offset _ aPoint.    ^self composeAll! !!Paragraph methodsFor: 'private'!displayLines: linesInterval affectedRectangle: affectedRectangle    "This is the first level workhorse in the display portion of the TextForm routines.    It checks to see which lines in the interval are actually visible, has the    CharacterScanner display only those, clears out the areas in which display will    occur, and clears any space remaining in the visibleRectangle following the space    occupied by lastLine."    | lineGrid topY firstLineIndex lastLineIndex lastLineIndexBottom |    "Save some time by only displaying visible lines"    firstLineIndex _ self lineIndexOfTop: affectedRectangle top.    firstLineIndex < linesInterval first ifTrue: [firstLineIndex _ linesInterval first].    lastLineIndex _ self lineIndexOfTop: affectedRectangle bottom - 1.    lastLineIndex > linesInterval last ifTrue:            [linesInterval last > lastLine                 ifTrue: [lastLineIndex _ lastLine]                  ifFalse: [lastLineIndex _ linesInterval last]].    lastLineIndexBottom _ (self bottomAtLineIndex: lastLineIndex).    ((Rectangle         origin: affectedRectangle left @ (topY _ self topAtLineIndex: firstLineIndex)         corner: affectedRectangle right @ lastLineIndexBottom)      intersects: affectedRectangle)        ifTrue: [ " . . . (skip to clear-below if no lines displayed)"                DisplayScanner new                    displayLines: (firstLineIndex to: lastLineIndex)                    in: self clippedBy: affectedRectangle].    lastLineIndex = lastLine ifTrue:          [destinationForm  "Clear out white space below last line"             fill: (affectedRectangle left @ (lastLineIndexBottom max: affectedRectangle top)                corner: affectedRectangle bottomRight)             rule: rule fillColor: self backgroundColor]! !!Paragraph methodsFor: 'private'!leftMarginForDisplayForLine: lineIndex     "Build the left margin for display of a line. Depends upon    leftMarginForComposition, compositionRectangle left and the alignment."    | pad |    (textStyle alignment = LeftFlush or: [textStyle alignment = Justified])        ifTrue:             [^compositionRectangle left                 + (self leftMarginForCompositionForLine: lineIndex)].    "When called from character location code and entire string has been cut,    there are no valid lines, hence following nil check."    (lineIndex <= lines size and: [(lines at: lineIndex) notNil])        ifTrue:             [pad _ (lines at: lineIndex) paddingWidth]        ifFalse:             [pad _                 compositionRectangle width - textStyle firstIndent - textStyle rightIndent].    textStyle alignment = Centered         ifTrue:             [^compositionRectangle left                 + (self leftMarginForCompositionForLine: lineIndex) + (pad // 2)].    textStyle alignment = RightFlush         ifTrue:            [^compositionRectangle left                 + (self leftMarginForCompositionForLine: lineIndex) + pad].    self error: ['no such alignment']! !!Paragraph methodsFor: 'private'!lineIndexOfTop: top     "Answer the line index at a given top y."    | y line |    lastLine = 0 ifTrue: [^ 1].    y _ compositionRectangle top.    1 to: lastLine do:        [:i | line _ lines at: i.        (y _ y + line lineHeight) > top ifTrue: [^ i]].    ^ lastLine! !!Paragraph methodsFor: 'private'!moveBy: delta    compositionRectangle _ compositionRectangle translateBy: delta.    clippingRectangle _ clippingRectangle translateBy: delta.! !!Paragraph methodsFor: 'private'!removeFirstChars: numberOfChars    "Remove a number of characters from the beginning of the receiver,    adjusting the composition rectangle so the displayed text moves as little as    possible. Special kludge for TextCollectorController."    "9/14/82 SBP"    | delta scrollDelta |    delta _ ((self lineIndexOfCharacterIndex: numberOfChars)-1)*self lineGrid.    scrollDelta _ self compositionRectangleDelta negated.    delta > scrollDelta ifTrue:        [delta _ scrollDelta.     "deleting some visible lines"        self clearVisibleRectangle].    self replaceFrom: 1 to: numberOfChars with: '' asText displaying: false.    compositionRectangle _ compositionRectangle translateBy: 0@delta.    delta = scrollDelta ifTrue: [self display]! !!Paragraph methodsFor: 'private'!setWithText: aText style: aTextStyle     "Set text and adjust bounding rectangles to fit."    | shrink compositionWidth unbounded |    unbounded _ Rectangle origin: 0 @ 0 extent: 9999@9999.    compositionWidth _ self        setWithText: aText style: aTextStyle compositionRectangle: unbounded clippingRectangle: unbounded.    compositionRectangle _ compositionRectangle withWidth: compositionWidth.    clippingRectangle _ compositionRectangle copy.    shrink _ unbounded width - compositionWidth.    "Shrink padding widths accordingly"    1 to: lastLine do:        [:i | (lines at: i) paddingWidth: (lines at: i) paddingWidth - shrink]! !!Paragraph methodsFor: 'private'!topAtLineIndex: lineIndex     "Answer the top y of given line."    | y |    y _ compositionRectangle top.    lastLine = 0 ifTrue: [lineIndex > 0 ifTrue: [^ y + textStyle lineGrid]. ^ y].    1 to: (lineIndex-1 min: lastLine) do:        [:i | y _ y + (lines at: i) lineHeight].    ^ y! !!Paragraph methodsFor: 'private'!topAtLineIndex: lineIndex using: otherLines and: otherLastLine    "Answer the top y of given line."    | y |    y _ compositionRectangle top.    otherLastLine = 0 ifTrue: [^ y].    1 to: (lineIndex-1 min: otherLastLine) do:        [:i | y _ y + (otherLines at: i) lineHeight].    ^ y! !!Paragraph methodsFor: 'private'!updateCompositionHeight    "Mainly used to insure that intersections with compositionRectangle work."     compositionRectangle _ compositionRectangle withHeight:        (self bottomAtLineIndex: lastLine) - compositionRectangle top.    (text size ~= 0 and: [(text at: text size) = CR])        ifTrue: [compositionRectangle _ compositionRectangle withHeight:                    compositionRectangle height + (lines at: lastLine) lineHeight]! !!Paragraph methodsFor: 'private' stamp: 'di 8/30/97 11:14'!withClippingRectangle: clipRect do: aBlock    | saveClip |    saveClip _ clippingRectangle.    clippingRectangle _ clipRect.        aBlock value.    clippingRectangle _ saveClip! !!Paragraph class methodsFor: 'examples' stamp: 'tk 9/30/96'!example    "This simple example illustrates how to display a few lines of text on the screen at the current cursor point.      Fixed. "    | para point |    point _ Sensor waitButton.    para _ 'This is the first line of charactersand this is the second line.' asParagraph.    para displayOn: Display at: point.    "Paragraph example"! !!ParagraphEditor methodsFor: 'scrolling'!computeMarkerRegion     "Refer to the comment in ScrollController|computeMarkerRegion."    paragraph compositionRectangle height = 0        ifTrue:    [^0@0 extent: Preferences scrollBarWidth @ scrollBar inside height]        ifFalse:    [^0@0 extent:                    Preferences scrollBarWidth                         @ ((paragraph clippingRectangle height asFloat /                            self scrollRectangleHeight * scrollBar inside height) rounded                            min: scrollBar inside height)]! !!ParagraphEditor methodsFor: 'scrolling'!scrollBar    ^ scrollBar! !!ParagraphEditor methodsFor: 'sensor access'!processRedButton    "The user pressed a red mouse button, meaning create a new text     selection. Highlighting the selection is carried out by the paragraph     itself. Double clicking causes a selection of the area between the nearest     enclosing delimitors."    | previousStartBlock previousStopBlock selectionBlocks tempBlock clickPoint oldDelta oldInterval |    clickPoint _ sensor cursorPoint.    (view containsPoint: clickPoint) ifFalse: [^ self].    (paragraph clickAt: clickPoint for: nil) ifTrue: [^ self].    oldInterval _ startBlock stringIndex to: stopBlock stringIndex - 1.    previousStartBlock _ startBlock.    previousStopBlock _ stopBlock.    oldDelta _ paragraph scrollDelta.    sensor leftShiftDown        ifFalse:            [self deselect.            self closeTypeIn.            selectionBlocks _ paragraph mouseSelect: clickPoint]        ifTrue:            [selectionBlocks _ paragraph extendSelectionAt: startBlock endBlock: stopBlock.            self closeTypeIn].    selectionShowing _ true.    startBlock _ selectionBlocks at: 1.    stopBlock _ selectionBlocks at: 2.    startBlock > stopBlock        ifTrue:             [tempBlock _ startBlock.            startBlock _ stopBlock.            stopBlock _ tempBlock].    (startBlock = stopBlock         and: [previousStartBlock = startBlock and: [previousStopBlock = stopBlock]])        ifTrue: [self selectWord].    oldDelta ~= paragraph scrollDelta "case of autoscroll"            ifTrue: [self updateMarker].    self setEmphasisHere.    (self isDisjointFrom: oldInterval) ifTrue:        [otherInterval _ oldInterval]! !!ParagraphEditor methodsFor: 'menu messages' stamp: 'di 10/2/97 11:36'!changeAlignment    | aList reply  |    aList _ #(leftFlush centered justified rightFlush).    reply _ (SelectionMenu labelList: aList selections: aList) startUp.    reply ~~ nil ifTrue:        [paragraph perform: reply.        paragraph composeAll.        self recomputeSelection.        self mvcRedisplay].    ^ true! !!ParagraphEditor methodsFor: 'menu messages' stamp: 'di 10/2/97 11:39'!changeEmphasis    | aList reply  |    aList _ #(plain bold italic narrow underlined struckOut).    reply _ (SelectionMenu labelList: aList selections: aList) startUp.    reply ~~ nil ifTrue:        [self setEmphasis: reply.        paragraph composeAll.        self recomputeSelection.        self mvcRedisplay].    ^ true! !!ParagraphEditor methodsFor: 'menu messages' stamp: 'di 10/2/97 11:41'!changeStyle    "Let user change styles for the current text pane       Moved from experimentalCommand to its own method  "    | aList reply style |    aList _ (TextConstants select: [:thang | thang isKindOf: TextStyle])            keys asOrderedCollection.    reply _ (SelectionMenu labelList: aList selections: aList) startUp.    reply ~~ nil ifTrue:        [style _ TextConstants at: reply ifAbsent: [self beep. ^ true].        paragraph textStyle: style copy.        paragraph composeAll.        self recomputeSelection.        self mvcRedisplay].    ^ true! !!ParagraphEditor methodsFor: 'menu messages'!clipboardText    "Return the text currently in the clipboard. If the system clipboard is empty, or if it differs from the Smalltalk clipboard text, use the Smalltalk clipboard. This is done since (a) the Mac clipboard gives up on very large chunks of text and (b) since not all platforms support the notion of a clipboard."    | s |    s _ Smalltalk clipboardText.    (s isEmpty or: [s = CurrentSelection string])        ifTrue: [^ CurrentSelection]        ifFalse: [^ s asText]! !!ParagraphEditor methodsFor: 'menu messages' stamp: 'sw 1/15/96'!explain    "Try to shed some light on what kind of entity the current selection is.     The selection must be a single token or construct. Insert the answer after     the selection. Send private messages whose names begin with 'explain'     that return a string if they recognize the selection, else nil.    : put here intact from BrowserCodeController.  But there's too many things that still don't work, as the explain code was very tightly bound with properties of code browsers.  So for the moment, in the interest of system integrity, we don't permit.  "    | string tiVars cgVars selectors delimitors numbers sorry reply newLine |    true ifTrue:        [self flag: #noteToTed.   "Feel like taking this on?  Plenty of things make sense to explain in any text window, but my efforts to elevate the explain facility to more generic use ran out of steam before success."        ^ self inform: 'Sorry, explain is currently availableonly in code panes.  Someday, it may be availablein any text pane.  Maybe.'].    newLine _ String with: Character cr.    Cursor execute        showWhile:             [sorry _ '"Sorry, I can''t explain that.  Please select a single token, construct, or special character.'.            sorry _ sorry , (model isUnlocked                            ifTrue: ['"']                            ifFalse: ['  Also, please cancel or accept."']).            (string _ self selection asString) isEmpty                ifTrue: [reply _ '']                ifFalse:                     [string _ self explainScan: string.                    "Remove space, tab, cr"                    "Temps and Instance vars need only test strings that are                     all                      letters"                    (string detect: [:char | (char isLetter or: [char isDigit]) not]                        ifNone: [])                        ~~ nil                        ifFalse:                             [tiVars _ self explainTemp: string.                            tiVars == nil ifTrue: [tiVars _ self explainInst: string]].                    (tiVars == nil and: [model class == Browser])                        ifTrue: [tiVars _ model explainSpecial: string].                    tiVars == nil                        ifTrue: [tiVars _ '']                        ifFalse: [tiVars _ tiVars , newLine].                    "Context, Class, Pool, and Global vars, and Selectors need                     only test symbols"                    (Symbol hasInterned: string ifTrue: [:symbol | symbol])                        ifTrue:                             [cgVars _ self explainCtxt: symbol.                            cgVars == nil                                ifTrue:                                     [cgVars _ self explainClass: symbol.                                    cgVars == nil ifTrue: [cgVars _ self explainGlobal: symbol]].                            "See if it is a Selector (sent here or not)"                            selectors _ self explainMySel: symbol.                            selectors == nil                                ifTrue:                                     [selectors _ self explainPartSel: string.                                    selectors == nil ifTrue: [selectors _ self explainAnySel: symbol]]]                        ifFalse: [selectors _ self explainPartSel: string].                    cgVars == nil                        ifTrue: [cgVars _ '']                        ifFalse: [cgVars _ cgVars , newLine].                    selectors == nil                        ifTrue: [selectors _ '']                        ifFalse: [selectors _ selectors , newLine].                    string size = 1                        ifTrue: ["single special characters"                            delimitors _ self explainChar: string]                        ifFalse: ["matched delimitors"                            delimitors _ self explainDelimitor: string].                    numbers _ self explainNumber: string.                    numbers == nil ifTrue: [numbers _ ''].                    delimitors == nil ifTrue: [delimitors _ ''].                    reply _ tiVars , cgVars , selectors , delimitors , numbers].            reply size = 0 ifTrue: [reply _ sorry].            self afterSelectionInsertAndSelect: reply]! !!ParagraphEditor methodsFor: 'menu messages' stamp: 'sw 1/15/96'!explainGlobal: symbol     "Is symbol a global variable?     : copied intact from BrowserCodeController"    | reply classes newLine |    self flag: #noteToTed.  "a fumbling piece of the generic-explain attempt."    newLine _ String with: Character cr.    reply _ Smalltalk at: symbol ifAbsent: [^nil].    (reply isKindOf: Behavior)        ifTrue: [^'"is a global variable.  ' , symbol , ' is a class in category ', reply category,            '."', newLine, 'Browser newOnClass: ' , symbol , '.'].    symbol == #Smalltalk ifTrue: [^'"is a global.  Smalltalk is the only instance of SystemDictionary and holds all global variables."'].    reply class == Dictionary        ifTrue:             [classes _ Set new.            Smalltalk allBehaviorsDo: [:each | (each sharedPools detect: [:pool | pool == reply]                    ifNone: [])                    ~~ nil ifTrue: [classes add: each]].            classes _ classes printString.            ^'"is a global variable.  ' , symbol , ' is a Dictionary.  It is a pool which is used by the following classes' , (classes copyFrom: 4 to: classes size) , '"'].    ^'"is a global variable.  ' , symbol , ' is ' , reply printString , '"'! !!ParagraphEditor methodsFor: 'menu messages'!methodSourceContainingIt    "Open a browser on methods which contain the current selection in their source (case-sensitive full-text search of source).   EXTREMELY slow!!"    startBlock = stopBlock ifTrue: [view flash.  ^ self].    (self confirm: 'This will take a few minutes.Shall I proceed?') ifFalse: [^ self].    Smalltalk browseMethodsWithSourceString: self selection string! !!ParagraphEditor methodsFor: 'menu messages' stamp: 'di 10/2/97 11:34'!mvcRedisplay    "Overridable by subclasses that do their own display"    Display fill: paragraph clippingRectangle             fillColor: view backgroundColor.    "very brute force"    self display! !!ParagraphEditor methodsFor: 'menu messages' stamp: 'sw 4/29/96'!specialMenuItems    "Refer to comment under #presentSpecialMenu.  .     : added objectsReferencingIt,"    ^ #(    'Transcript cr; show: ''testing'''            'view superView model inspect'            'view superView model browseObjClass'            'view display'            'self inspect'            'view backgroundColor: Color fromUser'            'view topView inspect'            'self compareToClipboard'            'view insideColor: Form white'            'self objectsReferencingIt'        ) ! !!ParagraphEditor methodsFor: 'editing keys'!changeEmphasis: characterStream     "Change the emphasis of the current selection or prepare to accept     characters with the change in emphasis. Emphasis change amounts to a     font change.  Keeps typeahead."    | keyCode attribute oldAttributes index |         "control 0..9 -> 0..9"    keyCode _ ('0123456789-=' indexOf: sensor keyboard ifAbsent: [1]) - 1.    oldAttributes _ paragraph text attributesAt: startBlock stringIndex.    "Decipher keyCodes for Command 0-9..."    (keyCode between: 1 and: 5) ifTrue:        [attribute _ TextFontChange fontNumber: keyCode].    keyCode = 6 ifTrue:        [index _ (PopUpMenu labelArray: #(black magenta red yellow green blue active)                            lines: #(6)) startUp.        index = 0 ifTrue: [^ true].        attribute _ index = 7        ifTrue: [TextAction evalString: self selection asString]        ifFalse: [TextColor color: (Color perform: (#(black magenta red yellow green blue cyan) at: index))]].    (keyCode between: 7 and: 11) ifTrue:        [attribute _ TextEmphasis perform:                    (#(bold italic narrow underlined struckOut) at: keyCode - 6).        oldAttributes do:            [:att | (att dominates: attribute) ifTrue: [attribute turnOff]]].    (keyCode = 0) ifTrue:        [attribute _ TextEmphasis normal].    beginTypeInBlock ~~ nil        ifTrue:  "only change emphasisHere while typing"            [self insertTypeAhead: characterStream.            emphasisHere _ Text addAttribute: attribute toArray:                    oldAttributes.            ^ true].    self replaceSelectionWith: (self selection addAttribute: attribute).    ^ true! !!ParagraphEditor methodsFor: 'editing keys'!enclose: characterStream    "Insert or remove bracket characters around the current selection.     Flushes typeahead."    | char left right startIndex stopIndex oldSelection which text |    char _ sensor keyboard.    self closeTypeIn.    startIndex _ startBlock stringIndex.    stopIndex _ stopBlock stringIndex.    oldSelection _ self selection.    which _ '([<{"''' indexOf: char ifAbsent: [ ^true ].    left _ '([<{"''' at: which.    right _ ')]>}"''' at: which.    text _ paragraph text.    ((startIndex > 1 and: [stopIndex <= text size])        and:        [(text at: startIndex-1) = left and: [(text at: stopIndex) = right]])        ifTrue:            ["already enclosed; strip off brackets"            self selectFrom: startIndex-1 to: stopIndex.            self replaceSelectionWith: oldSelection]        ifFalse:            ["not enclosed; enclose by matching brackets"            self replaceSelectionWith:                (Text string: (String with: left), oldSelection string ,(String with: right)                    emphasis: emphasisHere).            self selectFrom: startIndex+1 to: stopIndex].    ^true! !!ParagraphEditor methodsFor: 'editing keys' stamp: 'sw 5/27/96'!offerFontMenu    "Present a menu of available fonts, and if one is chosen, apply it to the current selection.      Use only names of Fonts of this paragraph  "    | aList reply |    aList _ paragraph textStyle fontNames.    reply _ (SelectionMenu labelList: aList selections: aList) startUp.    reply ~~ nil ifTrue:        [self replaceSelectionWith:            (Text string: self selection asString                 attribute: (TextFontChange fontNumber: (aList indexOf: reply)))] ! !!ParagraphEditor methodsFor: 'editing keys'!shiftEnclose: characterStream    "Insert or remove bracket characters around the current selection.     Flushes typeahead."    | char left right startIndex stopIndex oldSelection which text |    char _ sensor keyboard.    char = $9 ifTrue: [ char _ $( ].    char = $, ifTrue: [ char _ $< ].    char = $[ ifTrue: [ char _ ${ ].    char = $' ifTrue: [ char _ $" ].    char asciiValue = 27 ifTrue: [ char _ ${ ].    "ctrl-["    self closeTypeIn.    startIndex _ startBlock stringIndex.    stopIndex _ stopBlock stringIndex.    oldSelection _ self selection.    which _ '([<{"''' indexOf: char ifAbsent: [1].    left _ '([<{"''' at: which.    right _ ')]>}"''' at: which.    text _ paragraph text.    ((startIndex > 1 and: [stopIndex <= text size])        and:        [(text at: startIndex-1) = left and: [(text at: stopIndex) = right]])        ifTrue:            ["already enclosed; strip off brackets"            self selectFrom: startIndex-1 to: stopIndex.            self replaceSelectionWith: oldSelection]        ifFalse:            ["not enclosed; enclose by matching brackets"            self replaceSelectionWith:                (Text string: (String with: left), oldSelection string ,(String with: right)                    emphasis: emphasisHere).            self selectFrom: startIndex+1 to: stopIndex].    ^true! !!ParagraphEditor methodsFor: 'editing keys' stamp: 'sw 1/18/96'!swapChars: characterStream     "Triggered byCmd-Y;.  Swap two characters, either those straddling the insertion point, or the two that comprise the selection.  Suggested by Ted Kaehler.  "    | currentSelection aString chars |    sensor keyboard.        "flush the triggering cmd-key character"    (chars _ self selection) size == 0        ifTrue:            [currentSelection _ startBlock stringIndex]        ifFalse:            [chars size == 2                ifFalse:                    [view flash.  ^ true]                ifTrue:                    [currentSelection _ startBlock stringIndex + 1]].    self selectFrom: currentSelection - 1 to: currentSelection.    aString _ self selection string.    self replaceSelectionWith: (Text fromString: aString reversed).    self selectAt: currentSelection + 1.    ^ true! !!ParagraphEditor methodsFor: 'typing/selecting keys'!crWithIndent: characterStream     "Replace the current text selection with CR followed by as many tabs    as on the current line (+/- bracket count) -- initiated by Shift-Return."    | char s i tabCount |    sensor keyboard.        "flush character"    s _ paragraph string.    i _ stopBlock stringIndex.    tabCount _ 0.    [(i _ i-1) > 0 and: [(char _ s at: i) ~= Character cr]]        whileTrue:  "Count tabs and brackets (but not a leading bracket)"        [(char = Character tab and: [(s at: i+1) ~= $[]) ifTrue: [tabCount _ tabCount + 1].        char = $[ ifTrue: [tabCount _ tabCount + 1].        char = $] ifTrue: [tabCount _ tabCount - 1]].    characterStream crtab: tabCount.  "Now inject CR with tabCount tabs"    ^ false! !!ParagraphEditor methodsFor: 'typing/selecting keys'!cursorDown: characterStream "Private - Move cursor from position in current line to same position innext line. If next line too short, put at end. If shift key down,select."    | shift string right left start position textSize|    shift := sensor leftShiftDown.    sensor keyboard.    string _ paragraph text string.    textSize _ string size.    left _ right _ stopBlock stringIndex.    [left > 1 and: [(string at: (left - 1)) ~= Character cr]] whileTrue:[left _ left - 1].    position _ stopBlock stringIndex - left.    [right < textSize and: [(string at: right) ~= Character cr]] whileTrue:[right _ right + 1].    right _ start _ right + 1.    [right < textSize and: [(string at: right) ~= Character cr]] whileTrue:[right _ right + 1].    shift        ifTrue:             [            start + position > right                ifTrue: [self selectFrom: startBlock stringIndex to: right - 1]                ifFalse: [self selectFrom: startBlock stringIndex to: start +position - 1]            ]        ifFalse:             [            start + position > right                ifTrue: [self selectFrom: right to: right - 1]                ifFalse: [self selectFrom: start + position to: start + position -1]            ].    ^true! !!ParagraphEditor methodsFor: 'typing/selecting keys'!cursorEnd: characterStream "Private - Move cursor end of current line. If cursor already at end ofline, put cursor at end of text"    | string right stringSize |    sensor keyboard.    string _ paragraph text string.    stringSize _ string size.    right _ stopBlock stringIndex.    [right <= stringSize and: [(string at: right) ~= Character cr]]whileTrue: [right _ right + 1].    stopBlock stringIndex == right        ifTrue: [self selectAt: string size + 1]        ifFalse: [self selectAt: right].    ^true! !!ParagraphEditor methodsFor: 'typing/selecting keys'!cursorHome: characterStream "Private - Move cursor from position in current line to beginning ofcurrent line. If cursor already at beginning of line, put cursor atbeginning of text"    | string left |    sensor keyboard.    string _ paragraph text string.    left _ startBlock stringIndex.    [left > 1 and: [(string at: (left - 1)) ~= Character cr]] whileTrue:[left _ left - 1].    startBlock stringIndex == left        ifTrue: [self selectAt: 1]        ifFalse: [self selectAt: left].    ^true! !!ParagraphEditor methodsFor: 'typing/selecting keys'!cursorLeft: characterStream "Private - Move cursor left one character if nothing selected, otherwisemove cursor to beginning of selection. If the shift key is down, startselecting or extending current selection. Don't allow cursor pastbeginning of text"    | shift |    shift := sensor leftShiftDown.    sensor keyboard.    shift        ifTrue:             [            startBlock stringIndex > 1                ifTrue: [self selectFrom: startBlock stringIndex - 1 to: stopBlockstringIndex - 1]            ]        ifFalse:             [            (startBlock stringIndex == stopBlock stringIndex and: [startBlockstringIndex > 1])                ifTrue: [self selectFrom: startBlock stringIndex - 1 to: startBlockstringIndex - 2]                ifFalse: [self selectFrom: startBlock stringIndex to: startBlockstringIndex - 1]            ].    ^true! !!ParagraphEditor methodsFor: 'typing/selecting keys'!cursorRight: characterStream "Private - Move cursor right one character if nothing selected,otherwise move cursor to end of selection. If the shift key is down,start selecting characters or extending already selected characters.Don't allow cursor past end of text"    | shift |    shift := sensor leftShiftDown.    sensor keyboard.    shift        ifTrue: [self selectFrom: startBlock stringIndex to: stopBlockstringIndex]        ifFalse:             [            startBlock stringIndex == stopBlock stringIndex                ifTrue: [self selectFrom: stopBlock stringIndex + 1 to: stopBlockstringIndex]                ifFalse: [self selectFrom: stopBlock stringIndex to: stopBlockstringIndex - 1]            ].    ^true! !!ParagraphEditor methodsFor: 'typing/selecting keys'!cursorUp: characterStream "Private - Move cursor from position in current line to same position inprior line. If prior line too short, put at end"    | shift string left position start |    shift := sensor leftShiftDown.    sensor keyboard.    string _ paragraph text string.    left _ startBlock stringIndex.    [left > 1 and: [(string at: (left - 1)) ~= Character cr]] whileTrue:[left _ left - 1].    position _ startBlock stringIndex - left.    start _ left.    left _ left - 1.    [left > 1 and: [(string at: (left - 1)) ~= Character cr]] whileTrue:[left _ left - 1].    left < 1 ifTrue: [left _ 1].    start = 1 ifTrue: [position _ 0].    shift        ifTrue:             [            (start - left < position and: [start > 1])                ifTrue: [self selectFrom: start - 1 to: stopBlock stringIndex - 1]                ifFalse: [self selectFrom: left + position to: stopBlock stringIndex- 1]            ]        ifFalse:             [            (start - left < position and: [start > 1])                ifTrue: [self selectFrom: start - 1 to: start - 2]                ifFalse: [self selectFrom: left + position to: left + position - 1]            ].    ^true! !!ParagraphEditor methodsFor: 'typing/selecting keys'!displayIfFalse: characterStream     "Replace the current text selection with the text 'ifFalse:'--initiated by     ctrl-f."    sensor keyboard.        "flush character"    characterStream nextPutAll: 'ifFalse:'.    ^false! !!ParagraphEditor methodsFor: 'typing/selecting keys'!displayIfTrue: characterStream     "Replace the current text selection with the text 'ifTrue:'--initiated by     ctrl-t."    sensor keyboard.        "flush character"    characterStream nextPutAll: 'ifTrue:'.    ^false! !!ParagraphEditor methodsFor: 'typing/selecting keys' stamp: 'tk 11/4/96'!forwardDelete: characterStream    "Delete forward over the next character.      Make Undo work on the whole type-in, not just the one char."    | startIndex usel upara uinterval ind |    startIndex _ startBlock stringIndex.    startIndex > paragraph text size ifTrue:        [sensor keyboard.        ^ false].    startIndex = stopBlock stringIndex ifFalse:        ["there was a selection"        "Just like regular Backspace -- delete the selection"        ^ self backspace: characterStream].    "Null selection - do the delete forward"    beginTypeInBlock == nil    "no previous typing.  openTypeIn"        ifTrue: [self openTypeIn. UndoSelection _ self nullText].    uinterval _ UndoInterval deepCopy.    "umes _ UndoMessage deepCopy.    Set already by openTypeIn"    "usel _ UndoSelection deepCopy."    upara _ UndoParagraph deepCopy.    sensor keyboard.    self selectFrom: startIndex to: startIndex.    self replaceSelectionWith: self nullText.    self selectFrom: startIndex to: startIndex-1.    UndoParagraph _ upara.  UndoInterval _ uinterval.    UndoMessage selector == #noUndoer ifTrue: [        (UndoSelection isText) ifTrue: [            usel _ UndoSelection.            ind _ startIndex. "UndoInterval startIndex"            usel replaceFrom: usel size + 1 to: usel size with:                (UndoParagraph text copyFrom: ind to: ind).            UndoParagraph text replaceFrom: ind to: ind with:self nullText]].    ^false! !!ParagraphEditor methodsFor: 'typing support'!dispatchOnCharacter: char with: typeAheadStream    "Carry out the action associated with this character, if any.    Type-ahead is passed so some routines can flush or use it."    "enter, backspace, and escape keys (ascii 3, 8, and 27) are command keys"    (sensor commandKeyPressed or: [self class specialShiftCmdKeys includes: char asciiValue]) ifTrue: [        sensor leftShiftDown ifTrue: [            ^ self perform: (ShiftCmdActions at: char asciiValue + 1) with: typeAheadStream.        ] ifFalse: [            ^ self perform: (CmdActions at: char asciiValue + 1) with: typeAheadStream.        ].    ].    "the control key can be used to invoke shift-cmd shortcuts"    sensor controlKeyPressed ifTrue: [        ^ self perform: (ShiftCmdActions at: char asciiValue + 1) with: typeAheadStream.    ].    ^ self perform: #normalCharacter: with: typeAheadStream! !!ParagraphEditor methodsFor: 'typing support'!setEmphasisHere    emphasisHere _ paragraph text attributesAt: (startBlock stringIndex-1 max: 1)! !!ParagraphEditor class methodsFor: 'class initialization' stamp: 'sw 6/18/96'!initialize    "Initialize the keyboard shortcut maps and the shared buffers    for copying text across views and managing again and undo.    : call initializeTextEditorMenus    other times: marked change to trigger reinit"     "ParagraphEditor initialize"    CurrentSelection _ UndoSelection _ FindText _ ChangeText _ Text new.    UndoMessage _ Message selector: #halt.    self initializeCmdKeyShortcuts.    self initializeShiftCmdKeyShortcuts.    self initializeTextEditorMenus! !!ParagraphEditor class methodsFor: 'keyboard shortcut tables'!initializeCmdKeyShortcuts    "Initialize the (unshifted) command-key shortcut table."    "ParagraphEditor initialize"    | cmdMap cmds |    cmdMap _ Array new: 256.  "use temp in case of a crash"    cmdMap atAllPut: #noop:.    cmdMap at: ( 1 + 1) put: #cursorHome:.            "home key"    cmdMap at: ( 4 + 1) put: #cursorEnd:.            "end key"    cmdMap at: ( 8 + 1) put: #backspace:.            "ctrl-H or delete key"    cmdMap at: (13 + 1) put: #crWithIndent:.            "cmd-Return"    cmdMap at: (27 + 1) put: #selectCurrentTypeIn:.    "escape key"    cmdMap at: (28 + 1) put: #cursorLeft:.            "left arrow key"    cmdMap at: (29 + 1) put: #cursorRight:.            "right arrow key"    cmdMap at: (30 + 1) put: #cursorUp:.                "up arrow key"    cmdMap at: (31 + 1) put: #cursorDown:.            "down arrow key"    '0123456789-=' do: [ :char | cmdMap at: (char asciiValue + 1) put: #changeEmphasis: ].    '([{''"<'         do: [ :char | cmdMap at: (char asciiValue + 1) put: #enclose: ].    cmdMap at: ($, asciiValue + 1) put: #shiftEnclose:.    cmds _ #(        $a    selectAll:        $b    browseIt:        $c    copySelection:        $d    doIt:        $e    exchange:        $f    find:        $g    findAgain:        $h    setSearchString:        $i    inspectIt:        $j    doAgainOnce:        $k  offerFontMenu:        $l    cancel:        $m    implementorsOfIt:        $n    sendersOfIt:        $o    spawnIt:        $p    printIt:        $q    querySymbol:        $r    recognizer:        $s    save:        $t    tempCommand:        $u    align:        $v    paste:        $w    backWord:        $x    cut:        $y    swapChars:        $z    undo:    ).    1 to: cmds size by: 2 do: [ :i |        cmdMap at: ((cmds at: i) asciiValue + 1) put: (cmds at: i + 1).    ].    CmdActions _ cmdMap.! !!ParagraphEditor class methodsFor: 'keyboard shortcut tables'!initializeShiftCmdKeyShortcuts    "Initialize the shift-command-key (or control-key) shortcut table."    | cmdMap cmds |    "shift-command and control shortcuts"    cmdMap _ Array new: 256.  "use temp in case of a crash"    cmdMap atAllPut: #noop:.    cmdMap at: ( 1 + 1) put: #cursorHome:.            "home key"    cmdMap at: ( 4 + 1) put: #cursorEnd:.            "end key"    cmdMap at: ( 8 + 1) put: #forwardDelete:.            "ctrl-H or delete key"    cmdMap at: (13 + 1) put: #crWithIndent:.            "ctrl-Return"    cmdMap at: (27 + 1) put: #selectCurrentTypeIn:.    "escape key"    cmdMap at: (28 + 1) put: #cursorLeft:.            "left arrow key"    cmdMap at: (29 + 1) put: #cursorRight:.            "right arrow key"    cmdMap at: (30 + 1) put: #cursorUp:.                "up arrow key"    cmdMap at: (31 + 1) put: #cursorDown:.            "down arrow key"    cmdMap at: (127 + 1) put: #forwardDelete:.                "del key"    "Note: Command key overrides shift key, so, for example, cmd-shift-9 produces $9 not $("    '9[,''' do: [ :char | cmdMap at: (char asciiValue + 1) put: #shiftEnclose: ].    "({< and double-quote"    "Note: Must use cmd-9 or ctrl-9 to get '()' since cmd-shift-9 is a Mac FKey command."    cmdMap at: (27 + 1) put: #shiftEnclose:.    "ctrl-["    cmds _ #(        $a    argAdvance:        $b    browseItHere:        $c    compareToClipboard:        $d    duplicate:        $f    displayIfFalse:        $j    doAgainMany:        $k    changeStyle:        $n    referencesToIt:        $r    indent:        $l    outdent:        $s    search:        $t    displayIfTrue:        $w    methodNamesContainingIt:        $v    pasteInitials:    ).    1 to: cmds size by: 2 do: [ :i |        cmdMap at: ((cmds at: i) asciiValue + 1)            put: (cmds at: i + 1).        cmdMap at: (((cmds at: i) asciiValue - 96) + 1)    put: (cmds at: i + 1).    ].    ShiftCmdActions _ cmdMap.! !!ParagraphEditor class methodsFor: 'keyboard shortcut tables'!specialShiftCmdKeys"Private - return array of key codes that represent single keys actingas if shift-command were also being pressed"^#(    1    "home"    3    "enter"    4    "end"    8    "backspace"    27    "escape"    28    "left arrow"    29    "right arrow"    30    "up arrow"    31    "down arrow"    127    "delete"    )! !!ParseNode methodsFor: 'testing'!isUndefTemp    ^ false! !!ParseNode methodsFor: 'testing'!isUnusedTemp    ^ false! !!ParseNode methodsFor: 'testing'!nowHasDef  "Ignored in all but VariableNode"! !!ParseNode methodsFor: 'testing'!nowHasRef  "Ignored in all but VariableNode"! !!ParseNode methodsFor: 'printing'!printCommentOn: aStream indent: indent     | thisComment |    comment == nil ifTrue: [^self].    "Show comments in green"    aStream withAttribute: (TextColor color: Color blue) do:     [1 to: comment size do:         [:index |         index > 1 ifTrue: [aStream crtab: indent].        aStream nextPut: $".        thisComment _ comment at: index.        self printSingleComment: thisComment            on: aStream            indent: indent.        aStream nextPut: $"]].    comment _ nil! !!ParseNode methodsFor: 'private'!printSingleComment: aString on: aStream indent: indent     "Print the comment string, assuming it has been indented indent tabs.       Break the string at word breaks, given the widths in the default font, at     450 points."    | readStream word position lineBreak font wordWidth tabWidth spaceWidth |    readStream _ ReadStream on: aString.    font _ TextStyle default defaultFont.    tabWidth _ TextConstants at: #DefaultTab.    spaceWidth _ font widthOf: Character space.    position _ indent * tabWidth.    lineBreak _ 450.    [readStream atEnd]        whileFalse:             [word _ self nextWordFrom: readStream setCharacter: [:lastChar | lastChar].            wordWidth _ 0.            word do: [:char | wordWidth _ wordWidth + (font widthOf: char)].            position _ position + wordWidth.            position > lineBreak                ifTrue:                     [aStream crtab: indent.                    position _ indent * tabWidth + wordWidth + spaceWidth.                    lastChar = Character cr                        ifTrue: [[readStream peekFor: Character tab] whileTrue].                    aStream nextPutAll: word; space]                ifFalse:                     [aStream nextPutAll: word.                    readStream atEnd                        ifFalse:                             [position _ position + spaceWidth.                            aStream space].                    lastChar = Character cr                        ifTrue:                             [aStream crtab: indent.                            position _ indent * tabWidth.                            [readStream peekFor: Character tab] whileTrue]]]! !!ParseNode class methodsFor: 'class initialization'!initialize    "ParseNode initialize. VariableNode initialize"    LdInstType _ 1.    LdTempType _ 2.    LdLitType _ 3.    LdLitIndType _ 4.    SendType _ 5.    CodeBases _ #(0 16 32 64 208 ).    CodeLimits _ #(16 16 32 32 16 ).    LdSelf _ 112.    LdTrue _ 113.    LdFalse _ 114.    LdNil _ 115.    LdMinus1 _ 116.    LoadLong _ 128.    Store _ 129.    StorePop _ 130.    ShortStoP _ 96.    SendLong _ 131.    DblExtDoAll _ 132.    SendLong2 _ 134.    LdSuper _ 133.    Pop _ 135.    Dup _ 136.    LdThisContext _ 137.    EndMethod _ 124.    EndRemote _ 125.    Jmp _ 144.    Bfp _ 152.    JmpLimit _ 8.    JmpLong _ 164.  "code for jmp 0"    BtpLong _ 168.    SendPlus _ 176.    Send _ 208.    SendLimit _ 16! !!Parser methodsFor: 'expression types'!assignment: varNode    " var '_' expression => AssignmentNode."    | loc |    (loc _ varNode assignmentCheck: encoder at: prevMark + requestorOffset) >= 0        ifTrue: [^self notify: 'Cannot store into' at: loc].    varNode nowHasDef.    self advance.    self expression ifFalse: [^self expected: 'Expression'].    parseNode _ AssignmentNode new                variable: varNode                value: parseNode                from: encoder.    ^true! !!Parser methodsFor: 'expression types'!blockExpression    " [ {:var} ( | statements) ] => BlockNode."    | argNodes |    argNodes _ OrderedCollection new.    [self match: #colon    "gather any arguments"]        whileTrue:             [argNodes addLast: (encoder autoBind: self argumentName)].    (argNodes size > 0 & (hereType ~~ #rightBracket) and: [(self match: #verticalBar) not])        ifTrue: [^self expected: 'Vertical bar'].    self statements: argNodes innerBlock: true.    (self match: #rightBracket)        ifFalse: [^self expected: 'Period or right bracket'].    argNodes do: [:arg | arg scope: -1] "Scope no longer active"! !!Parser methodsFor: 'expression types'!method: doit context: ctxt     " pattern [ | temporaries ] block => MethodNode."    | sap blk prim temps messageComment methodNode |    sap _ self pattern: doit inContext: ctxt.    "sap={selector, arguments, precedence}"    (sap at: 2) do: [:argNode | argNode isArg: true].    temps _ self temporaries.    messageComment _ currentComment.    currentComment _ nil.    prim _ doit ifTrue: [0] ifFalse: [self primitive].    self statements: #() innerBlock: doit.    blk _ parseNode.    doit ifTrue: [blk returnLast]        ifFalse: [blk returnSelfIfNoOther].    hereType == #doIt ifFalse: [^self expected: 'Nothing more'].    self interactive ifTrue: [self removeUnusedTemps].    methodNode _ MethodNode new comment: messageComment.    ^methodNode        selector: (sap at: 1)        arguments: (sap at: 2)        precedence: (sap at: 3)        temporaries: temps        block: blk        encoder: encoder        primitive: prim! !!Parser methodsFor: 'expression types'!pattern: fromDoit inContext: ctxt     " unarySelector | binarySelector arg | keyword arg {keyword arg} =>     {selector, arguments, precedence}."    | args selector |    fromDoit         ifTrue:             [ctxt == nil                ifTrue: [^Array with: #DoIt with: #() with: 1]                ifFalse: [^Array                             with: #DoItIn:                             with: (Array                                     with: (encoder encodeVariable: 'homeContext'))                                     with: 3]].    hereType == #word         ifTrue: [^Array with: self advance asSymbol with: #() with: 1].    (hereType == #binary or: [hereType == #verticalBar])        ifTrue:             [selector _ self advance asSymbol.            args _ Array with: (encoder bindArg: self argumentName).            ^Array with: selector with: args with: 2].    hereType == #keyword        ifTrue:             [selector _ WriteStream on: (String new: 32).            args _ OrderedCollection new.            [hereType == #keyword]                whileTrue:                     [selector nextPutAll: self advance.                    args addLast: (encoder bindArg: self argumentName)].            ^Array with: selector contents asSymbol with: args with: 3].    ^self expected: 'Message pattern'! !!Parser methodsFor: 'expression types'!primaryExpression     hereType == #word         ifTrue:             [parseNode _ self variable.            (parseNode isUndefTemp and: [self interactive])                ifTrue: [self queryUndefined].            parseNode nowHasRef.            ^ true].    hereType == #leftBracket        ifTrue:             [self advance.            self blockExpression.            ^true].    hereType == #leftBrace        ifTrue:             [self braceExpression.            ^true].    hereType == #leftParenthesis        ifTrue:             [self advance.            self expression ifFalse: [^self expected: 'expression'].            (self match: #rightParenthesis)                ifFalse: [^self expected: 'right parenthesis'].            ^true].    (hereType == #string or: [hereType == #number or: [hereType == #literal]])        ifTrue:             [parseNode _ encoder encodeLiteral: self advance.            ^true].    (here == #- and: [tokenType == #number])        ifTrue:             [self advance.            parseNode _ encoder encodeLiteral: self advance negated.            ^true].    ^false! !!Parser methodsFor: 'temps'!bindArg: name    ^ self bindTemp: name! !!Parser methodsFor: 'error correction'!correctSelector: proposedKeyword wordIntervals: spots exprInterval: expInt ifAbort: abortAction fullSearch: tryHard     "Correct the proposedKeyword to some selector symbol, correcting the original text if such action is indicated.  abortAction is invoked if the proposedKeyword couldn't be converted into a valid selector.  Spots is an ordered collection of intervals within the test stream of the for each of the keyword parts."    | alternatives aStream choice correctSelector userSelection lines firstLine |    "If we can't ask the user, assume that the keyword will be defined later"    self interactive ifFalse: [ ^ proposedKeyword asSymbol ].    userSelection _ requestor selectionInterval.    requestor selectFrom: spots first first to: spots last last.    requestor select.    alternatives _ tryHard        ifFalse: [ Symbol possibleSelectorsFor: proposedKeyword ]        ifTrue: [ Symbol morePossibleSelectorsFor: proposedKeyword ].    aStream _ WriteStream on: (String new: 200).    aStream nextPutAll: (proposedKeyword contractTo: 35); cr.    firstLine _ 1.     alternatives do:        [:sel | aStream nextPutAll: (sel contractTo: 35); nextPut: Character cr].    aStream nextPutAll: 'cancel'.    lines _ Array with: firstLine with: (alternatives size + firstLine).    tryHard ifFalse:        [aStream cr; nextPutAll: 'try harder'.        lines _ lines copyWith: (alternatives size + firstLine + 1)].        choice _ (PopUpMenu labels: aStream contents lines: lines)        startUpWithCaption: 'Unknown selector, please confirm, correct, or cancel'.    tryHard not & (choice > lines last) ifTrue:        [^ self correctSelector: proposedKeyword wordIntervals: spots                exprInterval: expInt ifAbort: abortAction fullSearch: true ].     (choice = 0) | (choice > (lines at: 2))        ifTrue: [ ^ abortAction value ].    requestor deselect.    requestor selectInvisiblyFrom: userSelection first to: userSelection last.    choice = 1 ifTrue: [ ^ proposedKeyword asSymbol ].    correctSelector _ alternatives at: choice - 1.    self substituteSelector: correctSelector keywords wordIntervals: spots.    ^ correctSelector.! !!Parser methodsFor: 'error correction'!queryUndefined    | varStart varName |     varName _ parseNode key.    varStart _ self endOfLastToken + requestorOffset - varName size + 1.    requestor selectFrom: varStart to: varStart + varName size - 1; select.    ((PopUpMenu labels:'yesno') startUpWithCaption:        ((varName , ' appears to beundefined at this point.Proceed anyway?') asText makeBoldFrom: 1 to: varName size))        = 1 ifFalse: [^ self fail]! !!Parser methodsFor: 'error correction'!removeUnusedTemps     | str end start |     str _ requestor text string.    ((tempsMark between: 1 and: str size)        and: [(str at: tempsMark) = $|]) ifFalse: [^ self].    encoder unusedTempNames do:        [:temp |        ((PopUpMenu labels: 'yes\no' withCRs) startUpWithCaption:            ((temp , ' appears to beunused in this method.OK to remove it?') asText makeBoldFrom: 1 to: temp size))            = 1        ifTrue:        [(encoder encodeVariable: temp) isUndefTemp            ifTrue:            [end _ tempsMark.            ["Beginning at right temp marker..."            start _ end - temp size + 1.            end < temp size or: [temp = (str copyFrom: start to: end)                                and: [(str at: start-1) isSeparator]]]            whileFalse:                ["Search left for the unused temp"                end _ requestor nextTokenFrom: end direction: -1].            end < temp size ifFalse:                [(str at: start-1) = $  ifTrue: [start _ start-1].                requestor correctFrom: start to: end with: ''.                str _ str copyReplaceFrom: start to: end with: ''.                 tempsMark _ tempsMark - (end-start+1)]]            ifFalse:            [PopUpMenu notify:'You''ll first have to remove thestatement where it''s stored into']]]! !!PartsBinMorph methodsFor: 'menu'!addCustomMenuItems: aCustomMenu hand: aHandMorph    super addCustomMenuItems: aCustomMenu hand: aHandMorph.    aCustomMenu addLine.    aCustomMenu add: 'lock' action: #lock.    aCustomMenu add: 'unlock' action: #unlock.! !!PartsBinMorph methodsFor: 'menu'!lock    openToDragNDrop _ false.! !!PartsBinMorph methodsFor: 'menu'!unlock    openToDragNDrop _ true.! !!PartsBinMorph methodsFor: 'extraction support'!rootForGrabOf: aMorph    "If open to drag-n-drop, allow submorph to be extracted. Otherwise, copy the submorph."    | root |    root _ aMorph.    [root = self] whileFalse: [        root owner = self ifTrue: [            openToDragNDrop                ifTrue: [^ root]                ifFalse: [^ root fullCopy]].        root _ root owner].    ^ super rootForGrabOf: aMorph! !!Pen methodsFor: 'initialize-release'!defaultNib: widthInteger     "Nib is the tip of a pen. This sets up the pen, with a nib of width    widthInteger. Alternatively, try        roundNib: widthInteger, or        sourceForm: aForm    to set the shape of the tip. For example, try:        | bic | bic _ Pen new sourceForm: Cursor normal.        bic combinationRule: Form paint; turn: 90.        10 timesRepeat: [bic down; go: 10; up; go: 20]."    self color: Color black.    self squareNib: widthInteger! !!Pen methodsFor: 'coloring'!black    "Set the receiver's mask to black."    self fillColor: Color black.! !!Pen methodsFor: 'coloring' stamp: 'tk 6/18/96'!color: colorSpec    "Set the pen to the Nth color (wraps), or to an explicit color.  "    colorSpec isInteger        ifTrue: [destForm depth=1 ifTrue: [^ self fillColor: Color black].                "spread colors out in randomish fashion"                self fillColor: (Colors atWrap: colorSpec*9)]        ifFalse: [self fillColor: colorSpec].    "arg must be a color already"! !!Pen methodsFor: 'coloring'!white     "Set the receiver's mask to white."    self fillColor: Color white.! !!Pen methodsFor: 'moving' stamp: 'tk 2/17/97'!goDelta: aPoint     "Move the receiver by the relative amount in aPoint. If the pen is down, a line will be     drawn from the current position to the new one using the receiver's     form source as the shape of the drawing brush. The receiver's set     direction does not change.  "    | old |    old _ location.    location _ location + aPoint.    penDown ifTrue: [self drawFrom: old to: location]! !!Pen methodsFor: 'moving' stamp: 'di 9/20/97 22:54'!goto: aPoint     "Move the receiver to position aPoint. If the pen is down, a line will be     drawn from the current position to the new one using the receiver's     form source as the shape of the drawing brush. The receiver's set     direction does not change."    | old |    old _ location.    location _ aPoint.    penDown ifTrue: [self drawFrom: old rounded                                to: location rounded]    "NOTE:  This should be changed so it does NOT draw the first point, so as    not to overstrike at line junctions.  At the same time, place should draw    a single dot if the pen is down, as should down (put-pen-down) if it    was not down before."! !!Pen methodsFor: 'geometric designs'!mandala: npoints    "Display restoreAfter: [Pen new mandala: 30]"    "On a circle of diameter d, place npoints number of points. Draw all     possible connecting lines between the circumferential points."    | l points d |    Display fillWhite.    d _ Display height-50.    l _ 3.14 * d / npoints.    self home; up; turn: -90; go: d // 2; turn: 90; go: 0 - l / 2; down.    points _ Array new: npoints.    1 to: npoints do:         [:i |         points at: i put: location rounded.        self go: l; turn: 360.0 / npoints].    npoints // 2        to: 1        by: -1        do:             [:i |             self color: i.            1 to: npoints do:                 [:j |                 self place: (points at: j).                self goto: (points at: j + i - 1 \\ npoints + 1)]]! !!Pen methodsFor: 'geometric designs' stamp: 'di 9/20/97 23:55'!web   "Display restoreAfter: [Pen new web]"    "Draw pretty web-like patterns from the mouse movement on the screen.    Press the mouse button to draw, option-click to exit.    By Dan Ingalls and Mark Lentczner. "    | history newPoint ancientPoint lastPoint filter color |    "self erase."    color _ 1.    [ true ] whileTrue:        [ history _ OrderedCollection new.        Sensor waitButton.        Sensor yellowButtonPressed ifTrue: [^ self].        filter _ lastPoint _ Sensor mousePoint.        20 timesRepeat: [ history addLast: lastPoint ].        self color: (color _ color + 1).        [ Sensor redButtonPressed ] whileTrue:             [ newPoint _ Sensor mousePoint.            (newPoint = lastPoint) ifFalse:                [ ancientPoint _ history removeFirst.                filter _ filter * 4 + newPoint // 5.                self place: filter.                self goto: ancientPoint.                lastPoint _ newPoint.                history addLast: filter ] ] ]! !!PlayWithMe1 methodsFor: 'public access'!slider1Value: x    valuePrinter contents: x printString.    scrollBar1 value: x! !!PlayWithMe1 methodsFor: 'input events'!listPane1MenuButtonPressed: arg1    self confirm: 'Do you like menu buttons?'! !!PlayWithMe1 methodsFor: 'input events'!listPane1NewSelection: arg1    valuePrinter contents: arg1.    listPane2 selection: arg1! !!PlayWithMe1 methodsFor: 'input events'!listPane2MenuButtonPressed: arg1    self confirm: 'Do you like menu buttons?'! !!PlayWithMe1 methodsFor: 'input events'!listPane2NewSelection: arg1    valuePrinter contents: arg1.    listPane1 selection: arg1! !!PlayWithMe1 methodsFor: 'input events'!scrollBar1MenuButtonPressed: arg1    self confirm: 'Do you like menu buttons?'! !!PlayWithMe1 methodsFor: 'input events'!scrollBar1Value: arg1    valuePrinter contents: arg1 printString.    slider1 value: arg1! !!PlayWithMe1 class methodsFor: 'instance creation' stamp: 'di 6/22/97 09:14'!includeInNewMorphMenu    "Not to be instantiated from the menu"    ^ false! !!PlayWithMe3 methodsFor: 'public access' stamp: '6/6/97 16:12 di'!codeBrowser1    ^codeBrowser1! !!PlayWithMe3 methodsFor: 'public access'!slantedList1    ^slantedList1! !!PlayWithMe3 class methodsFor: 'instance creation' stamp: 'di 6/22/97 09:14'!includeInNewMorphMenu    "Not to be instantiated from the menu"    ^ false! !!PluckedSound methodsFor: 'initialization' stamp: 'jm 9/17/97 13:05'!setPitch: p dur: d loudness: l    amplitude _ l rounded.    ring _ SoundBuffer newMonoSampleCount:        (((2.0 * self samplingRate asFloat) / p asFloat) asInteger max: 2).    ringSize _ ring size.    initialCount _ (d * self samplingRate asFloat) asInteger.    self reset.! !!PluckedSound methodsFor: 'sound generation'!mixSampleCount: n into: aSoundBuffer startingAt: startIndex pan: pan    "The Karplus-Strong plucked string algorithm: start with a buffer full of random noise and repeatedly play the contents of that buffer while averaging adjacent samples. High harmonics damp out more quickly, transfering their energy to lower ones. The length of the buffer corresponds to the length of the string. It may be out of tune for higher pitches because the buffer length must be an integral number of samples and the nearest integer may not result in the exact pitch desired."    "(PluckedSound pitch: 220.0 dur: 3.0 loudness: 1000) play"    | lastIndex thisIndex nextIndex mySample channelIndex sample |    <primitive: 178>    self var: #aSoundBuffer declareC: 'short int *aSoundBuffer'.    self var: #ring declareC: 'short int *ring'.    lastIndex _ (startIndex + n) - 1.    thisIndex _ ringIndx.    startIndex to: lastIndex do: [ :i |        nextIndex _ (thisIndex \\ ringSize) + 1.        mySample _ ((ring at: thisIndex) + (ring at: nextIndex)) // 2.        ring at: thisIndex put: mySample.        thisIndex _ nextIndex.        pan > 0 ifTrue: [            channelIndex _ 2 * i.            sample _ (aSoundBuffer at: channelIndex) + ((mySample * pan) // 1000).            sample >  32767 ifTrue: [ sample _  32767 ].  "clipping!!"            sample < -32767 ifTrue: [ sample _ -32767 ].  "clipping!!"            aSoundBuffer at: channelIndex put: sample.        ].        pan < 1000 ifTrue: [            channelIndex _ (2 * i) - 1.            sample _ (aSoundBuffer at: channelIndex) + ((mySample * (1000 - pan)) // 1000).            sample >  32767 ifTrue: [ sample _  32767 ].  "clipping!!"            sample < -32767 ifTrue: [ sample _ -32767 ].  "clipping!!"            aSoundBuffer at: channelIndex put: sample.        ].    ].    ringIndx _ nextIndex.    count _ count - n.! !!PluckedSound methodsFor: 'copying' stamp: 'jm 10/4/97 16:46'!copy    ^ self clone copyRing! !!PluckedSound methodsFor: 'copying' stamp: 'jm 10/4/97 16:47'!copyRing    "Private!! Support for copying"    ring _ ring copy.! !!PluggableListController methodsFor: 'all'!changeModelSelection: anInteger    "Let the view handle this."    view changeModelSelection: anInteger.! !!PluggableListController methodsFor: 'all'!controlActivity    "Overridden to handle keystrokes."    sensor keyboardPressed ifTrue: [view handleKeystroke: sensor keyboard].    super controlActivity.! !!PluggableListController methodsFor: 'all'!yellowButtonActivity    "Invoke the model's menu."    | menu |    menu _ view getMenu.    menu == nil ifFalse: [menu invokeOn: model].! !!PluggableListView methodsFor: 'initialization'!list: arrayOfStrings    "Set the receivers items to be the given list of strings."    "Note: the instance variable 'itemsList' holds the original list.     The instance variable 'items' is a paragraph constructed from     this list."    | s |    items _ arrayOfStrings.    isEmpty _ arrayOfStrings isEmpty.    s _ WriteStream on: Array new.    "add top and bottom delimiters"    s nextPut: topDelimiter.    arrayOfStrings do: [:item |        item == nil ifFalse: [s nextPut: item].    ].    s nextPut: bottomDelimiter.    list _ ListParagraph withArray: s contents.    selection _ self getCurrentSelectionIndex.    self positionList.! !!PluggableListView methodsFor: 'initialization'!on: anObject list: getListSel selected: getSelectionSel changeSelected: setSelectionSel menu: getMenuSel keystroke: keyActionSel    self model: anObject.    getListSelector _ getListSel.    getSelectionSelector _ getSelectionSel.    setSelectionSelector _ setSelectionSel.    getMenuSelector _ getMenuSel.    keystrokeActionSelector _ keyActionSel.    self borderWidth: 1.    self list: self getList.! !!PluggableListView methodsFor: 'model access'!changeModelSelection: anInteger    "Change the model's selected item to be the one at the given index."    | item |    setSelectionSelector ~~ nil ifTrue: [        item _ (anInteger = 0 ifTrue: [nil] ifFalse: [items at: anInteger]).        model perform: setSelectionSelector with: item.        getSelectionSelector == nil ifFalse: [model perform: getSelectionSelector].    ].! !!PluggableListView methodsFor: 'model access'!getCurrentSelectionIndex    "Answer the index of the current selection."    | item |    getSelectionSelector == nil ifTrue: [^ 0].    item _ model perform: getSelectionSelector.    ^ items findFirst: [ :x | x = item]! !!PluggableListView methodsFor: 'model access'!getList     "Answer the list to be displayed."    | lst |    getListSelector == nil ifTrue: [^ #()].    lst _ model perform: getListSelector.    lst == nil ifTrue: [^ #()].    ^ lst! !!PluggableListView methodsFor: 'model access'!getMenu    "Answer the menu for this list view."    getMenuSelector == nil ifTrue: [^ nil].    ^ model perform: getMenuSelector! !!PluggableListView methodsFor: 'model access'!handleKeystroke: aCharacter    "Answer the menu for this list view."    keystrokeActionSelector == nil ifTrue: [^ nil].    model perform: keystrokeActionSelector with: aCharacter.! !!PluggableListView methodsFor: 'controller access'!defaultControllerClass     ^ PluggableListController! !!PluggableListView methodsFor: 'updating'!update: aSymbol     "Refer to the comment in View|update:."    | oldIndex newIndex |    aSymbol == getListSelector ifTrue: [        oldIndex _ self getCurrentSelectionIndex.        self list: self getList.        newIndex _ self getCurrentSelectionIndex.        (oldIndex > 0 and: [newIndex = 0]) ifTrue: [            "new list did not include the old selection; deselecting"            self changeModelSelection: newIndex].        self displayView.        self displaySelectionBox.        ^self].    aSymbol == getSelectionSelector ifTrue: [        self moveSelectionBox: self getCurrentSelectionIndex.        ^self].! !!PluggableListView class methodsFor: 'as yet unclassified'!aboutPluggability    "A pluggable list view gets its content from the model. This allows the same kind of view can be used in different situations, thus avoiding a proliferation of gratuitous view and controller classes. Selector usage is:        getListSel        fetch the list of items (strings) to be displayed        getSelectionSel    get the currently selected item        setSelectionSel    set the currently selected item (takes an argument)        getMenuSel        get the pane-specific (or 'yellow-button') menu        keyActionSel    process keystrokes typed to this view (takes an argument)    Any of the above selectors can be nil, meaning that the model does not supply behavior for the given action, and the default, do-nothing behavior should be used. However, if getListSel is nil, the default behavior just provides an empty list, which makes for a rather dull list view!! (Such behavior can actually be useful during debugging.)    The model informs a pluggable view of changes by sending #changed: to itself with getListSel or getSelectionSel as a parameter. The view informs the model of selection changes by sending setSelectionSel to it with the newly selected item as a parameter, and invokes menu and keyboard actions on the model via getMenuSel and keyActionSel.    Pluggability allows a single model object to have pluggable list views on multiple aspects of itself. For example, an object representing one personal music library might be organized as a three-level hierarchy: the types of music, the titles within a given type, and the songs on a given title. Pluggability allows one to easily build a multipane browser for this object with separate list views for the music type, title, and song."! !!PluggableListView class methodsFor: 'as yet unclassified'!on: anObject list: getListSel selected: getSelectionSel changeSelected: setSelectionSel    "Create a 'pluggable' list view on the given model parameterized by the given message selectors. See aboutPluggability comment."    ^ self new        on: anObject        list: getListSel        selected: getSelectionSel        changeSelected: setSelectionSel        menu: nil        keystroke: nil! !!PluggableListView class methodsFor: 'as yet unclassified'!on: anObject list: getListSel selected: getSelectionSel changeSelected: setSelectionSel menu: getMenuSel    "Create a 'pluggable' list view on the given model parameterized by the given message selectors. See aboutPluggability comment."    ^ self new        on: anObject        list: getListSel        selected: getSelectionSel        changeSelected: setSelectionSel        menu: getMenuSel        keystroke: nil! !!PluggableListView class methodsFor: 'as yet unclassified'!on: anObject list: getListSel selected: getSelectionSel changeSelected: setSelectionSel menu: getMenuSel keystroke: keyActionSel    "Create a 'pluggable' list view on the given model parameterized by the given message selectors. See aboutPluggability comment."    ^ self new        on: anObject        list: getListSel        selected: getSelectionSel        changeSelected: setSelectionSel        menu: getMenuSel        keystroke: keyActionSel! !!PluggableTest methodsFor: 'initialization'!initialize    list1 _ #('reggae' 'early' 'classical').    list2 _ #('marley' 'alpha blondy' 'burning spear' 'ziggy').! !!PluggableTest methodsFor: 'artist pane'!artist    ^ selection2! !!PluggableTest methodsFor: 'artist pane'!artist: aString    selection2 _ aString.    self changed: #artist.! !!PluggableTest methodsFor: 'artist pane'!artistKeystroke: aCharacter    list2 do: [ :artist |        (artist first asLowercase = aCharacter asLowercase) ifTrue: [            self artist: artist]].! !!PluggableTest methodsFor: 'artist pane'!artists    selection1 = 'reggae' ifTrue: [^ list2].    selection1 = 'early' ifFalse: [^ #('ziggy' 'marley')].    ^ #()! !!PluggableTest methodsFor: 'music type pane'!musicType    ^ selection1! !!PluggableTest methodsFor: 'music type pane'!musicType: aString    selection1 _ aString.    self changed: #musicType.    self changed: #artists.! !!PluggableTest methodsFor: 'music type pane'!musicTypeKeystroke: aCharacter    list1 do: [ :type |        (type first asLowercase = aCharacter asLowercase) ifTrue: [            self musicType: type]].! !!PluggableTest methodsFor: 'music type pane'!musicTypeMenu    ^ SelectionMenu        labels: 'reggae\grunge\flash' withCRs        lines: #(2)        selections: #(reggaeCmd grungeCmd flashCmd)! !!PluggableTest methodsFor: 'music type pane'!musicTypes    ^ list1! !!PluggableTest methodsFor: 'menu commands'!flashCmd    Display reverse; reverse.! !!PluggableTest methodsFor: 'menu commands'!grungeCmd    SelectionMenu confirm:        'You mean, like those strange bands from Seattle?'! !!PluggableTest methodsFor: 'menu commands'!reggaeCmd    self musicType: 'reggae'.! !!PluggableTest class methodsFor: 'as yet unclassified'!open    "PluggableTest open"    | model listView1 topView listView2 |    model _ self new initialize.    listView1 _        PluggableListView on: model            list: #musicTypes            selected: #musicType            changeSelected: #musicType:            menu: #musicTypeMenu            keystroke: #musicTypeKeystroke:.    listView2 _        PluggableListView on: model            list: #artists            selected: #artist            changeSelected: #artist:            menu: nil            keystroke: #artistKeystroke:.    topView _ StandardSystemView new        label: 'Pluggable Test';        minimumSize: 300@200;        borderWidth: 1;        addSubView: listView1;        addSubView: listView2 toRightOf: listView1.    topView controller open.! !!Point methodsFor: 'arithmetic'!\\ scale     "Answer a Point that is the mod of the receiver and scale (which is a  Point or Number)."    | scalePoint |    scalePoint _ scale asPoint.    ^ x \\ scalePoint x @ (y \\ scalePoint y)! !!Point methodsFor: 'polar coordinates' stamp: 'di 6/12/97 12:18'!degrees    "Answer the angle the receiver makes with origin in degrees. right is 0; down is 90."    | tan theta |    x = 0        ifTrue: [y >= 0                ifTrue: [^ 90.0]                ifFalse: [^ 270.0]]        ifFalse:             [tan _ y asFloat / x asFloat.            theta _ tan arcTan.            x >= 0                ifTrue: [y >= 0                        ifTrue: [^ theta radiansToDegrees]                        ifFalse: [^ 360.0 + theta radiansToDegrees]]                ifFalse: [^ 180.0 + theta radiansToDegrees]]! !!Point methodsFor: 'point functions' stamp: 'di 6/11/97 16:08'!flipBy: direction centerAt: c    "Answer a Point which is flipped according to the direction about the point c.    Direction must be #vertical or #horizontal."    direction == #vertical ifTrue: [^ x @ (c y * 2 - y)].    direction == #horizontal ifTrue: [^ (c x * 2 - x) @ y].    self error: 'unrecognizable direction'! !!Point methodsFor: 'point functions' stamp: 'di 6/25/97 22:28'!isRectilinear: aPoint    "Answer true if a line between self and aPoint is either vertical or horizontal"    ^ (x = aPoint x) | (y = aPoint y)! !!Point methodsFor: 'point functions' stamp: 'di 6/25/97 22:49'!onLineFrom: p1 to: p2    "Answer true if the receiver is on the line between p1 and p2 within a small epsilon."    | eps |  eps _ 2.    "test if receiver is within the bounding box"    (((p1 rect: p2) expandBy: eps) containsPoint: self) ifFalse: [^ false].    "its in the box, is it on the line?"    ^ (self farFrom: (self nearestPointAlongLineFrom: p1 to: p2) by: eps) not! !!Point methodsFor: 'point functions' stamp: 'di 9/20/97 22:04'!onLineFrom: p1 to: p2 width: width    "Answer true if the receiver is on the line between p1 and p2 within a small epsilon plus half the line width."    | eps |  eps _ 2 + (width+1 //2).    "test if receiver is within the bounding box"    (((p1 rect: p2) expandBy: eps) containsPoint: self) ifFalse: [^ false].    "its in the box, is it on the line?"    ^ (self farFrom: (self nearestPointAlongLineFrom: p1 to: p2) by: eps) not! !!Point methodsFor: 'point functions' stamp: '6/9/97 14:51 di'!quadrantOf: otherPoint    "Return 1..4 indicating relative direction to otherPoint.    1 is downRight, 2=downLeft, 3=upLeft, 4=upRight"    ^ x <= otherPoint x        ifTrue: [y < otherPoint y ifTrue: [1] ifFalse: [4]]        ifFalse: [y <= otherPoint y ifTrue: [2] ifFalse: [3]]"[Sensor anyButtonPressed] whileFalse:    [(Display boundingBox center quadrantOf: Sensor cursorPoint) printString displayAt: 0@0]"! !!Point methodsFor: 'point functions' stamp: 'di 6/11/97 15:12'!rotateBy: direction centerAt: c    "Answer a Point which is rotated according to direction, about the point c.    Direction must be one of #right (CW), #left (CCW) or #pi (180 degrees)."    | offset |    offset _ self - c.    direction == #right ifTrue: [^ (offset y negated @ offset x) + c].    direction == #left ifTrue: [^ (offset y @ offset x negated) + c].    direction == #pi ifTrue: [^ c - offset].    self error: 'unrecognizable direction'! !!Point methodsFor: 'converting'!asFloatPoint    ^ x asFloat @ y asFloat! !!Point methodsFor: 'converting' stamp: '6/6/97 14:32 di'!rect: aPoint     "Answer a Rectangle that encompasses the receiver and aPoint.    This is the most general infix way to create a rectangle."    ^ (self corner: self) encompass: aPoint! !!Point methodsFor: 'transforming'!adhereTo: aRectangle    "If the receiver lies outside aRectangle, return the nearest point on the boundary of the rectangle, otherwise return self."    (aRectangle containsPoint: self)    ifTrue: [^ self]    ifFalse: [^ (x min: (aRectangle corner x) max: (aRectangle origin x))            @ (y min: (aRectangle corner y) max: (aRectangle origin y))]! !!Point methodsFor: 'transforming'!rotateBy: angle about: center    "Even though Point.theta is measured CW, this rotates with the more conventional CCW interpretateion of angle."    | p r theta |    p _ self - center.    r _ p r.    theta _ angle asFloat - p theta.    ^ (center x asFloat + (r * theta cos)) @      (center y asFloat - (r * theta sin))! !!Point methodsFor: 'transforming'!scaleFrom: rect1 to: rect2    "Produce a point stretched according to the stretch from rect1 to rect2"    ^ rect2 topLeft + (((x-rect1 left) * rect2 width / rect1 width)                    @ ((y-rect1 top) * rect2 height / rect1 height))! !!Point methodsFor: 'private'!setR: rho degrees: theta    | radians |    radians _ theta asFloat degreesToRadians.    x _ (rho asFloat * radians cos) asInteger.    y _ (rho asFloat * radians sin) asInteger.! !!Point class methodsFor: 'instance creation'!r: rho degrees: theta    "Answer an instance of me with polar coordinates rho and theta."    ^self new setR: rho degrees: theta! !!Polygon methodsFor: 'initialization' stamp: 'jm 8/2/97 14:21'!initialize    super initialize.    vertices _ Array with: 20@20 with: 40@30 with: 20@40.    color _ Color orange.    borderWidth _ 2.    borderColor _ Color magenta.    closed _ true.    quickFill _ true.    arrows _ #none.    self computeBounds.! !!Polygon methodsFor: 'initialization' stamp: 'di 9/26/97 10:05'!installModelIn: aWorld    aWorld isWorldMorph ifTrue: [self addHandles]! !!Polygon methodsFor: 'initialization' stamp: 'di 9/26/97 09:03'!vertices: verts color: c borderWidth: bw borderColor: bc    super initialize.    vertices _ verts.    color _ c.    borderWidth _ bw.    borderColor _ bc.    closed _ true.    quickFill _ true.    arrows _ #none.    self computeBounds.! !!Polygon methodsFor: 'access' stamp: 'di 6/13/97 07:22'!borderColor: colorOrNil    borderColor _ colorOrNil.    self changed! !!Polygon methodsFor: 'access' stamp: '6/8/97 15:43 di'!borderWidth: anInteger    borderColor ifNil: [borderColor _ Color black].    borderWidth _ anInteger.    self computeBounds! !!Polygon methodsFor: 'access' stamp: '6/9/97 13:22 di'!makeClosed    closed _ true.    self computeBounds! !!Polygon methodsFor: 'access' stamp: '6/9/97 13:22 di'!makeOpen    closed _ false.    self computeBounds! !!Polygon methodsFor: 'access' stamp: 'sw 9/14/97 18:22'!vertices    ^ vertices! !!Polygon methodsFor: 'geometry' stamp: 'tk 9/8/97 10:41'!containsPoint: aPoint    (super containsPoint: aPoint) ifFalse: [^ false].    closed    ifTrue: [filledForm colors: (Array with: Color white with: Colorblack).        ^ (filledForm pixelValueAt: aPoint - bounds topLeft) = 1]    ifFalse: [        self lineSegmentsDo:            [:p1 :p2 | (aPoint onLineFrom: p1 to: p2) ifTrue:[^ true]].        arrowForms ifNotNil: [arrowForms do:            [:f | (f pixelValueAt: aPoint - f offset) > 0ifTrue: [^ true]]].        ^ false]! !!Polygon methodsFor: 'geometry' stamp: 'sw 9/14/97 18:22'!flipHAroundX: centerX    "Flip me horizontally around the center.  If centerX is nil, compute my center of gravity."    | cent |    cent _ centerX         ifNil: [bounds center x            "cent _ 0.            vertices do: [:each | cent _ cent + each x].            cent asFloat / vertices size"]        "average is the center"        ifNotNil: [centerX].    self setVertices: (vertices collect: [:vv |            (vv x - cent) * -1 + cent @ vv y]) reversed.! !!Polygon methodsFor: 'geometry' stamp: 'sw 9/14/97 18:22'!flipVAroundY: centerY    "Flip me vertically around the center.  If centerY is nil, compute my center of gravity."    | cent |    cent _ centerY         ifNil: [bounds center y            "cent _ 0.            vertices do: [:each | cent _ cent + each y].            cent asFloat / vertices size"]        "average is the center"        ifNotNil: [centerY].    self setVertices: (vertices collect: [:vv |            vv x @ ((vv y - cent) * -1 + cent)]) reversed.! !!Polygon methodsFor: 'geometry' stamp: 'sw 9/14/97 18:22'!inset: amt    "Only works if I am made of rectangles (every segment of me is horizontal or vertical).  Inset each vertex by amt.  Uses containsPoint."    | delta four cnt offset |    delta _ amt asPoint.    four _ {delta.  -1@1 * delta.  -1@-1 * delta.  1@-1 * delta}.    self setVertices: (vertices collect: [:vv |         cnt _ 0.        offset _ four detectSum: [:del |             (self containsPoint: del+vv) ifTrue: [cnt _ cnt + 1. del] ifFalse: [0@0]].        cnt = 2 ifTrue: [offset _ offset // 2].        vv + offset]).! !!Polygon methodsFor: 'geometry' stamp: 'sw 9/14/97 18:22'!merge: aPolygon    "Expand myself to enclose the other polygon.  (Later merge overlapping or disjoint in a smart way.)  For now, the two polygons must share at least two vertices.  Shared vertices must come one after the other in each polygon.  Polygons must not overlap."    | shared mv vv hv xx |    shared _ vertices select: [:mine |         (aPolygon vertices includes: mine)].    shared size < 2 ifTrue: [^ nil].    "not sharing a segment"    mv _ vertices asOrderedCollection.    [shared includes: mv first] whileFalse: ["rotate them"        vv _ mv removeFirst.        mv addLast: vv].    hv _ aPolygon vertices asOrderedCollection.    [mv first = hv first] whileFalse: ["rotate him until same shared vertex is first"        vv _ hv removeFirst.        hv addLast: vv].    [shared size > 2] whileTrue: [        shared _ shared asOrderedCollection.        (self mergeDropThird: mv in: hv from: shared) ifNil: [^ nil]].        "works by side effect on the lists"    (mv at: 2) = hv last ifTrue: [mv removeFirst; removeFirst.        ^ self setVertices: (hv, mv) asArray].    (hv at: 2) = mv last ifTrue: [hv removeFirst; removeFirst.        ^ self setVertices: (mv, hv) asArray].    (mv at: 2) = (hv at: 2) ifTrue: [hv removeFirst.  mv remove: (mv at: 2).        xx _ mv removeFirst.        ^ self setVertices: (hv, (Array with: xx), mv reversed) asArray].    mv last = hv last ifTrue: [mv removeLast.  hv removeFirst.        ^ self setVertices: (mv, hv reversed) asArray].    ^ nil! !!Polygon methodsFor: 'geometry' stamp: 'sw 9/14/97 18:22'!mergeDropThird: mv in: hv from: shared    "We are merging two polygons.  In this case, they have at least three identical shared vertices.  Make sure they are sequential in each, and drop the middle one from vertex lists mv, hv, and shared.  First vertices on lists are identical already."    "know (mv first = hv first)"    | mdrop vv |    (shared includes: (mv at: mv size - 2))         ifTrue: [(shared includes: (mv last)) ifTrue: [mdrop _ mv last]]        ifFalse: [(shared includes: (mv last)) ifTrue: [            (shared includes: (mv at: 2)) ifTrue: [mdrop _ mv first]]].    (shared includes: (mv at: 3)) ifTrue: [        (shared includes: (mv at: 2)) ifTrue: [mdrop _ mv at: 2]].    mdrop ifNil: [^ nil].    mv remove: mdrop.    hv remove: mdrop.    shared remove: mdrop.    [shared includes: mv first] whileFalse: ["rotate them"        vv _ mv removeFirst.        mv addLast: vv].    [mv first = hv first] whileFalse: ["rotate him until same shared vertex is first"        vv _ hv removeFirst.        hv addLast: vv].! !!Polygon methodsFor: 'geometry' stamp: 'sw 9/14/97 18:22'!rotate: degrees around: centerPt    "Rotate me around the center.  If center is nil, use the center of my bounds.  Rotation is clockwise on the screen."    | cent |    cent _ centerPt         ifNil: [bounds center]    "approx the center"        ifNotNil: [centerPt].    degrees \\ 90 = 0 ifTrue: ["make these cases exact"        degrees \\ 360 = 90 ifTrue: ["right"            ^ self setVertices: (vertices collect: [:vv |                (vv - cent) y * -1 @ ((vv - cent) x) + cent])].        degrees \\ 360 = 180 ifTrue: [            ^ self setVertices: (vertices collect: [:vv |                (vv - cent) negated + cent])].        degrees \\ 360 = 270 ifTrue: ["left"            ^ self setVertices: (vertices collect: [:vv |                (vv - cent) y @ ((vv - cent) x * -1) + cent])].        degrees \\ 360 = 0 ifTrue: [^ self].        ].    self setVertices: (vertices collect: [:vv |            (Point r: (vv - cent) r degrees: (vv - cent) degrees + degrees) + cent]).! !!Polygon methodsFor: 'drawing' stamp: 'di 6/25/97 23:19'!drawOn: aCanvas     "Display the receiver, a spline curve, approximated by straight line segments."    | lineColor bevel topLeftColor bottomRightColor |    vertices size < 1 ifTrue: [self error: 'a polygon must have at least one point'].    closed & color isTransparent not ifTrue:        [filledForm colors: (Array with: Color transparent with: color).        aCanvas image: filledForm at: bounds topLeft].    lineColor _ borderColor.  bevel _ false.    "Border colors for bevelled effects depend on CW ordering of vertices"    borderColor == #raised ifTrue: [topLeftColor _ color lighter.                        bottomRightColor _ color darker.  bevel _ true].    borderColor == #inset ifTrue: [topLeftColor _ owner colorForInsets darker.                        bottomRightColor _ owner colorForInsets lighter.  bevel _ true].    self lineSegmentsDo:        [:p1 :p2 |        bevel ifTrue: [((p1 quadrantOf: p2) > 2)                        ifTrue: [lineColor _ topLeftColor]                        ifFalse: [lineColor _ bottomRightColor]].        aCanvas line: p1 to: p2 width: borderWidth color: lineColor].    arrowForms ifNotNil: [arrowForms do:        [:f | f colors: (Array with: Color transparent with: borderColor).        aCanvas image: f at: f offset]]! !!Polygon methodsFor: 'editing' stamp: 'di 9/26/97 09:58'!dragVertex: evt fromHandle: handle vertIndex: ix    | p |    p _ evt cursorPoint.    vertices at: ix put: p.    handle position: p + (borderWidth//2) - (handle extent//2).    self computeBounds! !!Polygon methodsFor: 'editing' stamp: 'di 9/26/97 09:54'!dropVertex: evt fromHandle: handle vertIndex: ix    | p |    p _ vertices at: ix.    (((vertices atWrap: ix-1) dist: p) < 3 or:        [((vertices atWrap: ix+1) dist: p) < 3])        ifTrue: ["Drag a vertex onto its neighbor means delete"                self setVertices: (vertices copyReplaceFrom: ix to: ix with: Array new)]! !!Polygon methodsFor: 'editing' stamp: 'di 6/11/97 16:03'!extent: newExtent    "Not really advisable, but we can preserve most of the geometry if we don't    shrink things too small."    | safeExtent |    safeExtent _ newExtent max: 20@20.    self setVertices: (vertices collect:        [:p | p - bounds topLeft * (safeExtent asFloatPoint / (bounds extent max: 1@1)) + bounds topLeft])! !!Polygon methodsFor: 'editing' stamp: 'di 9/26/97 09:17'!newVertex: evt fromHandle: handle afterVert: ix    "Insert a new vertex and fix everything up!!    Install the drag-handle of the new vertex as recipient of further mouse events."    | pt |    pt _ evt cursorPoint.    self setVertices: (vertices copyReplaceFrom: ix+1 to: ix with: (Array with: pt)).    evt hand mouseDownRecipient: (handles at: ix+1*2-1)! !!Polygon methodsFor: 'menu' stamp: 'tk 7/28/97 23:04'!addCustomMenuItems: aCustomMenu hand: aHandMorph    super addCustomMenuItems: aCustomMenu hand: aHandMorph.    handles == nil ifTrue: [aCustomMenu add: 'show handles' action: #addHandles]        ifFalse: [aCustomMenu add: 'hide handles' action: #removeHandles].    closed ifTrue: [aCustomMenu add: 'open polygon' action: #makeOpen]        ifFalse:        [aCustomMenu add: 'close polygon' action: #makeClosed.        arrows == #none ifFalse: [aCustomMenu add: '---' action: #makeNoArrows].        arrows == #forward ifFalse: [aCustomMenu add: '-->' action: #makeForwardArrow].        arrows == #back ifFalse: [aCustomMenu add: '<--' action: #makeBackArrow].        arrows == #both ifFalse: [aCustomMenu add: '<-->' action: #makeBothArrows]]! !!Polygon methodsFor: 'menu' stamp: 'di 9/26/97 09:10'!addHandles    | handle newVert tri |    self removeHandles.    handles _ OrderedCollection new.    tri _ Array with: 0@-4 with: 4@3 with: -3@3.    vertices withIndexDo:        [:vertPt :vertIndex |        handle _ EllipseMorph newBounds: (Rectangle center: vertPt + (borderWidth//2) extent: 8@8)                color: Color yellow.        handle on: #mouseStillDown send: #dragVertex:fromHandle:vertIndex:                to: self withValue: vertIndex.        handle on: #mouseUp send: #dropVertex:fromHandle:vertIndex:                to: self withValue: vertIndex.        self addMorph: handle.        handles addLast: handle.        (closed or: [vertIndex < vertices size]) ifTrue:            ["newVert _ (RectangleMorph newBounds: (Rectangle center: vertPt + (vertices atWrap: vertIndex+1) // 2 extent: 7@7)                    color: Color green) borderWidth: 1."            newVert _ Polygon                    vertices: (tri collect: [:p | p + (vertPt + (vertices atWrap: vertIndex+1) // 2)])                    color: Color green borderWidth: 1 borderColor: Color black.            newVert on: #mouseDown send: #newVertex:fromHandle:afterVert:                    to: self withValue: vertIndex.            self addMorph: newVert.            handles addLast: newVert]].    self changed! !!Polygon methodsFor: 'menu' stamp: '6/9/97 21:32 di'!makeBackArrow    arrows _ #back.    self computeBounds! !!Polygon methodsFor: 'menu' stamp: '6/9/97 21:32 di'!makeBothArrows    arrows _ #both.    self computeBounds! !!Polygon methodsFor: 'menu' stamp: '6/9/97 21:32 di'!makeForwardArrow    arrows _ #forward.    self computeBounds! !!Polygon methodsFor: 'menu' stamp: '6/9/97 21:32 di'!makeNoArrows    arrows _ #none.    self computeBounds! !!Polygon methodsFor: 'menu' stamp: 'tk 9/2/97 16:04'!removeHandles    "tk 9/2/97 allow it to be called twice (when nil already)"    handles ifNotNil: [        handles do: [:h | h delete].        handles _ nil].! !!Polygon methodsFor: 'private' stamp: 'di 6/13/97 07:21'!computeArrowFormAt: endPoint from: priorPoint    "Compute a triangle oriented along the line from priorPoint to endPoint.    Then draw those lines in a form and return that form, with appropriate offset"    | d v p1 pts box arrowForm bb origin angle |    d _ borderWidth max: 1.    v _ endPoint - priorPoint.    angle _ v theta radiansToDegrees.    pts _ Array with: (endPoint + (borderWidth//2) + (Point r: d*5 degrees: angle))                with: (endPoint + (borderWidth//2) + (Point r: d*4 degrees: angle + 135.0))                with: (endPoint + (borderWidth//2) + (Point r: d*4 degrees: angle - 135.0)).    box _ ((pts first rect: pts last) encompass: (pts at: 2)) expandBy: 1.    arrowForm _ ColorForm extent: box extent asIntegerPoint.    bb _ (BitBlt toForm: arrowForm) sourceForm: nil; fillColor: Color black;            combinationRule: Form over; width: 1; height: 1.    origin _ box topLeft.    p1 _ pts last - origin.    pts do: [:p | bb drawFrom: p1 to: p-origin.  p1 _ p-origin].    arrowForm convexShapeFill: Color black.    ^ arrowForm offset: box topLeft! !!Polygon methodsFor: 'private' stamp: '6/9/97 21:33 di'!computeArrows    (closed or: [arrows == #none or: [vertices size < 2]]) ifTrue: [arrowForms _ nil.  ^ self changed].    arrowForms _ Array new.    (arrows == #forward or: [arrows == #both]) ifTrue:        [arrowForms _ arrowForms copyWith:            (self computeArrowFormAt: vertices last from: self nextToLastPoint)].    (arrows == #back or: [arrows == #both]) ifTrue:        [arrowForms _ arrowForms copyWith:            (self computeArrowFormAt: vertices first from: self nextToFirstPoint)].    arrowForms do: [:f | bounds _ bounds merge: (f offset extent: f extent)]! !!Polygon methodsFor: 'private' stamp: 'di 9/26/97 09:57'!computeBounds    self changed.    bounds _ self curveBounds.    self computeFill.    self computeArrows.    handles ifNotNil: [self updateHandles].    self layoutChanged.    self changed! !!Polygon methodsFor: 'private' stamp: 'di 6/25/97 22:48'!computeFill    | bb origin |    closed ifFalse: [^ filledForm _ nil].    filledForm _ ColorForm extent: bounds extent.    bb _ (BitBlt toForm: filledForm) sourceForm: nil; fillColor: Color black;            combinationRule: Form over; width: 1; height: 1.    origin _ bounds topLeft.    self lineSegmentsDo: [:p1 :p2 | bb drawFrom: p1-origin to: p2-origin].    quickFill ifTrue: [filledForm convexShapeFill: Color black]            ifFalse: ["Someday put a better fill algorithm here"].! !!Polygon methodsFor: 'private' stamp: 'tk 8/5/97 09:01'!copyRecordingIn: dict    "Copy the vertices array.  Give each one its own handles, and in the handles array."    | new hadHandles |    hadHandles _ handles ifNil: [false] ifNotNil: [self removeHandles. true].    new _ super copyRecordingIn: dict.    new setVertices: vertices copy.    hadHandles ifTrue: [self addHandles.  new addHandles].    ^ new! !!Polygon methodsFor: 'private' stamp: '6/9/97 11:54 di'!curveBounds    | r |    r _ nil.    vertices do:        [:p | r == nil ifTrue: [r _ p corner: p]                    ifFalse: [r _ r encompass: p]].    ^ r topLeft corner: r bottomRight + (borderWidth+1)! !!Polygon methodsFor: 'private' stamp: 'di 6/25/97 23:21'!lineSegmentsDo: endPointsBlock    | beginPoint |    beginPoint _ nil.    vertices do:        [:endPoint | beginPoint ifNotNil:            [endPointsBlock value: beginPoint asIntegerPoint                            value: endPoint asIntegerPoint].        beginPoint _ endPoint].    (closed or: [vertices size = 1])        ifTrue: [endPointsBlock value: beginPoint asIntegerPoint                                value: vertices first asIntegerPoint]! !!Polygon methodsFor: 'private' stamp: '6/9/97 12:07 di'!nextToFirstPoint  "For arrow direction"    ^ vertices at: 2! !!Polygon methodsFor: 'private' stamp: '6/9/97 12:07 di'!nextToLastPoint  "For arrow direction"    ^ vertices at: vertices size - 1! !!Polygon methodsFor: 'private' stamp: '6/9/97 09:35 di'!privateMoveBy: delta    super privateMoveBy: delta.    vertices _ vertices collect: [:p | p + delta].    arrowForms ifNotNil: [arrowForms do: [:f | f offset: f offset + delta]]! !!Polygon methodsFor: 'private' stamp: 'di 6/11/97 16:00'!setVertices: newVertices    | hadHandles |    hadHandles _ handles ifNil: [false] ifNotNil: [self removeHandles. true].    vertices _ newVertices.    hadHandles ifTrue: [self addHandles].    self computeBounds! !!Polygon methodsFor: 'private' stamp: 'di 9/26/97 09:42'!updateHandles    | newVert |    vertices withIndexDo:        [:vertPt :vertIndex |        (closed or: [vertIndex < vertices size]) ifTrue:            [newVert _ handles at: vertIndex*2.            newVert position: (vertPt + (vertices atWrap: vertIndex+1)                                - newVert extent) // 2 + (2@0)]].! !!Polygon class methodsFor: 'instance creation' stamp: 'di 9/26/97 09:06'!vertices: verts color: c borderWidth: bw borderColor: bc    ^ self basicNew vertices: verts color: c borderWidth: bw borderColor: bc! !!PopUpMenu methodsFor: 'displaying'!displayAt: aPoint withCaption: captionOrNil during: aBlock    "Display the receiver just to the right of aPoint while aBlock is evaluated.  If the receiver is forced off screen, display it just to the right."    | delta savedArea captionView captionSave outerFrame captionText tFrame frameSaveLoc |    frame _ frame align: marker leftCenter with: aPoint + (2@0).    outerFrame _ frame.    captionOrNil notNil ifTrue:        [captionText _ DisplayText                text: captionOrNil asText                textStyle: TextStyle default copy centered.        tFrame _ captionText boundingBox insetBy: -2.        outerFrame _ frame merge: (tFrame align: tFrame bottomCenter                    with: frame topCenter + (0@2))].    delta _ outerFrame amountToTranslateWithin: Display boundingBox.    frame _ frame translateBy: delta.    captionOrNil notNil ifTrue:        [captionView _ DisplayTextView new model: captionText.        captionView align: captionView boundingBox bottomCenter                    with: frame topCenter + (0@2).        captionView insideColor: Color white.        captionView borderWidth: 2.        captionSave _ Form fromDisplay: captionView displayBox.        captionView unlock; display; release].    marker _ marker align: marker leftCenter with: aPoint + delta +  (2@0).    savedArea _ Form fromDisplay: frame.    self menuForm displayOn: Display at: (frameSaveLoc _ frame topLeft).    selection ~= 0 ifTrue: [Display reverse: marker].    Cursor normal showWhile: [aBlock value].    savedArea displayOn: Display at: frameSaveLoc.    captionOrNil notNil ifTrue:        [captionSave displayOn: Display at: captionView displayBox topLeft]! !!PopUpMenu methodsFor: 'marker adjustment'!manageMarker    "If the cursor is inside the receiver's frame, then highlight the marked     item. Otherwise no item is to be marked."    | pt |    "Don't let pt get far from display box, so scrolling will go all the way"    pt _ Sensor cursorPoint adhereTo: (Display boundingBox expandBy: 1).    (frame inside containsPoint: pt)        ifTrue: ["Need to cache the form for reasonable scrolling performance"                (Display boundingBox containsPoint: pt)                    ifTrue: [CacheMenuForms ifFalse: [form _ nil]]                    ifFalse: [form == nil ifTrue: [form _ self computeForm].                            pt _ pt - (self scrollIntoView: pt)].                self markerOn: pt]        ifFalse: [self markerOff]! !!PopUpMenu methodsFor: 'marker adjustment'!scrollIntoView: cursorLoc    | dy |    dy _ 0.    cursorLoc y < 0 ifTrue: [dy _ font height].    cursorLoc y > Display height ifTrue: [dy _ font height negated].    dy = 0 ifTrue: [^ 0@0].    self markerOff.    frame _ frame translateBy: 0@dy.    marker _ marker translateBy: 0@dy.    self menuForm displayOn: Display at: frame topLeft.    ^ 0@dy! !!PopUpMenu methodsFor: 'private'!computeForm    "Compute and answer a Form to be displayed for this menu."    | borderInset paraForm menuForm |    borderInset _ 2@2.    paraForm _ self computeLabelParagraph asForm.    menuForm _ Form extent: paraForm extent + (borderInset * 2).    menuForm fillBlack.    paraForm displayOn: menuForm at: borderInset.    lineArray == nil ifFalse: [        lineArray do: [ :line |            menuForm fillBlack:                (0 @ ((line * font height) + borderInset y) extent: (menuForm width @ 1)).        ].    ].    ^ menuForm! !!PopUpMenu methodsFor: 'private'!computeLabelParagraph    "Answer a Paragraph containing this menu's labels, one per line and centered."    ^ Paragraph withText: labelString asText style: MenuStyle! !!PopUpMenu methodsFor: 'private'!labels: aString font: aFont lines: anArray    | style inside |    labelString _ aString.    font _ aFont.    lineArray _ anArray.    frame _ Quadrangle new.    frame region: self menuForm boundingBox.    frame borderWidth: 2.    inside _ frame inside.    marker _ inside topLeft extent: (inside width @ self computeLabelParagraph lineGrid).    selection _ 1.! !!PopUpMenu methodsFor: 'private'!menuForm    "Answer a Form to be displayed for this menu."    "Details: On slower systems, cache the menu Form for speed."    form == nil ifFalse: [^ form].    CacheMenuForms        ifTrue: [^ form _ self computeForm]        ifFalse: [^ self computeForm]! !!PopUpMenu methodsFor: 'private'!rescan    "Cause my form to be recomputed after a font change."    labelString == nil ifTrue: [labelString _ 'NoText!!'].    self labels: labelString font: (MenuStyle fontAt: 1) lines: lineArray.    form _ nil.    "PopUpMenu withAllSubclasses do: [ :menuClass |        menuClass allInstancesDo: [ :m | m rescan ]]"! !!PopUpMenu class methodsFor: 'instance creation'!labels: aString lines: anArray    "Answer an instance of me whose items are in aString, with lines drawn     after each item indexed by anArray."    ^self new        labels: aString        font: (MenuStyle fontAt: 1)        lines: anArray! !!PopUpMenu class methodsFor: 'class initialization'!initialize  "PopUpMenu initialize"    "Change CacheMenuForms to true to get faster popup menus on slower systems."    "CacheMenuForms _ true"    CacheMenuForms _ false.    (MenuStyle _ TextStyle default copy)        gridForFont: 1 withLead: 0;        centered.    PopUpMenu withAllSubclasses do:        [:menuClass | menuClass allInstancesDo:            [:m | m rescan]]! !!PositionableStream methodsFor: 'accessing'!next: anInteger     "Answer the next anInteger elements of the receiver."    | newArray |    newArray _ collection species new: anInteger.    1 to: anInteger do: [:index | newArray at: index put: self next].    ^newArray! !!PositionableStream methodsFor: 'accessing'!upToEnd    "Answer a subcollection from the current access position through the last element of the receiver."    | newStream el |    newStream _ WriteStream on: (collection species new: 100).    [(el _ self next) == nil] whileFalse: [ newStream nextPut: el ].    ^ newStream contents! !!PositionableStream methodsFor: 'fileIn/Out' stamp: 'di 6/28/97 08:34'!copyMethodChunkFrom: aStream    "Copy the next chunk from aStream (must be different from the receiver)."    | terminator code |    terminator _ $!!.    aStream skipSeparators.    code _ aStream upTo: terminator.    self nextPutAll: code; nextPut: terminator.    [aStream peekFor: terminator] whileTrue:   "case of imbedded (doubled) terminators"            [self nextPut: terminator;                nextPutAll: (aStream upTo: terminator);                nextPut: terminator].! !!PositionableStream methodsFor: 'fileIn/Out' stamp: 'di 6/28/97 08:49'!copyMethodWithPreamble: preamble from: aStream    | newFilePosition |    "First copy the preamble if any."    self copyPreamble: preamble from: aStream.    "Then copy the method chunk"    newFilePosition _ self position.    self copyMethodChunkFrom: aStream.    self nextChunkPut: ' '.    ^ newFilePosition! !!PositionableStream methodsFor: 'fileIn/Out' stamp: 'di 6/28/97 09:16'!copyPreamble: preamble from: aStream    "Look for a changeStamp for this method by peeking backward.    Write a method preamble, with that stamp if found."    | terminator methodPos p last50 stamp i |    terminator _ $!!.    "Look back to find stamp in old preamble, such as...    Polygon methodsFor: 'private' stamp: 'di 6/25/97 21:42' prior: 34957598!! "    methodPos _ aStream position.    aStream position: (p _ 0 max: methodPos-50).    last50 _ aStream next: methodPos - p.    stamp _ String new.    (i _ last50 findString: 'stamp:' startingAt: 1) > 0 ifTrue:        [stamp _ (last50 copyFrom: i+8 to: last50 size) copyUpTo: $'].    "Write the new preamble, with old stamp if any."    self cr; nextPut: terminator.    self nextChunkPut: (String streamContents:        [:strm |        strm nextPutAll: preamble.        stamp size > 0 ifTrue:            [strm nextPutAll: ' stamp: '; print: stamp]]).    self cr! !!PositionableStream methodsFor: 'fileIn/Out'!nextChunk    "Answer the contents of the receiver, up to the next terminator character. Doubled terminators indicate an embedded terminator character."    | terminator out ch |    terminator _ $!!.    out _ WriteStream on: (String new: 1000).    self skipSeparators.    [(ch _ self next) == nil] whileFalse: [        (ch == terminator) ifTrue: [            self peek == terminator ifTrue: [                self next.  "skip doubled terminator"            ] ifFalse: [                ^ out contents  "terminator is not doubled; we're done!!"            ].        ].        out nextPut: ch.    ].    ^ out contents! !!PositionableStream methodsFor: 'fileIn/Out' stamp: 'di 6/13/97 12:00'!skipSeparators    [self atEnd]        whileFalse:        [self next isSeparator ifFalse: [^ self position: self position-1]]! !Preferences comment:'A general mechanism to store preference choices.  The default setup treats any symbol as a potential boolean flag; flags unknown to the preference dictionary are always returned as false.  It is also possible to store non-boolean data in the preference table.  sw 8/91'!!Preferences class methodsFor: 'hard-coded prefs'!startAllWindowTicking    "Execute this to set the system to start the ticking of inactive windows"    "Preferences startAllWindowTicking"    Preferences class compile:'letInactiveWindowsTick    "Set to true if you want inactive windows to tick in HyperSqueak"    ^ true' classified: 'HyperSqueak'! !!Preferences class methodsFor: 'hard-coded prefs'!startCollisionDetection    "Execute this to set the system to start collision detection"    "Preferences startLoggingUserScripts"    Preferences class compile:'collisionDetection    "Set to true if you want collision detection to take place automatically in HyperSqueak"    ^ true' classified: 'HyperSqueak'! !!Preferences class methodsFor: 'hard-coded prefs' stamp: 'sw 7/18/96'!startLoggingUserScripts    "Execute this to set the system to start logging user scripts to the changes log.  "    "Preferences startLoggingUserScripts"    Preferences class compile:'logUserScripts    "Set to true if you want user scripts logged; later, we will maybe have a better way to specify this, or do something better altogether"    ^ true' classified: 'HyperSqueak'! !!Preferences class methodsFor: 'hard-coded prefs'!stopAllWindowTicking    "Execute this to set the system to stop the ticking of inactive windows"    "Preferences stopAllWindowTicking"    Preferences class compile:'letInactiveWindowsTick    "Set to true if you want inactive windows to tick in HyperSqueak"    ^ false' classified: 'HyperSqueak'! !!Preferences class methodsFor: 'hard-coded prefs'!stopCollisionDetection    "Execute this to set the system to stop collision detection"    "Preferences startLoggingUserScripts"    Preferences class compile:'collisionDetection    "Set to true if you want automatic collision detection to take place"    ^ false' classified: 'HyperSqueak'! !!Preferences class methodsFor: 'hard-coded prefs' stamp: 'sw 7/18/96'!stopLoggingUserScripts    "Execute this to set the system to stop logging user scripts to the changes log.  "    "Preferences stopLoggingUserScripts"    Preferences class compile:'logUserScripts    "Set to true if you want user scripts logged; later, we will maybe have a better way to specify this, or do something better altogether"    ^ false' classified: 'HyperSqueak'! !!Preferences class methodsFor: 'general' stamp: 'sw 5/2/96'!chooseInitialSettings    "Set up the initial choices for Preferences.  2/7/96 sw     : added init for uniformWindowColors     : init reverseWindowStagger, clear out old window parms"    "Preferences chooseInitialSettings"    self setPreference: #uniformWindowColors toValue: false.    self setPreference: #reverseWindowStagger toValue: true.    self setPreference: #programmerMode toValue: false.    AutoAccessors _ false.    BrowserAutoSelect _ false.! !!Preferences class methodsFor: 'general' stamp: 'sw 5/22/96'!initialize    ": Included within a 22 May96 fileout to trigger reinitialization"    FlagDictionary _ Dictionary new.    self chooseInitialSettings.    "Preferences initialize"! !!Preferences class methodsFor: 'HyperSqueak'!collisionDetection    "Set to true if you want automatic collision detection to take place"    ^ false! !!Preferences class methodsFor: 'HyperSqueak'!letInactiveWindowsTick    "Set to true if you want inactive windows to tick in HyperSqueak"    ^ false! !!Preferences class methodsFor: 'HyperSqueak'!logUserScripts    "Set to true if you want user scripts logged; later, we will maybe have a better way to specify this, or do something better altogether"    ^ true! !!Preferences class methodsFor: 'HyperSqueak' stamp: 'sw 1/8/97'!nestedHalos    "Answer whether nested halos should be used.  "    self flag: #scottPrivate.    ^ false! !!Preferences class methodsFor: 'ui prefs'!autoAccessors    "Answer the preference; change by: Preferences classPool inspect"        ^ AutoAccessors! !!Preferences class methodsFor: 'ui prefs'!browserAutoSelect    "Answer the preference; change by: Preferences classPool inspect"        ^ BrowserAutoSelect! !!Preferences class methodsFor: 'ui prefs' stamp: 'sw 11/26/96'!desktopColor    "Answer the desktop color.  Initialize it if it's never been done.  "        DesktopColor == nil ifTrue:        [DesktopColor _ Color gray].    ^ DesktopColor! !!Preferences class methodsFor: 'ui prefs'!desktopColor: aColor    "Set the desktop color"    DesktopColor _ aColor! !!Preferences class methodsFor: 'ui prefs'!scrollBarBackground: viewColor    "Answer the preferred background color for scroll bars."    ^ viewColor! !!Preferences class methodsFor: 'ui prefs'!scrollBarColor    "Answer the preferred color for scroll bar elevators."    ^ Color gray! !!Preferences class methodsFor: 'ui prefs'!scrollBarWidth    "Answer the preferred width for scroll bars."    ^ 8! !!ProcessorScheduler class methodsFor: 'background process' stamp: 'jm 9/11/97 10:44'!idleProcess    "A default background process which is invisible."    [true] whileTrue:        [self relinquishProcessorForMicroseconds: 1000].! !!ProcessorScheduler class methodsFor: 'background process' stamp: 'jm 9/3/97 11:17'!relinquishProcessorForMicroseconds: anInteger    "Platform specific. This primitive is used to return processor cycles to the host operating system when Squeak's idle process is running (i.e., when no other Squeak process is runnable). On some platforms, this primitive causes the entire Squeak application to sleep for approximately the given number of microseconds. No Squeak process can run while the Squeak application is sleeping, even if some external event makes it runnable. On the Macintosh, this primitive simply calls GetNextEvent() to give other applications a chance to run. On platforms without a host operating system, it does nothing. This primitive should not be used to add pauses to a Squeak process; use a Delay instead."    <primitive: 230>    "don't fail if primitive is not implemented, just do nothing"! !!ProcessorScheduler class methodsFor: 'background process' stamp: 'jm 9/11/97 10:42'!startUp    "Install a background process of the lowest possible priority that is always runnable."    "Details: The virtual machine requires that there is aways some runnable process that can be scheduled; this background process ensures that this is the case."    BackgroundProcess == nil ifFalse: [BackgroundProcess terminate].    BackgroundProcess _ [self idleProcess] newProcess.    BackgroundProcess priority: SystemRockBottomPriority.    BackgroundProcess resume.! !!ProcessorScheduler class methodsFor: 'background process' stamp: 'jm 9/11/97 10:32'!sweepHandIdleProcess    "A default background process which shows a sweeping circle of XOR-ed bits on the screen."    | sweepHand |    sweepHand _ Pen new.    sweepHand defaultNib: 2.    sweepHand combinationRule: 6.    [true] whileTrue: [        2 timesRepeat: [            sweepHand north.            36 timesRepeat: [                sweepHand place: Display boundingBox topRight + (-25@25).                sweepHand go: 20.                sweepHand turn: 10]].        self relinquishProcessorForMicroseconds: 10000].! !Project comment:'A Project stores the state of a complete Squeak desktop, including the windows, and the currently active changeSet, as well as the parent project in which it was created.  When you change projects, whether by entering or exiting, all the global state is saved into the project being exited, and loaded from the one being entered.A project is retained by its view in the parent world.  It is effectively named by the name of its changeSet, which can be changed either by renaming in a changeSorter, or by editing the label of its view from the parent project.As the site of major context switch, Projects are the locus of swapping between the old MVC and the new Morphic worlds.  The distinction is based on whether the variable ''world'' contains a WorldMorph or a ControlManager.'!!Project methodsFor: 'initialization' stamp: 'di 6/24/97 11:51'!initFromParent:  aProject    "Written so that Morphic can still be removed."    world _ (Smalltalk at: #WorldMorph ifAbsent: [^ nil]) new.    changeSet _ ChangeSet new initialize.    transcript _ Transcript.  "  -- we need a TranscriptMorph"    displayDepth _ Display depth.    parentProject _ aProject! !!Project methodsFor: 'initialization'!initialProject    self saveState.    parentProject _ self! !!Project methodsFor: 'initialization'!setChangeSet: aChangeSet    changeSet _ aChangeSet! !!Project methodsFor: 'initialization'!setProjectHolder: aProject    world _ ControlManager new.    changeSet _ ChangeSet new initialize.    transcript _ TextCollector new.    displayDepth _ Display depth.    parentProject _ aProject! !!Project methodsFor: 'accessing'!isTopProject    "Return true only of this is the top project (its own holder)"    ^ parentProject == self! !!Project methodsFor: 'accessing'!leaveThisWorld    exitFlag _ true! !!Project methodsFor: 'accessing'!name    ^ changeSet name! !!Project methodsFor: 'accessing'!projectChangeSet    ^ changeSet! !!Project methodsFor: 'accessing'!world    ^ world! !!Project methodsFor: 'menu messages' stamp: 'di 6/17/97 18:05'!enter    "The user has chosen to change the context of the workspace to be that of     the receiver. Change the ChangeSet, Transcript, and collection of     scheduled views accordingly."    CurrentProject saveState.    CurrentProject _ self.    Smalltalk newChanges: changeSet.    TextCollector newTranscript: transcript.    displayDepth == nil ifTrue: [displayDepth _ Display depth].    Display newDepthNoRestore: displayDepth.    world isMorph ifFalse: [World _ nil.  ^ ControlManager newScheduler: world].    (World _ world) install.    self spawnNewProcess! !!Project methodsFor: 'menu messages' stamp: 'jm 9/3/97 11:03'!exit    "Leave the current project and return to the project    in which this one was created."    self isTopProject ifTrue: [^ PopUpMenu notify: 'Can''t exit the top project'].    activeProcess _ nil.    parentProject enter.! !!Project methodsFor: 'menu messages'!fileOut    changeSet fileOut! !!Project methodsFor: 'menu messages' stamp: 'di 6/16/97 11:39'!saveState    "Save the current state in me prior to switching projects"    world isMorph ifTrue: [world _ World]                ifFalse: [world _ ScheduledControllers.                        ScheduledControllers unCacheWindows].    changeSet _ Smalltalk changes.    transcript _ Transcript.    displayDepth _ Display depth.! !!Project methodsFor: 'menu messages' stamp: 'di 6/17/97 18:05'!spawnNewProcess    exitFlag _ false.    activeProcess _        [[World doOneCycle.  Processor yield.  exitFlag] whileFalse: [].        self exit]            newProcess priority: Processor userSchedulingPriority.    activeProcess resume.    Processor terminateActive! !!Project methodsFor: 'release'!okToChange    ^ self confirm:'Are you sure you have savedall changes that you care aboutin ', self name printString.! !!Project methodsFor: 'release'!release    world == nil ifFalse:        [world release.        world _ nil].    ^ super release! !!Project class methodsFor: 'instance creation'!newMorphic    ^ super new initFromParent: CurrentProject! !!ProjectView methodsFor: 'displaying'!displayView    | scale rect topLeft ibox worldImage sc |    super displayView.    self label = model name        ifFalse: [super relabel: model name].    self isCollapsed ifTrue: [^ self].    model world isMorph ifTrue:        [Display fill: (ibox _ self insetDisplayBox) fillColor: model world color.        model world layoutChanged.        worldImage _ model world imageForm.        ^ (WarpBlt toForm: Display)            sourceForm: worldImage;            cellSize: 2;    "installs a colormap"            combinationRule: Form paint;            copyQuad: (worldImage offset negated extent: Display extent) innerCorners            toRect: self insetDisplayBox].    Display fill: (ibox _ self insetDisplayBox) fillColor: Color lightGray.    scale _ ibox extent / Display extent.    topLeft _ ibox topLeft.    sc _ model world screenController.    (model world scheduledControllers select: [:c | c ~~ sc] thenCollect: [:c | c view])        reverseDo:        [:v | rect _ ((v displayBox scaleBy: scale) rounded                translateBy: topLeft) intersect: ibox.        Display fill: rect fillColor: v backgroundColor;            border: rect width: 1;            border: (rect topLeft extent: rect width@3) width: 1]! !ProtocolBrowser comment:'An instance of ProtocolBrowser shows the methods a class understands--inherited or implemented at this level--as a "flattened" list.'!!ProtocolBrowser methodsFor: 'accessing' stamp: 'di 7/13/97 16:33'!getList    "Answer the receiver's message list."    ^ messageList! !!ProtocolBrowser methodsFor: 'accessing' stamp: 'di 7/13/97 16:33'!list    "Answer the receiver's message list."    ^ messageList! !!ProtocolBrowser methodsFor: 'accessing' stamp: 'di 7/13/97 16:35'!selectedClass    "Answer the receiver's selected class."    ^ selectedClass! !!ProtocolBrowser methodsFor: 'accessing' stamp: 'di 7/13/97 16:35'!selectedClass: aClass    "Set the receiver's selected class to be the argument."    selectedClass := aClass! !!ProtocolBrowser methodsFor: 'accessing' stamp: 'di 7/13/97 16:35'!selector    "Answer the receiver's selected selector."    ^ selectedSelector! !!ProtocolBrowser methodsFor: 'accessing' stamp: 'di 7/13/97 16:35'!selector: aString    "Set the currently selected message selector to be aString."    selectedSelector := aString.    self changed: #selector! !!ProtocolBrowser methodsFor: 'accessing' stamp: 'di 7/13/97 16:35'!setSelector: aString    "Set the currently selected message selector to be aString."    selectedSelector := aString! !!ProtocolBrowser methodsFor: 'private' stamp: 'di 7/13/97 16:23'!initListFrom: selectorCollection highlighting: aClass     "Make up the messageList with items from aClass in boldface."    | defClass item |    messageList := OrderedCollection new.    selectorCollection do:         [:selector |  defClass := aClass whichClassIncludesSelector: selector.        item _ selector, '     (' , defClass name , ')'.        messageList add: (defClass == aClass ifTrue:[item asText allBold] ifFalse:[item])]! !!ProtocolBrowser methodsFor: 'private' stamp: 'di 7/13/97 16:26'!on: aClass     "Initialize with the entire protocol for the class, aClass."    self initListFrom: aClass allSelectors asSortedCollection        highlighting: aClass! !!ProtocolBrowser methodsFor: 'private' stamp: 'di 7/13/97 16:29'!onSubProtocolOf: aClass     "Initialize with the entire protocol for the class, aClass,        but excluding those inherited from Object."    | selectors |    selectors := Set new.    (aClass withAllSuperclasses copyWithout: Object) do:        [:each | selectors addAll: each selectors].    self initListFrom: selectors asSortedCollection        highlighting: aClass! !!ProtocolBrowser methodsFor: 'private' stamp: 'di 7/13/97 16:51'!parse: messageString toClassAndSelector: csBlock    "Decode strings of the form <selectorName>   (<className> [class])  "    | tuple cl |    tuple _ messageString asString findTokens: ' '.    cl _ tuple at: 2.    cl _ cl copyWithoutAll: '()'.  "Strip parens"    cl _ tuple size = 2        ifTrue: [Smalltalk at: cl asSymbol]        ifFalse: [(Smalltalk at: cl asSymbol) class].    self selectedClass: cl.    self setSelector: tuple first.    ^ csBlock value: cl value: tuple first asSymbol! !!ProtocolBrowser methodsFor: 'private' stamp: 'di 7/13/97 16:37'!setClassAndSelectorIn: csBlock    "Decode strings of the form <selectorName>   (<className> [class])  "    ^ self parse: self selection toClassAndSelector: csBlock! !!ProtocolBrowser class methodsFor: 'instance creation' stamp: 'di 7/13/97 15:15'!openFullProtocolForClass: aClass     "Create and schedule a browser for the entire protocol of the class."    "ProtocolBrowser openFullProtocolForClass: ProtocolBrowser."    | aPBrowser label |    aPBrowser := ProtocolBrowser new on: aClass.    label := 'Entire protocol of: ', aClass name.    self open: aPBrowser name: label! !!ProtocolBrowser class methodsFor: 'instance creation' stamp: 'di 7/13/97 15:15'!openSubProtocolForClass: aClass     "Create and schedule a browser for the entire protocol of the class."    "ProtocolBrowser openSubProtocolForClass: ProtocolBrowser."    | aPBrowser label |    aPBrowser := ProtocolBrowser new onSubProtocolOf: aClass.    label := 'Sub-protocol of: ', aClass name.    self open: aPBrowser name: label! !!Quadrangle methodsFor: 'initialize-release'!initialize    "Initialize the region to a null Rectangle, the borderWidth to 1, the     borderColor to black, and the insideColor to white."    origin _ 0 @ 0.    corner _ 0 @ 0.    borderWidth _ 1.    borderColor _ Color black.    insideColor _ Color white.! !!Quadrangle methodsFor: 'displaying-generic'!displayOn: aDisplayMedium transformation: aWindowingTransformation clippingBox: aRectangle    "Display the border and region of the receiver so that it is scaled and     translated with respect to aWindowingTransformation. The displayed     information should be clipped so that only information with the area     determined by aRectangle is displayed."    | screenRectangle |    screenRectangle _         (aWindowingTransformation applyTo: self) intersect: aRectangle.    borderWidth ~~ 0 & (insideColor ~~ nil)        ifTrue:             [aDisplayMedium fill: screenRectangle fillColor: Color black "borderColor".            aDisplayMedium                fill: (screenRectangle insetBy: borderWidth)                fillColor: insideColor]! !!Quadrangle methodsFor: 'private'!setRegion: aRectangle borderWidth: anInteger borderColor: aMask1 insideColor: aMask2    origin _ aRectangle origin.    corner _ aRectangle corner.    borderWidth _ anInteger.    borderColor _ aMask1.    insideColor _ aMask2! !!Quadrangle class methodsFor: 'instance creation'!region: aRectangle borderWidth: anInteger borderColor: aMask1 insideColor: aMask2    "Answer an instance of me with rectangle, border width and color, and     inside color determined by the arguments."    ^super new        setRegion: aRectangle        borderWidth: anInteger        borderColor: aMask1        insideColor: aMask2! !QuickPrint comment:'This class supports fast, single-line string display. It is significantly faster than using a Paragraph for the same purpose.'!!QuickPrint methodsFor: 'displaying'!drawString: aString at: aPoint    "Draw the given string."    destX _ aPoint x asInteger.    destY _ aPoint y asInteger.    self scanCharactersFrom: 1 to: aString size in: aString        rightX: clipX + clipWidth + font maxWidth        stopConditions: stopConditions        displaying: true! !!QuickPrint methodsFor: 'displaying'!lineHeight    "Answer the height of the font used by QuickPrint."    ^ font height! !!QuickPrint methodsFor: 'displaying'!stringWidth: aString    "Answer the width of the given string."    destX _ 0.    destY _ 0.    self scanCharactersFrom: 1 to: aString size in: aString        rightX: 99999    "virtual infinity"        stopConditions: stopConditions        displaying: false.    ^ destX"    (1 to: 10) collect: [:i | QuickPrint new stringWidth: (String new: i withAll: $A)]"! !!QuickPrint methodsFor: 'private'!newOn: aForm box: aRectangle font: aStrikeFont color: textColor    "Initialize myself."    font _ aStrikeFont ifNil: [TextStyle default fontAt: 1].    self setFont.    destForm _ aForm.    self colorMap: (Bitmap with: 0      "Assumes 1-bit deep fonts"                        with: ((textColor bitPatternForDepth: destForm depth) at: 1)).    combinationRule _ Form paint.    self clipRect: aRectangle.    sourceY _ 0.    "sourceX is set when selecting the character from the font strike bitmap"! !!QuickPrint methodsFor: 'private'!setFont    "Install various parameters from the font."    spaceWidth _ font widthOf: Space.     sourceForm _ font glyphs.  "Should only be needed in DisplayScanner"    height _ font height.            " ditto "    xTable _ font xTable.    stopConditions _ font stopConditions.    stopConditions at: Space asciiValue + 1 put: nil.    stopConditions at: Tab asciiValue + 1 put: #tab.    stopConditions at: CR asciiValue + 1 put: #cr.    stopConditions at: EndOfRun put: #endOfRun.    stopConditions at: CrossedX put: #crossedX! !!QuickPrint class methodsFor: 'instance creation'!new    "Create an instance to print on the display in the default font."    ^ super new newOn: Display box: Display boundingBox font: self defaultFont color: Color black! !!QuickPrint class methodsFor: 'instance creation'!newOn: aForm box: aRectangle    "Create an instance to print on the given form in the given rectangle."    ^(super new) newOn: aForm box: aRectangle font: self defaultFont color: Color black! !!QuickPrint class methodsFor: 'instance creation'!newOn: aForm box: aRectangle font: aStrikeFont    "Create an instance to print on the given form in the given rectangle."    ^(super new) newOn: aForm box: aRectangle font: aStrikeFont color: Color black! !!QuickPrint class methodsFor: 'instance creation'!newOn: aForm box: aRectangle font: aStrikeFont color: textColor    "Create an instance to print on the given form in the given rectangle."    ^ (super new) newOn: aForm box: aRectangle font: aStrikeFont color: textColor! !!QuickPrint class methodsFor: 'queries'!defaultFont    ^ (TextStyle default) fontArray at: 1! !!QuickPrint class methodsFor: 'example'!example    "This will quickly print all the numbers from 1 to 100 on the display,    and then answer the default width and height of the string 'hello world'."    "QuickPrint example"    | scanner |    scanner _ QuickPrint new.    0 to: 99 do: [: i | scanner drawString: i printString at: (i//10*20) @ (i\\10*12) ].    ^ (scanner stringWidth: 'hello world') @ (scanner lineHeight)! !Random comment:'This Random Number Generator graciously contributed by David N. Smith.  It is an adaptation of the Park-Miller RNG which uses Floats to avoid the need for LargeInteger arithmetic.'!!Random methodsFor: 'all'!initialize    " Set a reasonable Park-Miller starting seed "    seed := Time millisecondClockValue.    a := 16r000041A7 asFloat.    " magic constant =      16807 "    m := 16r7FFFFFFF asFloat.    " magic constant = 2147483647 "    q := (m quo: a) asFloat.    r  := (m \\ a) asFloat.! !!Random methodsFor: 'all'!next    " This method generates random instances of Float in the interval 0to 1. "    seed := self nextValue.    ^ seed / m! !!Random methodsFor: 'all'!nextValue    " This method generates random instances of Integer    in the interval 0 to 16r7FFFFFFF.    This method does NOT update the seed; repeated sends answer thesame value.    The algorithm is described in detail in 'Random Number Generators:    Good Ones Are Hard to Find' by Stephen K. Park and Keith W. Miller    (Comm. Asso. Comp. Mach., 31(10):1192--1201, 1988). "    | lo hi aLoRHi answer |    hi := (seed quo: q) asFloat.    lo := seed - (hi*q).     " = seed rem: q"      aLoRHi := (a * lo) - (r * hi).    answer := (aLoRHi > 0.0)        ifTrue:  [ aLoRHi ]        ifFalse: [ aLoRHi + m ].    ^ answer! !!Random methodsFor: 'all'!seed: anInteger     seed := anInteger! !!Random class methodsFor: 'examples'!example    "If you just want a quick random integer, use:        10 atRandom    Every integer interval can give a random number:        (6 to: 12) atRandom    Most Collections can give randomly selected elements:        'pick one of these letters randomly' atRandom    Collections also respond to shuffled, as in:        ($A to: $Z) shuffled    The correct way to use class Random is to store one in     an instance or class variable:        myGenerator _ Random new.    Then use it every time you need another number between 0.0 and 1.0        myGenerator next"! !!Random class methodsFor: 'testing'!bucketTest: randy    "Execute this:   Random bucketTest: Random new"    " A quick-and-dirty bucket test. Prints nbuckets values on theTranscript.      Each should be 'near' the value of ntries. Any run with any value'far' from ntries      indicates something is very wrong. Each run generates differentvalues.      For a slightly better test, try values of nbuckets of 200-1000 ormore; go get coffee.      This is a poor test; see Knuth.   Some 'OK' runs:        1000 1023 998 969 997 1018 1030 1019 1054 985 1003        1011 987 982 980 982 974 968 1044 976        1029 1011 1025 1016 997 1019 991 954 968 999 991        978 1035 995 988 1038 1009 988 993 976"    | nbuckets buckets ntrys slot |    nbuckets := 20.    buckets := Array new: nbuckets.    buckets atAllPut: 0.    ntrys :=  100.    ntrys*nbuckets timesRepeat: [        slot := (randy next * nbuckets) floor + 1.        buckets at: slot put: (buckets at: slot) + 1 ].    Transcript cr.    1 to: nbuckets do: [ :nb |        Transcript show: (buckets at: nb) printString, ' ' ]! !!Random class methodsFor: 'testing'!theItsCompletelyBrokenTest    "Random theItsCompletelyBrokenTest"    "The above should print as...    (0.149243269650845 0.331633021743797 0.75619644800024 0.393701540023881 0.941783181364547 0.549929193942775 0.659962596213428 0.991354559078512 0.696074432551896 0.922987899707159 )    If they are not these values (accounting for precision of printing) then something is horribly wrong: DO NOT USE THIS CODE FOR ANYTHING. "    | rng |    rng := Random new.    rng seed: 2345678901.    ^ (1 to: 10) collect: [:i | rng next]! !!Random class methodsFor: 'instance creation'!new    ^ super new        initialize! !!ReadWriteStream methodsFor: 'fileIn/Out' stamp: 'tk 6/26/97 12:03'!fileInObjectAndCode    "This file may contain:1) a fileIn of code  2) just an object in SmartReferenceStream format 3) both code and an object.    File it in and return the object.  Note that self must be a FileStream or RWBinaryOrTextStream.  Maybe ReadWriteStream incorporate RWBinaryOrTextStream?  tk 6/26/97 11:59"    | refStream object |    self text.    self peek asciiValue = 4        ifTrue: [  "pure object file"            refStream _ SmartRefStream on: self.            object _ refStream nextAndClose]        ifFalse: [  "objects mixed with a fileIn"            self fileIn.  "reads code and objects, then closes the file"            object _ SmartRefStream scannedObject.    "set by side effect of one of the chunks"            SmartRefStream scannedObject: nil].  "clear scannedObject"    ^ object! !!ReadWriteStream methodsFor: 'fileIn/Out' stamp: 'tk 6/26/97 13:27'!fileOutClass: aClassOrChangeSet andObject: anObject    "Write a file that has both code and an object as bits.  tk 6/26/97 12:25"    | class refStream |    self setFileTypeToObject.        "Type and Creator not to be text, so can attach correctly to an email msg"    self header; timeStamp.    aClassOrChangeSet ifNotNil: [        class _ aClassOrChangeSet.    "need to test with changeSet"        class sharedPools size > 0 ifTrue:            [class shouldFileOutPools                ifTrue: [class fileOutSharedPoolsOn: self]].        class fileOutOn: self            moveSource: false            toFile: 0].    self trailer.    "Does nothing for normal files.  HTML streams will have trouble with object data"    "Append the object's raw data"    self cr; cr; nextPutAll: '!!SmartRefStream!!'.    self binary.        "redundant"    refStream _ SmartRefStream on: self.    refStream nextPut: anObject.  "with its morphs"        "Terminator, $!!, is not doubled inside object data"    self ascii.    self nextPutAll: '!!'; cr; cr.    refStream close.        "also closes me"! !!ReadWriteStream methodsFor: 'fileIn/Out' stamp: 'di 7/14/97 22:57'!timeStamp    "Append the current time to the receiver as a String."    self nextChunkPut:    "double string quotes and !!s"        (String streamContents: [:s | Smalltalk timeStamp: s]) printString.    self cr! !!RealEstateAgent class methodsFor: 'as yet unclassified' stamp: 'di 10/24/96'!assignCollapsePointFor: aSSView    "Offer up a location along the left edge of the screen for a collapsed SSView.    Make sure it doesn't overlap any other collapsed frames.    "    | grid extent allOthers y putativeFrame free |    grid _ 24.  "should be mult of 8, since manual move is gridded by 8"    extent _ aSSView labelDisplayBox extent.    allOthers _ ScheduledControllers scheduledWindowControllers                collect: [:aController | aController view collapsedFrame]                thenSelect: [:rect | rect notNil].    y _ 0.    [(y _ y + grid) < (Display height - extent y)]        whileTrue:        [putativeFrame _ 0@y extent: extent.        free _ true.        allOthers do: [:w | free _ free & (w intersects: putativeFrame) not].        free ifTrue: [^ putativeFrame topLeft]].    "If all else fails..."    ^ 0 @ 0! !!RealEstateAgent class methodsFor: 'as yet unclassified' stamp: 'sw 5/22/96'!standardPositions    "Return a list of standard window positions -- this may have one, two, or four of them, depending on the size and shape of the display screen.  "    | anArea aList  midX midY |    anArea _ Display usableArea.    midX _ ScrollBarSetback +   ((anArea width - ScrollBarSetback)  // 2).    midY _ ScreenTopSetback + ((anArea height - ScreenTopSetback) // 2).    aList _ OrderedCollection with: (ScrollBarSetback @ ScreenTopSetback).    self windowColumnsDesired > 1        ifTrue:            [aList add: (midX @ ScreenTopSetback)].    self windowRowsDesired > 1        ifTrue:            [aList add: (ScrollBarSetback @ (midY+ScreenTopSetback)).            self windowColumnsDesired > 1 ifTrue:                [aList add: (midX @ (midY+ScreenTopSetback))]].    ^ aList! !!RealEstateAgent class methodsFor: 'as yet unclassified' stamp: 'sw 5/23/96'!standardWindowExtent    "Answer the standard default extent for new windows.  "    | effectiveExtent width strips height grid allowedArea maxLevel |    effectiveExtent _ Display usableArea extent - (ScrollBarSetback @ ScreenTopSetback).    Preferences reverseWindowStagger ifTrue:        ["NOTE: following copied from strictlyStaggeredInitialFrameFor:"        allowedArea _ ScrollBarSetback @ ScreenTopSetback                        corner: Display usableArea bottomRight.        "Number to be staggered at each corner (less on small screens)"        maxLevel _ allowedArea area > 300000 ifTrue: [3] ifFalse: [2].        "Amount by which to stagger (less on small screens)"        grid _ allowedArea area > 500000 ifTrue: [40] ifFalse: [20].        ^ (allowedArea extent - (grid*(maxLevel+1*2) + (grid//2))) min: 600@400].    width _ (strips _ self windowColumnsDesired) > 1        ifTrue:            [effectiveExtent x // strips]        ifFalse:            [(3 * effectiveExtent x) // 4].    height _ (strips _ self windowRowsDesired) > 1        ifTrue:            [effectiveExtent y // strips]        ifFalse:            [(3 * effectiveExtent y) //4].    ^ width @ height"RealEstateAgent standardWindowExtent"! !!RealEstateAgent class methodsFor: 'as yet unclassified' stamp: 'di 10/24/96'!strictlyStaggeredInitialFrameFor: aStandardSystemView    "This method implements a staggered window placement policy that I like.    Basically it provides for up to 4 windows, staggered from each of the 4 corners.    The windows are staggered so that there will always be a corner visible.    "    | allowedArea grid initialFrame allWindows cornerSel corner delta putativeCorner free maxLevel |    allowedArea _ ScrollBarSetback @ ScreenTopSetback                    corner: Display usableArea bottomRight.    "Number to be staggered at each corner (less on small screens)"    maxLevel _ allowedArea area > 300000 ifTrue: [3] ifFalse: [2].    "Amount by which to stagger (less on small screens)"    grid _ allowedArea area > 500000 ifTrue: [40] ifFalse: [20].    initialFrame _ 0@0 extent: ((aStandardSystemView initialExtent                            "min: (allowedArea extent - (grid*(maxLevel+1*2) + (grid//2))))                            min: 600@400")).    allWindows _ ScheduledControllers scheduledWindowControllers                collect: [:aController | aController view isCollapsed                                ifTrue: [aController view expandedFrame]                                ifFalse: [aController view displayBox]].    0 to: maxLevel do:        [:level |         1 to: 4 do:            [:ci | cornerSel _ #(topLeft topRight bottomRight bottomLeft) at: ci.            corner _ allowedArea perform: cornerSel.            "The extra grid//2 in delta helps to keep title tabs distinct"            delta _ (maxLevel-level*grid+(grid//2)) @ (level*grid).            1 to: ci-1 do: [:i | delta _ delta rotateBy: #right centerAt: 0@0]. "slow way"            putativeCorner _ corner + delta.            free _ true.            allWindows do:                [:w |                free _ free & ((w perform: cornerSel) ~= putativeCorner)].            free ifTrue:                [^ (initialFrame align: (initialFrame perform: cornerSel)                                with: putativeCorner)                         squishedWithin: allowedArea]]].    "If all else fails..."    ^ (ScrollBarSetback @ ScreenTopSetback extent: initialFrame extent)        squishedWithin: allowedArea! !!RecentMessageSet methodsFor: 'as yet unclassified'!accept    ^ super accept! !!RecentMessageSet methodsFor: 'as yet unclassified'!contents: c notifying: n    | result |    result _ super contents: c notifying: n.    result == true ifTrue:        [self initializeMessageList: Utilities recentlySubmittedMessages.        self changed: #messageListChanged].    ^ result! !!RecentMessageSet methodsFor: 'as yet unclassified'!maybeSetSelection    "After a browser's message list is changed, this message is dispatched to the model, to give it a chance to refigure a selection"        self messageListIndex: 1! !!RecordingControlsMorph methodsFor: 'all' stamp: 'jm 9/18/97 19:01'!buttonName: aString action: aSymbol    ^ SimpleButtonMorph new        target: recorder;        label: aString;        actionSelector: aSymbol! !!RecordingControlsMorph methodsFor: 'all' stamp: 'jm 9/18/97 19:05'!done    | m |    recorder stopRecording.    m _ InterimSoundMorph new sound: recorder recordedSound.    self world hands first attachMorph: m.    self delete.! !!RecordingControlsMorph methodsFor: 'all' stamp: 'jm 9/18/97 19:08'!initialize    | r |    super initialize.    borderWidth _ 2.    orientation _ #vertical.    recorder _ SoundRecorder new startRecording.    r _ LayoutMorph newRow vResizing: #shrinkWrap.    r addMorphBack: (self buttonName: 'Clear' action: #clearRecordedSound).    r addMorphBack: ((self buttonName: 'Tile' action: #makeTile) target: self).    r addMorphBack: ((self buttonName: 'Done' action: #done) target: self).    self addMorphBack: r.    r _ LayoutMorph newRow vResizing: #shrinkWrap.    r addMorphBack: (self buttonName: 'Record' action: #resumeRecording).    r addMorphBack: (self buttonName: 'Pause' action: #pause).    r addMorphBack: (self buttonName: 'Play' action: #playback).    r addMorphBack: self makeStatusLight.    self addMorphBack: r.    r _ LayoutMorph newRow vResizing: #shrinkWrap.    r addMorphBack: self makeRecordMeter.    self addMorphBack: r.! !!RecordingControlsMorph methodsFor: 'all' stamp: 'jm 8/24/97 21:31'!makeRecordMeter    | outerBox |    outerBox _ Morph new extent: 102@18; color: Color gray.    recordMeter _ Morph new extent: 1@16; color: Color yellow.    recordMeter position: outerBox topLeft + (1@1).    outerBox addMorph: recordMeter.    ^ outerBox! !!RecordingControlsMorph methodsFor: 'all' stamp: 'jm 8/24/97 21:11'!makeStatusLight    recordingStatusLight _ Morph new extent: 18@18.    recordingStatusLight color: Color green.    ^ recordingStatusLight! !!RecordingControlsMorph methodsFor: 'all' stamp: 'jm 9/18/97 19:09'!makeTile    | m |    m _ InterimSoundMorph new sound: recorder recordedSound.    self world hands first attachMorph: m.! !!RecordingControlsMorph methodsFor: 'all' stamp: 'jm 9/13/97 17:20'!recorder    ^ recorder! !!RecordingControlsMorph methodsFor: 'all' stamp: 'jm 8/24/97 21:31'!step    recorder isPaused        ifTrue: [recordingStatusLight color: Color transparent]        ifFalse: [recordingStatusLight color: Color red].    recordMeter extent: (recorder meterLevel + 1) @ recordMeter height.! !!RecordingControlsMorph methodsFor: 'all' stamp: 'jm 8/24/97 21:00'!stepTime    ^ 50! !!Rectangle methodsFor: 'accessing'!corners    "Return an array of corner points in the order of a quadrilateral spec for WarpBlt."    ^ Array        with: self topLeft        with: self bottomLeft        with: self bottomRight        with: self topRight! !!Rectangle methodsFor: 'accessing'!innerCorners    "Return an array of inner corner points,    ie, the most extreme pixels included,    in the order of a quadrilateral spec for WarpBlt"    | r1 |    r1 _ self topLeft corner: self bottomRight - (1@1).    ^ Array with: r1 topLeft with: r1 bottomLeft with: r1 bottomRight with: r1 topRight! !!Rectangle methodsFor: 'rectangle functions'!areasOutside: aRectangle    "Answer an Array of Rectangles comprising the parts of the receiver not     intersecting aRectangle."    | areas yOrigin yCorner |    "Make sure the intersection is non-empty"    (origin <= aRectangle corner and: [aRectangle origin <= corner])        ifFalse: [^Array with: self].    areas _ OrderedCollection new.    aRectangle origin y > origin y        ifTrue: [areas addLast: (origin corner: corner x @ (yOrigin _ aRectangle origin y))]        ifFalse: [yOrigin _ origin y].    aRectangle corner y < corner y        ifTrue: [areas addLast: (origin x @ (yCorner _ aRectangle corner y) corner: corner)]        ifFalse: [yCorner _ corner y].    aRectangle origin x > origin x         ifTrue: [areas addLast: (origin x @ yOrigin corner: aRectangle origin x @ yCorner)].    aRectangle corner x < corner x         ifTrue: [areas addLast: (aRectangle corner x @ yOrigin corner: corner x @ yCorner)].    ^areas! !!Rectangle methodsFor: 'rectangle functions'!bordersOn: her along: herSide     (herSide = #right and: [self left = her right])    | (herSide = #left and: [self right = her left])        ifTrue:        [^ (self top max: her top) <= (self bottom min: her bottom)].    (herSide = #bottom and: [self top = her bottom])    | (herSide = #top and: [self bottom = her top])        ifTrue:        [^ (self left max: her left) <= (self right min: her right)].    ^ false! !!Rectangle methodsFor: 'rectangle functions'!merge: aRectangle     "Answer a Rectangle that contains both the receiver and aRectangle."    ^Rectangle         origin: (origin min: aRectangle origin)        corner: (corner max: aRectangle corner)! !!Rectangle methodsFor: 'rectangle functions'!quickMerge: aRectangle     "Answer the receiver if it encloses the given rectangle or the merge of the two rectangles if it doesn't. THis method is an optimization to reduce extra rectangle creations."    | useRcvr rOrigin rCorner minX maxX minY maxY |    useRcvr _ true.    rOrigin _ aRectangle topLeft.    rCorner _ aRectangle bottomRight.    minX _ rOrigin x < origin x ifTrue: [useRcvr _ false. rOrigin x] ifFalse: [origin x].    maxX _ rCorner x > corner x ifTrue: [useRcvr _ false. rCorner x] ifFalse: [corner x].    minY _ rOrigin y < origin y ifTrue: [useRcvr _ false. rOrigin y] ifFalse: [origin y].    maxY _ rCorner y > corner y ifTrue: [useRcvr _ false. rCorner y] ifFalse: [corner y].    useRcvr        ifTrue: [^ self]        ifFalse: [^ Rectangle origin: minX@minY corner: maxX@maxY].! !!Rectangle methodsFor: 'rectangle functions'!withBottom: y     "Return a copy of me with a different bottom y"    ^ origin x @ origin y corner: corner x @ y! !!Rectangle methodsFor: 'rectangle functions'!withHeight: height     "Return a copy of me with a different height"    ^ origin corner: corner x @ (origin y + height)! !!Rectangle methodsFor: 'rectangle functions'!withLeft: x     "Return a copy of me with a different left x"    ^ x @ origin y corner: corner x @ corner y! !!Rectangle methodsFor: 'rectangle functions'!withRight: x     "Return a copy of me with a different right x"    ^ origin x @ origin y corner: x @ corner y! !!Rectangle methodsFor: 'rectangle functions'!withSide: side setTo: value  "return a copy with side set to value"    ^ self perform: (#(withLeft: withRight: withTop: withBottom: )                            at: (#(left right top bottom) indexOf: side))        with: value! !!Rectangle methodsFor: 'rectangle functions'!withTop: y     "Return a copy of me with a different top y"    ^ origin x @ y corner: corner x @ corner y! !!Rectangle methodsFor: 'rectangle functions'!withWidth: width     "Return a copy of me with a different width"    ^ origin corner: (origin x + width) @ corner y! !!Rectangle methodsFor: 'testing'!containsRect: aRect    "Answer whether aRect is within the receiver (OK to coincide)."    ^ aRect origin >= origin and: [aRect corner <= corner]! !!Rectangle methodsFor: 'testing'!isTall    ^ self height > self width! !!Rectangle methodsFor: 'testing'!isWide    ^ self width > self height! !!Rectangle methodsFor: 'truncation and round off' stamp: 'jm 9/21/97 18:09'!truncated    "Answer a Rectangle whose origin and corner have any fractional parts removed."    (origin x isInteger and:    [origin y isInteger and:    [corner x isInteger and:    [corner y isInteger]]])        ifTrue: [^ self].    ^ Rectangle origin: origin truncated corner: corner truncated! !!Rectangle methodsFor: 'transforming' stamp: 'di 6/11/97 16:24'!flipBy: direction centerAt: aPoint     "Return a copy flipped #vertical or #horizontal, about aPoint."    ^ (origin flipBy: direction centerAt: aPoint)        rect: (corner flipBy: direction centerAt: aPoint)! !!Rectangle methodsFor: 'transforming' stamp: 'di 6/11/97 15:11'!rotateBy: direction centerAt: aPoint    "Return a copy rotated #right, #left, or #pi about aPoint"    ^ (origin rotateBy: direction centerAt: aPoint)        rect: (corner rotateBy: direction centerAt: aPoint)! !!Rectangle methodsFor: 'transforming'!scaleFrom: rect1 to: rect2    "Produce a rectangle stretched according to the stretch from rect1 to rect2"    ^ (origin scaleFrom: rect1 to: rect2)        corner: (corner scaleFrom: rect1 to: rect2)! !!Rectangle methodsFor: 'transforming' stamp: 'sw 5/21/96'!squishedWithin: aRectangle    "Return an adjustment of the receiver that fits within aRectangle by reducing its size, not by changing its origin.  "    ^ origin corner: (corner min: aRectangle bottomRight)"(50 @ 50 corner: 160 @ 100) squishedWithin:  (20 @ 10 corner: 90 @ 85)"! !!Rectangle methodsFor: 'printing' stamp: 'sw 12/9/96'!display: c     "Display the receiver filling it with the given color; by Alan Kay.  Used by his mini painting system, 1/96.    : fixed so it doesn't always draw a square!!"    | p |    p _ Pen new.    p color: c.    p place: self origin.    1 to: 2 do:        [:i | p turn: 90; go: self width.        p turn: 90; go: self height]! !!Rectangle methodsFor: 'private'!setOrigin: topLeft corner: bottomRight    origin _ topLeft.    corner _ bottomRight! !!Rectangle class methodsFor: 'instance creation' stamp: 'tk 3/9/97'!center: centerPoint extent: extentPoint     "Answer an instance of me whose center is centerPoint and width     by height is extentPoint.  "    ^self origin: centerPoint - (extentPoint//2) extent: extentPoint! !!Rectangle class methodsFor: 'instance creation'!left: leftNumber right: rightNumber top: topNumber bottom: bottomNumber     "Answer an instance of me whose left, right, top, and bottom coordinates     are determined by the arguments."    ^ self new setOrigin: leftNumber @ topNumber corner: rightNumber @ bottomNumber! !!Rectangle class methodsFor: 'instance creation'!origin: originPoint corner: cornerPoint     "Answer an instance of me whose corners (top left and bottom right) are     determined by the arguments."    ^self new setOrigin: originPoint corner: cornerPoint! !!Rectangle class methodsFor: 'instance creation'!origin: originPoint extent: extentPoint     "Answer an instance of me whose top left corner is originPoint and width     by height is extentPoint."    ^self new setOrigin: originPoint corner: originPoint + extentPoint! !!RectangleMorph methodsFor: 'initialization' stamp: 'di 6/20/97 11:24'!initialize    super initialize.    color _ Color gray.! !!RectangleMorphTemp methodsFor: 'as yet unclassified' stamp: 'jm 8/23/97 19:02'!handlesMouseDown: evt    ^ true! !!RectangleMorphTemp methodsFor: 'as yet unclassified' stamp: 'jm 8/23/97 23:02'!mouseDown: evt    Smalltalk beep.    self beep.! !ReferenceStream comment:'This is an interim save-to-disk facility. A ReferenceStream can storeone or more objects in a persistent form, including sharing andcycles. Cf. DataStream.Here is the way to use DataStream and ReferenceStream:    rr _ ReferenceStream fileNamed: ''test.obj''.    rr nextPut: <your object>.    rr close.To get it back:    rr _ ReferenceStream fileNamed: ''test.obj''.    <your object> _ rr next.    rr close.ReferenceStreams can now write "weak" references. nextPutWeak:writes a "weak" reference to an object, which refers to that object*if* it also gets written to the stream by a normal nextPut:.Public messages:    resetPublic inherited messages (see DataStream)    (class) on:    (class) fileNamed:    (class) fileTypeCode    atEnd    beginInstance:size: (for use by storeDataOn: methods)    beginReference: (for use by readDataFrom:size: methods)    close    next    next:    nextPut:    nextPutAll:    nextPutWeak:    setType:    shorten    sizeNOTE: A ReferenceStream should be treated as a read-stream *or* as awrite-stream, *not* as a read/write-stream. The reference-rememberingmechanism would probably do bad things if you tried to read and writefrom the same ReferenceStream.[TBD] Should we override "close" to do    self forgetReferences. super close?Instance variables references -- an IdentityDictionary mapping objects already written    to their byteStream positions. If asked to write any object a    second time, we just write a reference to its stream position.    This handles shared objects and reference cycles between objects.    To implement "weak references" (for Aliases), the references    dictionary also maps objects not (yet?) written to a Collection    of byteStream positions with hopeful weak-references to it. If    asked to definitely write one of these objects, we''ll fixup those    weak references. objects -- an IdentityDictionary mapping relative byte stream positions to    objects already read in. If asked to follow a reference, we    return the object already read.    This handles shared objects and reference cycles between objects. currentReference -- the current reference position. Positon relative to the     start of object data in this file.  (Allows user to cut and paste smalltalk     code from the front of the file without effecting the reference values.)      This variable is used to help install each new object in "objects" as soon    as it''s created, **before** we start reading its contents, in    case any of its content objects reference it. fwdRefEnds -- A weak reference can be a forward reference, which    requires advance-reading the referrent. When we later come to the    object, we must get its value from "objects" and not re-read it so    refs to it don''t become refs to copies. fwdRefEnds remembers the    ending byte stream position of advance-read objects. transients -- an IdentitySet of byte stream positions corresponding    to objects that we''ve started to read in (and already added to    "objects" in case of reference cycles) but haven''t yet handed out    OOPs for. If we hand out an OOP to one of these interim OOPs, and    if internalizing it (comeFullyUpOnReload) returns a different OOP,    then we must ask it to #become: the new OOP. Tracking the interim    OOPs handed out lets us save most calls to (costly) #become:.-- 11/17/92 jhm'!!ReferenceStream methodsFor: 'all' stamp: 'jm 7/31/97 16:17'!beginInstance: aClass size: anInteger    "This is for use by storeDataOn: methods.  Cf. Object>>storeDataOn:."    "Addition of 1 seems to make extra work, since readInstance has to compensate.  Here for historical reasons dating back to Kent Beck's original implementation in late 1988.    In ReferenceStream, class is just 5 bytes for shared symbol.    SmartRefStream puts out the names and number of class's instances variables for checking.6/10/97 16:09 tk: See if we can put on a short header. Type = 16. "    | short ref |    short _ true.    "All tests for object header that can be written in 4 bytes"    anInteger <= 254 ifFalse: [short _ false].    "one byte size"    ref _ references at: aClass name ifAbsent: [short _ false. nil].    short & (ref isInteger) ifTrue: [short _ (ref < 65536) & (ref > 0)].    short ifTrue: [        byteStream skip: -1.        short _ byteStream next = 9.        byteStream skip: 0].    "ugly workaround"    short         ifTrue: ["passed all the tests!!"            byteStream skip: -1; nextPut: 16; "type = short header"                nextPut: anInteger + 1;    "size is short"                nextNumber: 2 put: ref]        ifFalse: [            "default to normal longer object header"            byteStream nextNumber: 4 put: anInteger + 1.            self nextPut: aClass name].! !!ReferenceStream methodsFor: 'all' stamp: '6/9/97 08:25 tk'!beginReference: anObject    "Remember anObject as the object we read at the position recorded by     noteCurrentReference:. This must be done after instantiating anObject but     before reading any of its contents that might (directly or indirectly) refer to     it. (It's ok to do this redundantly, which is convenient for #next.)     Answer the reference position. -- jhm"    objects at: currentReference put: anObject.    "relative to start of data portion of file"    ^ currentReference        "relative position"! !!ReferenceStream methodsFor: 'all' stamp: '6/9/97 08:26 tk'!getCurrentReference    "PRIVATE -- Return the currentReference posn.  Always a relative position.  So user can cut and paste the Smalltalk source code at the beginning of the file."    ^ currentReference    "relative position"! !!ReferenceStream methodsFor: 'all' stamp: 'tk 8/14/96'!internalize: externalObject    "PRIVATE -- We just read externalObject. Give it a chance to internalize. Return the internalized object.     If become: is expensive, we could use it less often. It's needed when we've already given out references to the object being read (while recursively reading its contents).  In other cases, we could just change the entry in the objects Dictionary.    If an object is pointed at from inside itself, then it cannot have a different external and internal form.  It cannot be a PathFromHome or return anything other than self when sent comeFullyUpOnReload. (DiskProxy is OK)    Objects that do return something other than self when sent comeFullyUpOnReload must not point to themselves, even indirectly.        Allowin the use of DiskProxy for shared sysem objects.  "    | internalObject |    internalObject _ externalObject comeFullyUpOnReload.    (self isAReferenceType: (self typeIDFor: internalObject))            ifTrue: [self beginReference: internalObject].            "save the final object and give it out next time.  Substitute for become"    ^ internalObject"This code was removed.  I don't understand it.      (externalObject ~~ internalObject and: [externalObject isKindOf: DiskProxy])        ifTrue: [externalObject become: internalObject]        ifFalse: [(self isAReferenceType:(self typeIDFor: internalObject))            ifTrue: [self beginReference: internalObject]]."! !!ReferenceStream methodsFor: 'all' stamp: '6/9/97 09:02 tk'!next    "Answer the next object in the stream. If this object was already read by a     forward ref, don't re-read it. Cf. class comment. -- 11/18-24/92 jhm"    | curPosn skipToPosn |    "Did we already read the next object? If not, use ordinary super next."    skipToPosn _ fwdRefEnds removeKey: (curPosn _ byteStream position - basePos)                             ifAbsent: [nil].    skipToPosn ifNil: [^ super next].        "Compared to ifAbsent: [^ super next], this saves 2 stack frames per cycle         in the normal case of this deep recursion. This is mainly a debugging aid         but it also staves off stack overflow."    "Skip over the object and return the already-read-in value from 'object'."    byteStream position: skipToPosn + basePos.    "make absolute"    ^ objects at: curPosn ifAbsent: [self errorInternalInconsistency]! !!ReferenceStream methodsFor: 'all' stamp: 'jhm 11/15/92'!nextPutWeak: anObject    "Write a weak reference to anObject to the receiver stream. Answer anObject.     If anObject is not a reference type of object, then just put it normally.     A 'weak' reference means: If anObject gets written this stream via nextPut:,     then its weak references will become normal references. Otherwise they'll     read back as nil. -- "    | typeID referencePosn |    "Is it a reference type of object? If not, just write it normally."    typeID _ self typeIDFor: anObject.    (self isAReferenceType: typeID) ifFalse: [^ self nextPut: anObject].    "Have we heard of and maybe even written anObject before?"    referencePosn _ references at: anObject ifAbsent: [            references at: anObject put: OrderedCollection new].    "If referencePosn is an Integer, it's the stream position of anObject.     Else it's a collection of hopeful weak-references to anObject."    referencePosn isInteger ifFalse:        [referencePosn add: byteStream position - basePos.        "relative"        referencePosn _ self vacantRef].    self outputReference: referencePosn.        "relative"    ^ anObject! !!ReferenceStream methodsFor: 'all' stamp: '6/9/97 09:00 tk'!noteCurrentReference: typeID    "PRIVATE -- If we support references for type typeID, remember     the current byteStream position so beginReference: can add the     next object to the 'objects' dictionary of reference positions,     then return true. Else return false."    | answer |    (answer _ self isAReferenceType: typeID)        ifTrue: [self setCurrentReference: (byteStream position - 1) - basePos "relative"                "subtract 1 because we already read the object's type ID byte"].    ^ answer! !!ReferenceStream methodsFor: 'all' stamp: ' 6/9/97'!objectAt: anInteger    "PRIVATE -- Read & return the object at a given stream position.     If we already read it, just get it from the objects dictionary.     (Reading it again wouldn't work with cycles or sharing.)     If not, go read it and put it in the objects dictionary.     NOTE: This resolves a cross-reference in the ReferenceStream:       1. A backward reference to an object already read (the normal case).       2. A forward reference which is a sated weak reference (we record where          the object ends so when we get to it normally we can fetch it from          'objects' and skip over it).       3. A backward reference to a 'non-reference type' per the long NOTE in          nextPut: (we compensate here--seek back to re-read it and add the object          to 'objects' to avoid seeking back to read it any more times).       4. While reading a foward weak reference (case 2), we may recursively hit an          ordinary backward reference to an object that we haven't yet read because          we temporarily skipped ahead. Such a reference is forward in time so we          treat it much like case 2.     11/16-24/92 jhm: Handle forward refs. Cf. class comment and above NOTE.    08:57 tk   anInteger is a relative position"    | savedPosn refPosn anObject |    ^ objects at: anInteger "relative position.  case 1: It's in 'objects'"        ifAbsent:   "do like super objectAt:, but remember the fwd-ref-end position"            [savedPosn _ byteStream position.        "absolute"            refPosn _ self getCurrentReference.    "relative position"            byteStream position: anInteger + basePos.    "was relative"            anObject _ self next.            (self isAReferenceType: (self typeIDFor: anObject))                ifTrue:  [fwdRefEnds at: anInteger put: byteStream position - basePos] "cases 2, 4"                ifFalse: [objects at: anInteger put: anObject]. "case 3"            self setCurrentReference: refPosn.        "relative position"            byteStream position: savedPosn.        "absolute"            anObject]! !!ReferenceStream methodsFor: 'all' stamp: '6/9/97 08:24 tk'!setCurrentReference: refPosn    "PRIVATE -- Set currentReference to refPosn.  Always a relative position."    currentReference _ refPosn        "relative position"! !!ReferenceStream methodsFor: 'all' stamp: ' 6/9/97'!tryToPutReference: anObject typeID: typeID    "PRIVATE -- If we support references for type typeID, and if       anObject already appears in my output stream, then put a       reference to the place where anObject already appears. If we       support references for typeID but didn't already put anObject,       then associate the current stream position with anObject in       case one wants to nextPut: it again.     Return true after putting a reference; false if the object still       needs to be put.     : Added support for weak refs. Split out outputReference:.    08:42 tk  references stores relative file positions."    | referencePosn nextPosn |    "Is it a reference type of object?"    (self isAReferenceType: typeID) ifFalse: [^ false].    "Have we heard of and maybe even written anObject before?"    referencePosn _ references at: anObject ifAbsent:            ["Nope. Remember it and let the sender write it."            references at: anObject put: (byteStream position - basePos).    "relative"            ^ false].    "If referencePosn is an Integer, it's the stream position of anObject."    referencePosn isInteger ifTrue:        [self outputReference: referencePosn.    "relative"        ^ true].    "Else referencePosn is a collection of positions of weak-references to anObject.     Make them full references since we're about to really write anObject."    references at: anObject put: (nextPosn _ byteStream position) - basePos.    "store relative"    referencePosn do: [:weakRefPosn |            byteStream position: weakRefPosn + basePos.        "make absolute"            self outputReference: nextPosn - basePos].    "make relative"    byteStream position: nextPosn.        "absolute"    ^ false! !!ReferenceStream class methodsFor: 'all' stamp: 'sw 12/2/92'!versionCode    "Answer a number representing the 'version' of the ReferenceStream facility; this is stashed at the beginning of ReferenceStreams, as a secondary versioning mechanism (the primary one is the fileTypeCode).   At present, it serves for information only, and is not checked for compatibility at reload time, but could in future be used to branch to variant code. "    " 1 = original version 1992"    " 2 = HyperSqueak.  PathFromHome used for Objs outside the tree.  SqueakSupport SysLibrary for shared globals like Display and StrikeFonts.  File has version number, class structure, then an IncomingObjects manager.  8/16/96 tk.      Extended to SmartRefStream.  class structure also keeps superclasse chain.  Does analysis on structure to see when translation methods are needed.  Embedable in file-ins.  (factored out HyperSqueak support)  Feb-May 97 tk"    " 3 = Reference objects are byte offsets relative to the start of the object portion of the file.  Rectangles with values -2048 to 2047 are encoded compactly."    ^ 3! !!RemoteHandMorph methodsFor: 'initialization' stamp: 'jm 9/25/97 09:30'!initialize    super initialize.    remoteWorldExtent _ 100@100.  "initial guess"    socket _ nil.    waitingForConnection _ false.    receiveBuffer _ ''.! !!RemoteHandMorph methodsFor: 'meta menu' stamp: 'jm 9/26/97 09:45'!connectRemoteUser    "This menu command does nothing when invoked by a RemoteHandMorph."! !!RemoteHandMorph methodsFor: 'meta menu' stamp: 'jm 9/26/97 10:16'!disconnectAllRemoteUsers    "This menu command does nothing when invoked by a RemoteHandMorph."! !!RemoteHandMorph methodsFor: 'meta menu' stamp: 'jm 9/26/97 09:45'!disconnectRemoteUser    "This menu command does nothing when invoked by a RemoteHandMorph."! !!RemoteHandMorph methodsFor: 'connections' stamp: 'jm 9/26/97 11:31'!remoteHostAddress    "Return the address of the remote host or zero if not connected."    (socket ~~ nil and: [socket isUnconnectedOrInvalid not])        ifTrue: [^ socket remoteAddress]        ifFalse: [^ 0].! !!RemoteHandMorph methodsFor: 'connections' stamp: 'jm 9/26/97 11:03'!startListening    "Create a socket and start listening for a connection."    self stopListening.    Transcript show: 'My address is ', NetNameResolver localAddressString; cr.    Transcript show: 'Remote hand ', userInitials, ' waiting for a connection...'; cr.    socket _ Socket new.    socket listenOn: 54323.    waitingForConnection _ true.! !!RemoteHandMorph methodsFor: 'connections'!stopListening    "Destroy the socket, if any, terminating the connection."    socket ifNotNil: [        socket destroy.        socket _ nil].! !!RemoteHandMorph methodsFor: 'other' stamp: 'jm 9/26/97 10:22'!drawOn: aCanvas    "For remote cursors, always draw the hand itself (i.e., the cursor)."    super drawOn: aCanvas.    aCanvas image: NormalCursor at: self position.! !!RemoteHandMorph methodsFor: 'other' stamp: 'jm 9/25/97 09:31'!processEvents    "Process user input events from the remote input devices."    | evt |    evt _ self getNextRemoteEvent.    [evt ~~ nil] whileTrue: [        evt type == #worldExtent ifTrue: [            remoteWorldExtent _ evt cursorPoint.            ^ self].        (evt yellowButtonPressed and:         [lastEvent yellowButtonPressed not]) ifTrue: [            lastEvent _ evt.            ^ self invokeMetaMenu: evt].        self handleEvent: evt.        lastEvent _ evt.        evt _ self getNextRemoteEvent].! !!RemoteHandMorph methodsFor: 'other' stamp: 'jm 9/26/97 09:42'!withdrawFromWorld    "Close the socket, if any, and remove this hand from the world."    self stopListening.    Transcript show: 'Remote hand ', userInitials, ' closed'; cr.    owner ifNotNil: [owner removeHand: self].! !!RemoteHandMorph methodsFor: 'other' stamp: 'jm 9/25/97 09:33'!worldBounds    ^ 0@0 extent: remoteWorldExtent! !!RemoteHandMorph methodsFor: 'private' stamp: 'jm 9/24/97 11:58'!appendNewDataToReceiveBuffer    "Append all available raw data to my receive buffer. Assume that my socket is not nil."    | newData tempBuf bytesRead |    socket dataAvailable ifTrue: [        "get all the data currently available"        newData _ WriteStream on: (String new: receiveBuffer size + 1000).        newData nextPutAll: receiveBuffer.        tempBuf _ String new: 1000.        [socket dataAvailable] whileTrue: [            bytesRead _ socket receiveDataInto: tempBuf.            1 to: bytesRead do: [:i | newData nextPut: (tempBuf at: i)]].        receiveBuffer _ newData contents].! !!RemoteHandMorph methodsFor: 'private' stamp: 'jm 9/26/97 10:23'!getNextRemoteEvent    "Return the next remote event, or nil if the receive buffer does not contain a full event record. An event record is the storeString for a MorphicEvent terminated by a <CR> character."    | i s |    self receiveData.    receiveBuffer isEmpty ifTrue: [^ nil].    i _ receiveBuffer indexOf: Character cr ifAbsent: [^ nil].    s _ receiveBuffer copyFrom: 1 to: i - 1.    receiveBuffer _ receiveBuffer copyFrom: i + 1 to: receiveBuffer size.    ^ (MorphicEvent readFromString: s) setHand: self! !!RemoteHandMorph methodsFor: 'private' stamp: 'jm 9/26/97 09:40'!receiveData    "Check my connection status and withdraw from the world if the connection has been broken. Append any data that has arrived to receiveBuffer. "    socket ifNotNil: [        socket isConnected            ifTrue: [  "connected"                waitingForConnection ifTrue: [                    Transcript show: 'Remote hand ', userInitials, ' connected'; cr.                    waitingForConnection _ false].                self appendNewDataToReceiveBuffer]            ifFalse: [  "not connected"                waitingForConnection ifFalse: [                    "connection was established, then broken"                    self withdrawFromWorld.                    receiveBuffer _ '']]].! !!RemoteHandMorph class methodsFor: 'instance creation' stamp: 'di 6/22/97 09:07'!includeInNewMorphMenu    "Not to be instantiated from the menu"    ^ false! !!RemoteString methodsFor: 'accessing'!position     "Answer the location of the string on a file."    ^ filePositionHi! !!RemoteString methodsFor: 'accessing'!string     "Answer the receiver's string if remote files are enabled."    | theFile |    (sourceFileNumber == nil or: [(SourceFiles at: sourceFileNumber) == nil]) ifTrue: [^''].    theFile _ SourceFiles at: sourceFileNumber.    theFile position: filePositionHi.    ^ theFile nextChunk! !!RemoteString methodsFor: 'private'!fileNumber: fileNumber position: position     sourceFileNumber _ fileNumber.    filePositionHi _ position! !!RemoteString methodsFor: 'private'!string: aString onFileNumber: fileNumber    "Store this as my string if source files exist."    | theFile |    (SourceFiles at: fileNumber) == nil ifFalse:         [theFile _ SourceFiles at: fileNumber.        theFile setToEnd; cr.        self string: aString onFileNumber: fileNumber toFile: theFile]! !!RemoteString methodsFor: 'private'!string: aString onFileNumber: fileNumber toFile: aFileStream     "Store this as the receiver's string if source files exist."    | position |    position _ aFileStream position.    self fileNumber: fileNumber position: position.    aFileStream nextChunkPut: aString! !!RepeatingSound methodsFor: 'initialization' stamp: 'jm 9/12/97 15:54'!setPitch: p dur: d loudness: l    self error: 'RepeatingSounds do not support playing notes'.! !!RepeatingSound methodsFor: 'initialization' stamp: 'jm 9/12/97 16:39'!setSound: aSound iterations: anIntegerOrSymbol    "Initialize the receiver to play the given sound the given number of times. If iteration count is the symbol #forever, then repeat indefinitely."    "(RepeatingSound repeat: AbstractSound scaleTest count: 2) play"    "(RepeatingSound repeatForever: PluckedSound lowMajorScale) play"    super initialize.    sound _ aSound.    iterationCount _ anIntegerOrSymbol.    self reset.! !!RepeatingSound methodsFor: 'sound generation' stamp: 'jm 9/12/97 15:54'!doControl    sound doControl.! !!RepeatingSound methodsFor: 'sound generation' stamp: 'jm 9/12/97 16:08'!mixSampleCount: n into: aSoundBuffer startingAt: startIndex pan: pan    "Play a collection of sounds in sequence."    "(RepeatingSound new        setSound: BoinkSound majorScale        iterations: 2) play"    | i count samplesNeeded |    iteration <= 0 ifTrue: [^ self].    i _ startIndex.    samplesNeeded _ n.    [samplesNeeded > 0] whileTrue: [        count _ sound samplesRemaining min: samplesNeeded.        count = 0 ifTrue: [            iterationCount == #forever                ifFalse: [                    iteration _ iteration - 1.                    iteration <= 0 ifTrue: [^ self]].  "done"            sound reset.            count _ sound samplesRemaining min: samplesNeeded.            count = 0 ifTrue: [^ self]].  "zero length sound"        sound mixSampleCount: count into: aSoundBuffer startingAt: i pan: pan.        i _ i + count.        samplesNeeded _ samplesNeeded - count].! !!RepeatingSound methodsFor: 'sound generation' stamp: 'jm 9/12/97 16:09'!reset    super reset.    sound reset.    iterationCount == #forever        ifTrue: [iteration _ 1]        ifFalse: [iteration _ iterationCount].! !!RepeatingSound methodsFor: 'sound generation' stamp: 'jm 9/12/97 16:09'!samplesRemaining    iteration > 0        ifTrue: [^ 1000000]        ifFalse: [^ 0].! !!RepeatingSound methodsFor: 'copying' stamp: 'jm 10/4/97 16:48'!copy    "Copy my component sound."    ^ self clone copySound! !!RepeatingSound methodsFor: 'copying' stamp: 'jm 10/4/97 16:48'!copySound    "Private!! Support for copying."    sound _ sound copy.! !!RepeatingSound class methodsFor: 'instance creation' stamp: 'jm 9/12/97 16:14'!repeat: aSound count: anInteger    "Return a RepeatingSound that will repeat the given sound for the given number of iterations."    ^ self new setSound: aSound iterations: anInteger! !!RepeatingSound class methodsFor: 'instance creation' stamp: 'jm 9/12/97 16:13'!repeatForever: aSound    "Return a RepeatingSound that will repeat the given sound forever."    ^ self new setSound: aSound iterations: #forever! !!ResizeHandle methodsFor: 'as yet unclassified' stamp: '6/11/97 06:19 di'!initialize    super initialize.    self extent: 8@8.    self color: Color yellow.    self on: #mouseStillDown send: #doGrow: to: self;        on: #mouseUp send: #delete to: self.! !!ResizeHandle methodsFor: 'as yet unclassified' stamp: '6/10/97 17:43 jm'!justDroppedInto: aMorph event: anEvent    self delete.! !!ResizeHandle methodsFor: 'as yet unclassified' stamp: '6/10/97 17:41 jm'!setTargetMorph: aMorph    targetMorph _ aMorph.    aMorph isLayoutMorph        ifTrue: [minExtent _ aMorph minWidth @ aMorph minHeight]        ifFalse: [minExtent _ 1@1].    self position: aMorph fullBounds bottomRight - (self extent // 2).! !!ResizeHandle methodsFor: 'as yet unclassified' stamp: '6/10/97 17:44 jm'!step    | newExtent |    targetMorph ifNotNil: [        newExtent _ (self center - targetMorph bounds topLeft) max: minExtent.        targetMorph extent: newExtent].! !!ResizeHandle methodsFor: 'as yet unclassified' stamp: '6/10/97 17:44 jm'!stepTime    "Update every cycle."    ^ 0! !!RestSound methodsFor: 'copying' stamp: 'jm 10/4/97 16:49'!copy    ^ self clone! !!RestSound class methodsFor: 'instance creation' stamp: 'jm 9/12/97 15:54'!dur: d    "Return a rest of the given duration."    ^ self basicNew setDur: d! !!ReturnNode methodsFor: 'C translation'!asTranslatorNode    ^TReturnNode new setExpression: expr asTranslatorNode! !!RulerMorph methodsFor: 'all'!drawOn: aCanvas    | s |    super drawOn: aCanvas.    s _ self width printString, 'x', self height printString.    aCanvas text: s bounds: (bounds insetBy: borderWidth + 5) font: nil color: Color red.! !!RulerMorph methodsFor: 'all'!initialize    super initialize.    self color: (Color r: 0.8 g: 1.0 b: 1.0).    self borderWidth: 1.! !!RunArray methodsFor: 'accessing'!at: index    self at: index setRunOffsetAndValue: [:run :offset :value | ^value]! !!RunArray methodsFor: 'accessing'!runLengthAt: index     "Answer the length remaining in run beginning at index."    self at: index         setRunOffsetAndValue: [:run :offset :value | ^(runs at: run) - offset]! !!RunArray methodsFor: 'copying'!copyFrom: start to: stop    | newRuns |    stop < start ifTrue: [^RunArray new].    self at: start setRunOffsetAndValue: [:run1 :offset1 :value1 | value1].    self at: stop setRunOffsetAndValue: [:run2 :offset2 :value2 | value2].    run1 = run2        ifTrue:             [newRuns _ Array with: offset2 - offset1 + 1]        ifFalse:             [newRuns _ runs copyFrom: run1 to: run2.            newRuns at: 1 put: (newRuns at: 1) - offset1.            newRuns at: newRuns size put: offset2 + 1].    ^RunArray runs: newRuns values: (values copyFrom: run1 to: run2)! !!RunArray methodsFor: 'printing'!printOn: aStream    aStream nextPutAll: self class name.    aStream nextPutAll: ' runs: '.    runs printOn: aStream.    aStream nextPutAll: ' values: '.    values printOn: aStream.! !!RunArray methodsFor: 'private'!mapValues: mapBlock    "NOTE: only meaningful to an entire set of runs"    values _ values collect: [:val | mapBlock value: val]! !RWBinaryOrTextStream class comment:'A simulation of a FileStream, but living totally in memory.  Need to be able to switch between binary and text, as a FileStream does, without recopying the whole collection.  Convert upon input and output.  Always keep as text internally.'!!RWBinaryOrTextStream methodsFor: 'all' stamp: 'tk 6/25/97 13:22'!ascii    isBinary _ false! !!RWBinaryOrTextStream methodsFor: 'all' stamp: 'tk 6/20/97 19:46'!binary    isBinary _ true! !!RWBinaryOrTextStream methodsFor: 'all' stamp: 'tk 6/21/97 12:49'!contents    "Answer with a copy of my collection from 1 to readLimit."    | newArray |    isBinary ifFalse: [^ super contents].    "String"    readLimit _ readLimit max: position.    newArray _ ByteArray new: readLimit.    ^ newArray replaceFrom: 1        to: readLimit        with: collection        startingAt: 1.! !!RWBinaryOrTextStream methodsFor: 'all' stamp: 'jm 10/4/97 15:58'!contentsOfEntireFile    "For compatibility with file streams."    ^ self contents! !!RWBinaryOrTextStream methodsFor: 'all' stamp: 'tk 6/20/97 19:47'!isBinary    ^ isBinary! !!RWBinaryOrTextStream methodsFor: 'all' stamp: 'tk 6/20/97 20:11'!next    ^ isBinary ifTrue: [super next asciiValue]            ifFalse: [super next].! !!RWBinaryOrTextStream methodsFor: 'all' stamp: 'tk 6/21/97 12:51'!next: anInteger     "Answer the next anInteger elements of my collection. Must override to get class right."    | newArray |    newArray _ (isBinary ifTrue: [ByteArray] ifFalse: [String]) new: anInteger.    1 to: anInteger do: [:index | newArray at: index put: self next].        "Could be done faster than this!!"    ^newArray! !!RWBinaryOrTextStream methodsFor: 'all' stamp: 'tk 6/20/97 07:38'!nextPut: charOrByte    super nextPut: charOrByte asCharacter! !!RWBinaryOrTextStream methodsFor: 'all' stamp: 'tk 6/21/97 13:04'!reset    "Set the receiver's position to the beginning of the sequence of objects."    super reset.    isBinary ifNil: [isBinary _ false].    collection class == ByteArray ifTrue: ["Store as String and convert as needed."        collection _ collection asString.        isBinary _ true].! !!RWBinaryOrTextStream methodsFor: 'all' stamp: 'tk 6/20/97 19:47'!text    isBinary _ false! !!SampledSound methodsFor: 'initialization' stamp: 'jm 9/12/97 21:24'!setPitch: p dur: d loudness: l    "Used to play scores using the default sample table."    "(SampledSound pitch: 880.0 dur: 1.5 loudness: 500) play"    samples _ DefaultSampleTable.    samplesSize _ samples size.    initialCount _ (d * self samplingRate asFloat) rounded.    originalSamplingRate _        ((self samplingRate asFloat * p asFloat) / NominalSamplePitch asFloat) asInteger.    self reset.! !!SampledSound methodsFor: 'initialization' stamp: 'jm 9/12/97 17:19'!setSamples: anArray    "There are two ways to use sampled sound: (a) you can play them through once (supported by this method) or (b) you can make them the default waveform with which to play a musical score (supported by the class method defaultSamplesFromAIFF:samplePitch:)."    "(SampledSound new setSamples: SampledSound coffeeCupClink) play"    self setSamples: anArray samplingRate: self samplingRate.! !!SampledSound methodsFor: 'initialization' stamp: 'jm 9/17/97 12:45'!setSamples: anArray samplingRate: rate    "Set my samples array to the given array with the given nominal sampling rate. Altering the rate parameter allows one to playback the sampled sound at different pitches."    "Assume: anArray contains signed 16-bit samples."    "(SampledSound        samples: SampledSound coffeeCupClink        samplingRate: 5000) play"    "copy the array into a SoundBuffer if necessary"    anArray class isWords        ifTrue: [samples _ anArray]        ifFalse: [samples _ SoundBuffer fromArray: anArray].    samplesSize _ samples size.    originalSamplingRate _ rate.    initialCount _ (samplesSize * self samplingRate) // originalSamplingRate.    self reset.! !!SampledSound methodsFor: 'playing' stamp: 'jm 10/4/97 16:28'!mixSampleCount: n into: aSoundBuffer startingAt: startIndex pan: pan    "Mix the given number of samples with the samples already in the given buffer starting at the given index. Assume that the buffer size is at least (index + count) - 1. The pan parameter determines the left-right balance of the sound, where 0 is left only, 1000 is right only, and 500 is centered."    | lastIndex i thisSample channelIndex sample sampleIndex |    <primitive: 179>    self var: #aSoundBuffer declareC: 'short int *aSoundBuffer'.    self var: #samples declareC: 'short int *samples'.    lastIndex _ (startIndex + n) - 1.    i _ startIndex.    sampleIndex _ indexTimes1000 // 1000.    [(sampleIndex <= samplesSize) and: [i <= lastIndex]] whileTrue: [        thisSample _ samples at: sampleIndex.        pan > 0 ifTrue: [            channelIndex _ 2 * i.            sample _ (aSoundBuffer at: channelIndex) + ((thisSample * pan) // 1000).            sample >  32767 ifTrue: [ sample _  32767 ].  "clipping!!"            sample < -32767 ifTrue: [ sample _ -32767 ].  "clipping!!"            aSoundBuffer at: channelIndex put: sample.        ].        pan < 1000 ifTrue: [            channelIndex _ (2 * i) - 1.            sample _ (aSoundBuffer at: channelIndex) + ((thisSample * (1000 - pan)) // 1000).            sample >  32767 ifTrue: [ sample _  32767 ].  "clipping!!"            sample < -32767 ifTrue: [ sample _ -32767 ].  "clipping!!"            aSoundBuffer at: channelIndex put: sample.        ].        indexTimes1000 _ indexTimes1000 + incrementTimes1000.        sampleIndex _ indexTimes1000 // 1000.        i _ i + 1].    count _ count - n.! !!SampledSound methodsFor: 'playing' stamp: 'jm 9/12/97 19:29'!reset    "Details: The increment amount is represented as 1000 * the increment value to allow fractional increments without having to do floating point arithmetic in the inner loop."    super reset.    incrementTimes1000 _        ((originalSamplingRate asFloat / self samplingRate asFloat) * 1000.0) asInteger.    count _ initialCount.    indexTimes1000 _ 1000.! !!SampledSound methodsFor: 'playing' stamp: 'jm 9/13/97 19:07'!samplesRemaining    ^ count! !!SampledSound methodsFor: 'accessing' stamp: 'jm 9/12/97 16:46'!samples    ^ samples! !!SampledSound methodsFor: 'copying' stamp: 'jm 10/4/97 16:51'!copy    ^ self clone! !!SampledSound class methodsFor: 'class initialization' stamp: 'jm 9/17/97 13:10'!initialize    "Build a sine wave table."    "SampledSound initialize"    | radiansPerStep scale |    DefaultSampleTable _ SoundBuffer newMonoSampleCount: 6000.    radiansPerStep _ (2.0 * Float pi) / 100.0.    scale _ ((1 bitShift: 15) - 1) asFloat.  "range is +/- (2^15 - 1)"    1 to: DefaultSampleTable size do: [:i |        DefaultSampleTable at: i put:            (scale * (radiansPerStep * i) sin) rounded].    NominalSamplePitch _ 220.    SoundLibrary _ Dictionary new.! !!SampledSound class methodsFor: 'instance creation' stamp: 'jm 9/13/97 10:39'!fromAIFFfileNamed: fileName    "Read a SampledSound from the AIFF file of the given name assuming a default sampling rate."    "(SampledSound fromAIFFfileNamed: '1.aif') play"    "| snd |     FileDirectory default fileNames do: [:n |        (n endsWith: '.aif')            ifTrue: [                snd _ SampledSound fromAIFFfileNamed: n.                snd play.                SoundPlayer waitUntilDonePlaying: snd]]."    | data |    data _ self rawDataFromAIFFfileNamed: fileName.    data _ self convert8bitSignedTo16Bit: data.    ^ self samples: data samplingRate: 11025! !!SampledSound class methodsFor: 'instance creation' stamp: 'jm 9/12/97 21:29'!fromAIFFfileNamed: fileName samplingRate: anInteger    "Read a SampledSound from the AIFF file of the given name. This method skips the header without parsing it; it assumes the file contains 8-bit uncompressed mono data as recorded by the shareware program SoundMachine 2.1. The headers of such AIFF files are 54 bytes."    "(SampledSound fromAIFFfileNamed: '1.aif' samplingRate: 8000) play"    | data |    data _ self rawDataFromAIFFfileNamed: fileName.    data _ self convert8bitSignedTo16Bit: data.    ^ self samples: data samplingRate: anInteger! !!SampledSound class methodsFor: 'instance creation' stamp: 'jm 9/12/97 19:20'!samples: anArrayOf16BitSamples samplingRate: samplesPerSecond    "Return a SampledSound with the given samples array and sampling rate."    ^ self new setSamples: anArrayOf16BitSamples samplingRate: samplesPerSecond! !!SampledSound class methodsFor: 'default sound' stamp: 'jm 9/17/97 13:10'!defaultSamples: anArray repeated: n    | data |    data _ WriteStream on: (SoundBuffer newMonoSampleCount: anArray size * n).    n timesRepeat: [        anArray do: [:sample | data nextPut: sample truncated]].    DefaultSampleTable _ data contents.! !!SampledSound class methodsFor: 'default sound' stamp: 'jm 9/12/97 19:17'!defaultSamplesFromAIFF: fileName samplePitch: aNumber    "Set the sample table to be used as the default waveform from the AIFF file of the given name. The sample pitch is an estimate of the normal pitch of the sampled sound."    "SampledSound defaultSamplesFromAIFF: 'boing.aiff' samplePitch: 200"    self defaultSampleTable: (self fromAIFFfileNamed: fileName) samples.    self nominalSamplePitch: aNumber.! !!SampledSound class methodsFor: 'default sound'!defaultSampleTable    "Return the sample table to be used as the default waveform for playing a score."    ^ DefaultSampleTable! !!SampledSound class methodsFor: 'default sound' stamp: 'jm 9/17/97 12:49'!defaultSampleTable: anArray    "Set the sample table to be used as the default waveform for playing a score such as the Bach fugue. Array is assumed to contain monaural signed 16-bit sample values."    DefaultSampleTable _ SoundBuffer fromArray: anArray.! !!SampledSound class methodsFor: 'default sound'!nominalSamplePitch: aNumber    "Record an estimate of the normal pitch of the sampled sound."    NominalSamplePitch _ aNumber.! !!SampledSound class methodsFor: 'default sound' stamp: 'jm 9/12/97 19:38'!useCoffeeCupClink    "Set the sample table to be used as the default waveform to the sound of a coffee cup being tapped with a spoon."    "SampledSound useCoffeeCupClink bachFugue play"    self defaultSampleTable: self coffeeCupClink.    NominalSamplePitch _ 400.! !!SampledSound class methodsFor: 'coffee cup clink' stamp: 'jm 8/23/97 22:25'!coffeeCupClink    "Return the samples array for the sound of a spoon being tapped against a coffee cup."    CoffeeCupClink ifNil: [self initializeCoffeeCupClink].    ^ CoffeeCupClink! !!SampledSound class methodsFor: 'coffee cup clink' stamp: 'jm 9/17/97 12:50'!initializeCoffeeCupClink    "Initialize the samples array for the sound of a spoon being tapped against a coffee cup."    "SampledSound initializeCoffeeCupClink"    | samples |    samples _ #(768 1024 -256 2304 -13312 26624 32512 19200 6400 -256 5888 32512 28928 32512 -32768 32512 -32768 18688 26368 -26112 32512 32512 2304 32512 5632 2816 10240 -4608 -1792 32512 32512 -5376 10752 32512 32512 32512 8192 15872 32512 -3584 -32768 -23296 -24832 -32768 -32768 -32768 -2304 32512 32512 -32768 32512 -15360 6400 8448 -18176 -32768 -256 -32768 -29440 9472 20992 17920 32512 32512 -256 32512 -32768 -32768 -23040 -32768 -25088 -32768 -27648 -1536 24320 -32768 32512 20480 27904 22016 16384 -32768 32512 -27648 -32768 -7168 28160 -6400 5376 32512 -256 32512 -7168 -11776 -19456 -27392 -24576 -32768 -24064 -19456 12800 32512 27136 2048 25344 15616 8192 -4608 -28672 -32768 -30464 -2560 17664 256 -8192 8448 32512 27648 -6144 -512 -7424 -18688 7936 -256 -22272 -14080 2048 27648 15616 -12288 -768 5376 3328 5632 3072 -6656 -20480 10240 27136 -10752 -11008 -768 -2048 6144 -7168 -3584 -1024 -7680 19712 26112 1024 -11008 3072 16384 -8960 -14848 -4864 -23808 -11264 12288 8192 7168 4864 23040 32512 512 -11776 -5632 -16896 -21504 -12800 -6144 -16896 -4352 32512 32512 23296 21760 5632 2816 -9472 -20992 -11264 -29440 -32768 -3584 7680 8448 15360 32512 32512 15616 15104 -2048 -27904 -27904 -25600 -12288 -12032 -13568 17152 22272 15360 30208 28160 7680 -5632 -8192 -16384 -31744 -25856 -10752 -3840 6656 13056 24320 26368 12800 20736 12288 -19200 -20992 -16640 -21504 -17920 -6912 8448 11264 14080 23040 18176 8192 -1024 0 256 -20992 -19712 -4608 -11264 -2048 14080 12032 8192 6912 13056 9216 -5632 -5376 -3840 -6656 -9984 -5632 4864 -3584 -1280 17408 7680 -1280 4096 2816 -1024 -4864 3328 8448 -768 -5888 -2048 5120 0 3072 11008 -7680 -15360 2560 6656 -3840 0 11776 7680 2816 1536 -1280 -3840 -8704 -1536 3584 -9728 -9728 11776 18688 7680 6656 6400 -4864 -3840 -256 -6912 -13312 -11264 2304 9728 1792 3328 18944 18432 6912 6144 -1536 -17664 -14336 -2304 -10496 -15616 -4096 9728 17152 14848 13312 11520 2304 -1024 2560 -8704 -26624 -18688 -256 -256 2816 14080 13824 12544 14080 9728 -512 -12032 -8960 -3328 -9984 -15872 -5120 8192 3584 10496 20224 7936 4608 6144 1280 -8704 -12800 -7424 -8448 -8960 -3840 7424 13056 8704 13312 13056 -2304 -4864 -768 -7168 -10496 -4608 -1536 -3072 -1280 6144 13312 11008 4864 4864 1536 -8960 -7680 1792 -4864 -7680 2816 5632 3328 2560 5376 7936 3584 -512 512 -4608 -9728 0 9216 768 -4096 7680 7168 256 4608 -768 -8704 -6400 2048 6144 -3072 -3328 6400 9472 3840 -768 1792 -3840 -5120 6144 768 -9984 -4352 5120 9472 6912 2816 1792 1280 768 512 -2816 -9728 -6912 6912 6912 -3328 -768 8448 11776 10752 3328 -6912 -10752 -8704 -1536 0 -6912 -3328 9984 13568 7424 6144 6656 256 0 256 -12032 -17920 -8192 3584 8960 4096 5632 12032 8704 6912 5632 -3584 -10496 -7936 -2048 -9216 -11776 2304 9472 15104 14848 5888 512 -2816 1024 2560 -9984 -13312 -5120 768 1792 768 8448 12032 11264 12800 -256 -11264 -9728 -2304 3072 -4352 -6912 256 2304 5376 9984 8192 2816 1280 3584 -2048 -11008 -8448 -2048 3072 4864 2304 3072 3072 3072 7168 3328 -5376 -4864 512 512 -1792 -1792 1792 5376 5888 5888 512 -5888 -3584 4096 3584 -6400 -4864 4608 3072 3840 5376 1024 768 2816 5888 -768 -12288 -7936 2304 5888 3328 2048 6144 3072 3072 6400 -3328 -7168 256 4096 -512 -9472 -6656 3328 6912 9216 8704 3840 -2560 -256 6656 -2560 -11264 -4608 -768 -1280 1536 3072 4096 5120 9984 11264 1024 -8192 -6144 -1024 -3840 -5632 -512 1024 2304 9728 9728 1280 512 4096 2816 -3584 -9984 -6912 -2304 512 5632 7680 3584 1024 5632 5888 -1280 -3584 -2304 -2560 -1536 -1024 -1792 -512 1536 7680 9984 2048 -2048 2048 3328 -1280 -4096 -3328 -4608 -1280 4352 3328 1280 1792 5120 6912 1024 -2560 0 -768 -1024 1280 -256 -4608 -1280 6400 5120 768 1792 2560 2048 0 -1536 -1280 -2304 1024 5376 2560 -2560 -512 4096 2048 512 768 -1280 -256 2560 2560 -256 -1024 768 3584 1280 -3328 -1536 1792 2816 3328 2304 -256 256 2816 2304 -1280 -3328 -1536 2304 2304 -256 -256 1024 1536 3840 5120 1024 -2048 0 1536 -768 -2560 -1792 256 2304 2048 1536 256 768 5888 6656 256 -3840 -2304 -1280 -1536 256 0 -512 2304 4352 3840 768 0 2304 3072 256 -3072 -2560 -2560 256 4608 2560 256 1536 3072 3072 1792 256 256 512 -256 -768 -1280 -1536 768 4352 2816 -512 768 2560 2560 2304 -256 -1792 -768 768 1792 256 -2304 -256 3328 3840 2304 2304 1536 256 2048 1024 -1536 -1792 -1024 512 256 -512 0 2304 4864 5120 4352 1024 -1280 0 -768 -2816 -2304 -512 1024 2048 2304 2048 3072 3840 2816 2048 -512 -3072 -1792 -1536 -1280 768 1280 1536 2304 2816 2048 1536 2048 1536 1536 -768 -3840 -2048 0 1280 2816 1792 1536 2560 3584 2816 1024 256 -768 -768 -1280 -2816 -768 1792 3328 5120 3072 1280 1536 1792 768 -1024 -1280 -1536 -768 512 256 1536 2560 2560 3328 1280 0 768 1536 768 -256 -512 -1536 -1280 768 1280 2304 2560 2560 2560 1024 -256 -512 0 1280 1536 768 -1280 -512 2048 1536 2048 1280 -256 256 512 768 768 1280 2304 1792 512 -1280 -1024 768 1536 1536 256 -768 1536 3584 3072 1792 -256 -1536 -512 256 -512 -512 768 2048 2048 1792 1280 1280 3072 2816 768 -1024 -2304 -1024 256 256 1280 1792 2304 2816 2304 1280 512 1024 768 -768 -1280 -1280 -512 1536 2560 2816 2048 512 1024 1792 1280 768 0 -768 -768 0 256 256 1280 2560 2304 2304 1536 512 512 1024 1280 0 -1792 -1536 -512 1280 3072 2816 1792 512 1024 1536 256 -256 768 768 256 256 -256 512 1280 1280 1536 768 1024 1792 1536 1024 0 256 -512 -256 1024 512 256 768 1792 2304 1280 256 768 1024 1280 1792 768 -768 -768 768 512 256 1024 1792 1536 1280 1536 1792 1280 768 512 -512 -1792 -512 512 768 2304 2816 1792 768 1536 2304 1536 0 -256 -256 -768 -768 256 1536 1536 2304 2048 256 768 2048 2304 1280 0 -256 -1024 -1024 0 1024 1792 2304 2304 1280 512 1280 2048 1280 256 -512 -1792 -1536 256 1536 1792 2048 2048 2048 1536 512 512 768 256 -256 0 -512 -1024 768 2048 2304 2304 1280 1280 1024 1024 1024 0 -512 256 768 0 -256 1536 2304 1792 2304 1280 -512 -256 768 1536 1024 256 512 512 1024 1792 1792 1536 1024 1280 0 -1280 256 2048 2560 2048 1024 -256 -256 1024 1280 1536 1024 0 0 256 768 1792 2304 2048 1280 1024 0 -512 -256 256 1024 1024 512 768 768 1280 2048 1792 1024 768 768 -256 -1024 0 256 1024 1536 1024 1280 1536 1792 1792 1024 512 512 0 -512 -256 512 768 1280 1280 1024 1280 1792 1792 1280 512 -256 -256 256 512 1280 1024 1280 1280 1024 1024 768 1024 1024 1024 1280 256 256 768 768 1024 512 256 768 1280 2560 2560 1280 512 -256 -512 -256 1024 1536 768 1024 1280 768 1024 1536 1536 1024 256 0 0 0 768 768 512 1280 1536 1280 1280 1280 1280 768 768 256 -256 768 768 256 768 1280 1792 1536 1536 1536 256 512 1024 0 -768 -256 768 512 1024 2048 1536 1024 1536 1536 768 0 0 -256).    CoffeeCupClink _ SoundBuffer fromArray: samples.! !!SampledSound class methodsFor: 'sound library' stamp: 'jm 9/13/97 21:55'!addLibrarySoundNamed: aString fromAIFFfileNamed: fileName sampleRate: samplesPerSecond    "Add a sound from the given AIFF file to the library. The file is assumed to be 8-bits, mono, uncompressed."    "SampledSound addLibrarySoundNamed: 'shutterClick'        fromAIFFfileNamed: '7.aif'        sampleRate: 11025"    self addLibrarySoundNamed: aString        samples: (self rawDataFromAIFFfileNamed: fileName)        sampleRate: samplesPerSecond.! !!SampledSound class methodsFor: 'sound library' stamp: 'jm 9/12/97 19:45'!addLibrarySoundNamed: aString samples: sampleData sampleRate: samplesPerSecond    "Add the given sound to the sound library. The sample data may be either a ByteArray or a SoundBuffer. If the former, it is take to be 8-bit unsigned samples (as from an AIFF file). If the latter, it is taken to be 16 bit signed samples."    SoundLibrary        at: aString        put: (Array with: sampleData with: samplesPerSecond).! !!SampledSound class methodsFor: 'sound library' stamp: 'jm 9/12/97 19:46'!removeSoundNamed: aString    "Remove the sound with the given name from the sound library."    SoundLibrary removeKey: aString ifAbsent: [].! !!SampledSound class methodsFor: 'sound library' stamp: 'jm 9/13/97 21:56'!soundNamed: aString    "Return a list of sound names for the sounds stored in the sound library."    "(SampledSound soundNamed: 'shutterClick') play"    | entry samples |    entry _ SoundLibrary        at: aString        ifAbsent: [^ self error: 'sorry, the sound library has no sound of that name'].    samples _ entry at: 1.    samples class isBytes ifTrue: [samples _ self convert8bitSignedTo16Bit: samples].    ^ self samples: samples samplingRate: (entry at: 2)! !!SampledSound class methodsFor: 'sound library' stamp: 'jm 9/12/97 19:59'!soundNames    "Return a list of sound names for the sounds stored in the sound library."    "SampledSound soundNames"    ^ SoundLibrary keys asArray! !!SampledSound class methodsFor: 'utilities' stamp: 'jm 9/17/97 13:10'!convert8bitSignedTo16Bit: anArray    "Convert the given array of samples--assumed to be 8-bit signed, linear data--into 16-bit signed samples. Return an array containing the resulting samples. Typically used to read uncompressed AIFF sound data."    | n samples s |    n _ anArray size.    samples _ SoundBuffer newMonoSampleCount: n.    1 to: n do: [:i |        s _ anArray at: i.        s > 127 ifTrue: [s _ s - 256].        samples at: i put: (s * 256)].    ^ samples! !!SampledSound class methodsFor: 'utilities' stamp: 'jm 9/12/97 20:02'!rawDataFromAIFFfileNamed: fileName    "Read a SampledSound from the AIFF file of the given name. This method skips the header without parsing it; it assumes the file contains 8-bit uncompressed mono data as recorded by the shareware program SoundMachine 2.1. The headers of such AIFF files are 54 bytes."    "(SampledSound fromAIFFfileNamed: '1.aif') play"    | data f sz |    f _ (FileStream oldFileNamed: fileName) binary.    sz _ f size.    f skip: 54.  "skip AIFF header"    data _ (f next: sz - 54).    f close.    ^ data! !!SampledSound class methodsFor: 'utilities' stamp: 'jm 9/12/97 19:51'!readTrimmedSamplesFromAIFF: fileName    "Read samples from the given AIFF file and trim off leading and trailing silence."    | data first last i s |    data _ (FileStream oldFileNamed: fileName) binary contentsOfEntireFile.    first _ last _ nil.    i _ 55.    [(first == nil) and: [i < data size]] whileTrue: [        s _ data at: i.        s > 127 ifTrue: [s _ s - 256].        s abs > 10 ifTrue: [first _ i].        i _ i + 1].    first ifNil: [^ SoundBuffer new].  "all silence"    i _ data size.    [(last == nil) and: [i > first]] whileTrue: [        s _ data at: i.        s > 127 ifTrue: [s _ s - 256].        s abs > 10 ifTrue: [last _ i].        i _ i - 1].    ^ self convert8bitSignedTo16Bit: (data copyFrom: first to: last)! !!SampledSound class methodsFor: 'utilities' stamp: 'jm 9/17/97 13:11'!uLawDecode: aByteArray    "Convert the given array of uLaw-encoded 8-bit samples into a SoundBuffer of 16-bit signed samples."    | n out decodingTable |    n _ aByteArray size.    out _ SoundBuffer newMonoSampleCount: n.    decodingTable _ self uLawDecodeTable.    1 to: n do: [:i | out at: i put: (decodingTable at: (aByteArray at: i) + 1)].    ^ out! !!SampledSound class methodsFor: 'utilities' stamp: 'jm 9/13/97 16:41'!uLawDecodeTable    "Return a 256 entry table to be used to decode 8-bit uLaw-encoded samples."    "Details: This table was computed as follows:        | d encoded lastEncodedPos lastEncodedNeg |        d _ Array new: 256.        lastEncodedPos _ nil.        lastEncodedNeg _ nil.        4095 to: 0 by: -1 do: [:s |            encoded _ SampledSound uLawEncodeSample: s.            lastEncodedPos = encoded                ifFalse: [                    d at: (encoded + 1) put: (s bitShift: 3).                    lastEncodedPos _ encoded].            encoded _ encoded bitOr: 16r80.            lastEncodedNeg = encoded                ifFalse: [                    d at: (encoded + 1) put: (s bitShift: 3) negated.                    lastEncodedNeg _ encoded]].        d "    ^ #(32760 31608 30584 29560 28536 27512 26488 25464 24440 23416 22392 21368 20344 19320 18296 17272 16248 15736 15224 14712 14200 13688 13176 12664 12152 11640 11128 10616 10104 9592 9080 8568 8056 7800 7544 7288 7032 6776 6520 6264 6008 5752 5496 5240 4984 4728 4472 4216 3960 3832 3704 3576 3448 3320 3192 3064 2936 2808 2680 2552 2424 2296 2168 2040 1912 1848 1784 1720 1656 1592 1528 1464 1400 1336 1272 1208 1144 1080 1016 952 888 856 824 792 760 728 696 664 632 600 568 536 504 472 440 408 376 360 344 328 312 296 280 264 248 232 216 200 184 168 152 136 120 112 104 96 88 80 72 64 56 48 40 32 24 16 8 0 -32760 -31608 -30584 -29560 -28536 -27512 -26488 -25464 -24440 -23416 -22392 -21368 -20344 -19320 -18296 -17272 -16248 -15736 -15224 -14712 -14200 -13688 -13176 -12664 -12152 -11640 -11128 -10616 -10104 -9592 -9080 -8568 -8056 -7800 -7544 -7288 -7032 -6776 -6520 -6264 -6008 -5752 -5496 -5240 -4984 -4728 -4472 -4216 -3960 -3832 -3704 -3576 -3448 -3320 -3192 -3064 -2936 -2808 -2680 -2552 -2424 -2296 -2168 -2040 -1912 -1848 -1784 -1720 -1656 -1592 -1528 -1464 -1400 -1336 -1272 -1208 -1144 -1080 -1016 -952 -888 -856 -824 -792 -760 -728 -696 -664 -632 -600 -568 -536 -504 -472 -440 -408 -376 -360 -344 -328 -312 -296 -280 -264 -248 -232 -216 -200 -184 -168 -152 -136 -120 -112 -104 -96 -88 -80 -72 -64 -56 -48 -40 -32 -24 -16 -8 0)! !!SampledSound class methodsFor: 'utilities' stamp: 'jm 9/13/97 15:52'!uLawEncode: anArray    "Convert the given array of 16-bit signed samples into a ByteArray of uLaw-encoded 8-bit samples."    | n out s |    n _ anArray size.    out _ ByteArray new: n.    1 to: n do: [:i |        s _ anArray at: i.        s _ s bitShift: -3.  "drop 4 least significant bits"        s < 0            ifTrue: [s _ (self uLawEncodeSample: s negated) bitOr: 16r80]            ifFalse: [s _ (self uLawEncodeSample: s)].        out at: i put: s].    ^ out! !!SampledSound class methodsFor: 'utilities' stamp: 'jm 9/13/97 15:40'!uLawEncodeSample: s    "Encode the given 16-bit signed sample using the uLaw 8-bit encoding."    s < 496 ifTrue: [        s < 112 ifTrue: [            s < 48 ifTrue: [                s < 16                    ifTrue: [^ 16r70 bitOr: (15 - s)]                    ifFalse: [^ 16r60 bitOr: (15 - ((s - 16) bitShift: -1))]].            ^ 16r50 bitOr: (15 - ((s - 48) bitShift: -2))].        s < 240            ifTrue: [^ 16r40 bitOr: (15 - ((s - 112) bitShift: -3))]            ifFalse: [^ 16r30 bitOr: (15 - ((s - 240) bitShift: -4))]].    s < 2032 ifTrue: [        s < 1008            ifTrue: [^ 16r20 bitOr: (15 - ((s - 496) bitShift: -5))]            ifFalse: [^ 16r10 bitOr: (15 - ((s - 1008) bitShift: -6))]].    s < 4080        ifTrue: [^ 15 - ((s - 2032) bitShift: -7)]        ifFalse: [^ 0].! !!SampleStreamer methodsFor: 'all' stamp: 'jm 10/4/97 16:49'!copy    ^ self clone! !!SampleStreamer methodsFor: 'all'!nextSamplePut: anInteger    "Append the next sample to the output buffer."! !!Scanner methodsFor: 'multi-character scans'!xColon        "Allow := for assignment by converting to #_ "    aheadChar = $= ifTrue:        [self step.        tokenType _ #leftArrow.        self step.        ^ token _ #_].    "Otherwise, just do what normal scan of colon would do"    tokenType _ #colon.    ^ token _ self step asSymbol! !!Scanner methodsFor: 'multi-character scans'!xLetter    "Form a word or keyword."    | type |    buffer reset.    [(type _ typeTable at: hereChar asciiValue) == #xLetter or: [type == #xDigit]]        whileTrue:            ["open code step for speed"            buffer nextPut: hereChar.            hereChar _ aheadChar.            source atEnd                ifTrue: [aheadChar _ 30 asCharacter "doit"]                ifFalse: [aheadChar _ source next]].    (type == #colon or: [type = #xColon and: [aheadChar ~= $=]])        ifTrue:             [buffer nextPut: self step.            tokenType _ #keyword]        ifFalse:             [tokenType _ #word].    token _ buffer contents! !!Scanner class methodsFor: 'class initialization'!initialize    | newTable |    newTable _ Array new: 256 withAll: #xBinary. "default"    newTable atAll: #(9 10 12 13 32 ) put: #xDelimiter. "tab lf ff cr space"    newTable atAll: ($0 asciiValue to: $9 asciiValue) put: #xDigit.    newTable atAll: ($A asciiValue to: $Z asciiValue) put: #xLetter.    newTable atAll: ($a asciiValue to: $z asciiValue) put: #xLetter.    newTable at: 30 put: #doIt.    newTable at: $" asciiValue put: #xDoubleQuote.    newTable at: $# asciiValue put: #xLitQuote.    newTable at: $$ asciiValue put: #xDollar.    newTable at: $' asciiValue put: #xSingleQuote.    newTable at: $: asciiValue put: #xColon.    newTable at: $( asciiValue put: #leftParenthesis.    newTable at: $) asciiValue put: #rightParenthesis.    newTable at: $. asciiValue put: #period.    newTable at: $; asciiValue put: #semicolon.    newTable at: $[ asciiValue put: #leftBracket.    newTable at: $] asciiValue put: #rightBracket.    newTable at: ${ asciiValue put: #leftBrace.    newTable at: $} asciiValue put: #rightBrace.    newTable at: $^ asciiValue put: #upArrow.    newTable at: $_ asciiValue put: #leftArrow.    newTable at: $| asciiValue put: #verticalBar.    TypeTable _ newTable "bon voyage!!"    "Scanner initialize"! !!Scanner class methodsFor: 'testing'!isLiteralSymbol: aSymbol     "Test whether a symbol can be stored as # followed by its characters.      Symbols created internally with asSymbol may not have this property,     e.g. '3' asSymbol."    | i ascii type |    i _ aSymbol size.    i = 0 ifTrue: [^ false].    i = 1 ifTrue: [('$''"()' includes: (aSymbol at: 1)) ifTrue: [^ false] ifFalse: [^ true]].    ascii _ (aSymbol at: 1) asciiValue.    "TypeTable should have been origined at 0 rather than 1 ..."    ascii = 0 ifTrue: [^ false].    type _ TypeTable at: ascii.    (type == #xColon or: [type == #verticalBar]) ifTrue: [^ i = 1].    type == #xBinary ifTrue:             [[i > 1]                whileTrue:                     [ascii _ (aSymbol at: i) asciiValue.                    ascii = 0 ifTrue: [^ false].                    (TypeTable at: ascii) == #xBinary ifFalse: [^ false].                    i _ i - 1].            ^ true].    type == #xLetter ifTrue:             [[i > 1]                whileTrue:                     [ascii _ (aSymbol at: i) asciiValue.                    ascii = 0 ifTrue: [^ false].                    type _ TypeTable at: ascii.                    (type == #xLetter or: [type == #xDigit or: [type == #xColon]])                        ifFalse: [^ false].                    i _ i - 1].            ^ true].    ^ false! !!ScreenController methodsFor: 'menu messages' stamp: 'sw 1/18/96'!browseChangedMessages    "Browse all methods in the current change set.  , "    ChangedMessageSet openFor: Smalltalk changes! !!ScreenController methodsFor: 'menu messages'!changeWindowPolicy    Preferences setPreference: #reverseWindowStagger        toValue: (Preferences valueOfFlag: #reverseWindowStagger) not! !!ScreenController methodsFor: 'menu messages'!fastWindows    StandardSystemView cachingBits        ifTrue: [StandardSystemView dontCacheBits]        ifFalse: [StandardSystemView doCacheBits]! !!ScreenController methodsFor: 'menu messages' stamp: 'sw 5/10/96'!setAuthorInitials    "Put up a dialog allowing the user to specify the author's initials.  "    Utilities setAuthorInitials! !!ScreenController methodsFor: 'menu messages' stamp: 'sw 11/26/96'!setDesktopColor    "Let the user choose a new color for the desktop.   Based on an idea by Georg Gollmann.   "    Preferences desktopColor: Color fromUser.    ScheduledControllers updateGray; restore! !!ScreenController methodsFor: 'nested menus' stamp: 'sw 5/8/96'!changesMenu    "Answer a menu for changes-related items.  2/4/96 sw     : divided changelist options into two     : added browse recent submissions"    ChangesMenu == nil ifTrue:         [ChangesMenu _ SelectionMenu labelList:        #(    'file out changes'            'browse changed methods'            'browse recent submissions'            'recent change log')        lines: #(1 3)        selections: #(fileOutChanges browseChangedMessages browseRecentSubmissions browseRecentLog)].    ^ ChangesMenu"ScreenController new changesMenu startUp"! !!ScreenController methodsFor: 'nested menus' stamp: 'sw 7/24/96'!helpMenu    "Answer the help menu to be put up as a screen submenu.       : added set desktop color"    HelpMenu == nil ifTrue:        [HelpMenu _ SelectionMenu labelList:        #(    'preferences...'            'about this system...'            'command-key help'            'useful expressions'            'set author initials...'            'set desktop color...'            'view GIF imports'            'space left'                )        lines: #(1 4 6)        selections: #(editPreferences  aboutThisSystem openCommandKeyHelp openStandardWorkspace setAuthorInitials setDesktopColor viewGIFImports garbageCollect)].    ^ HelpMenu"ScreenController new helpMenu startUpScreenController initialize"! !!ScreenController methodsFor: 'nested menus' stamp: 'di 6/24/97 00:43'!openMenu    "Answer a menu for open-related items.       : useful expressions moved to help menu"    OpenMenu == nil ifTrue:        [OpenMenu _ SelectionMenu labelList:        #(    'open browser'            'open workspace'            'open file list'            'open change sorter'            'open project'            'open transcript'            'open system workspace')        selections: #(openBrowser openWorkspace openFileList openChangeManager openProject openTranscript  openSystemWorkspace )].    ^ OpenMenu"ScreenController new openMenu startUp"! !!ScreenController methodsFor: 'nested menus' stamp: 'sw 7/23/96'!projectScreenMenu    "Answer the project screen menu.        : remove misc menu thing"    ProjectScreenMenu == nil ifTrue:        [ProjectScreenMenu _ SelectionMenu labelList:        #(    'exit project'            'restore display'            'open...'            'changes...'            'window...'            'help...'            'do...'            'save'            'save as...'            'save and quit'            'quit...')        lines: #(2 7)        selections: #(exitProject restoreDisplay openMenu changesMenu windowMenu helpMenu commonRequests  snapshot saveAs snapshotAndQuit quit)].    ^ ProjectScreenMenu"ScreenController new projectScreenMenu startUp"! !!ScreenController methodsFor: 'nested menus' stamp: 'sw 7/24/96'!topScreenMenu    "Answer the screen menu for the top project, from whence there is no relevance to the 'exit project' item.  "    TopScreenMenu == nil ifTrue:        [TopScreenMenu _ SelectionMenu labelList:        #(    'restore display'            'open...'            'changes...'            'window...'            'help...'            'do...'            'save'            'save as...'            'save and quit'            'quit...')        lines: #(1 6)        selections: #( restoreDisplay openMenu changesMenu windowMenu helpMenu commonRequests  snapshot saveAs snapshotAndQuit quit)].    ^ TopScreenMenu"ScreenController new newScreenMenu startUp"! !!ScreenController methodsFor: 'nested menus' stamp: 'sw 10/24/96'!windowMenu    "Answer a menu for windows-related items.  "    ^ SelectionMenu labelList:        #(    'find window...'            'find changed windows...'            'collapse all windows'            'expand all windows'            'close unchanged windows') ,            (Array with: (StandardSystemView cachingBits                            ifTrue: ['dont save bits (compact)']                            ifFalse: ['save bits (fast)'])                with: ((Preferences valueOfFlag: #reverseWindowStagger)                            ifTrue: ['tile windows']                            ifFalse: ['stagger windows']))        lines: #(2 4 5)        selections: #(findWindow indicateWindowsWithUnacceptedInput collapseAll expandAll closeUnchangedWindows fastWindows changeWindowPolicy)"ScreenController new windowMenu startUp"! !!ScreenController methodsFor: 'nested menus' stamp: 'sw 5/8/96'!yellowButtonActivity    "Put up the alternate yellow button activity if appropriate, else defer to the old way.  2/7/96 sw     : if shift key down, do find window.     : project screen menu different from regular (top) screen menu"    | reply aMenu |    Sensor leftShiftDown ifTrue: [^ self findWindow].    aMenu _ self projectScreenMenu.    (reply _ aMenu startUp) isNil ifTrue: [^ super controlActivity].    (#(changesMenu helpMenu openMenu windowMenu miscMenu) includes: reply)        ifTrue:  "submenu called for"            [reply _ (self perform: reply) startUp.            reply == nil ifTrue: [^ super controlActivity]].    ^ self perform: reply! !!ScreenController class methodsFor: 'class initialization' stamp: 'di 6/24/97 00:16'!initialize    "Initialize the screen menus.  Call this method to reset everything back to nil, so that the various menu retrieval methods will duly reinitialize them."    "ScreenController initialize"    ChangesMenu _ HelpMenu _ TopScreenMenu _ OpenMenu _ WindowMenu _ ProjectScreenMenu _ nil.! !!ScreenController class methodsFor: 'class initialization'!installHyperSqueakScreenMenu    "Install the variant of the screen menu containing the HyperSqueak submenu..  To restore the standard version, just set the TopScreenMenu class variable back to nil, or call ScreenController revertToStandardMenus, which does just that11/4/96 sw"    "ScreenController installHyperSqueakScreenMenu"    TopScreenMenu _ SelectionMenu labelList:        #('HyperSqueak...'            'restore display'            'open...'            'changes...'            'window...'            'help...'            'do...'            'save'            'save as...'            'save and quit'            'quit...')        lines: #(1 2 7)        selections: #(hyperSqueakMenu restoreDisplay openMenu changesMenu windowMenu helpMenu commonRequests  snapshot saveAs snapshotAndQuit quit).    ProjectScreenMenu _ SelectionMenu labelList:        #('HyperSqueak...'            'exit project'            'restore display'            'open...'            'changes...'            'window...'            'help...'            'do...'            'save'            'save as...'            'quit...')        lines: #(1 3 8)        selections: #(hyperSqueakMenu exitProject restoreDisplay openMenu changesMenu windowMenu helpMenu commonRequests  snapshot saveAs quit)! !ScreeningMorph comment:'ScreeningMorph uses its first submorph as a screen, and its second submorph as a source.  It also wants you to choose (when showing only the screen) the passing color in the screen.  It then makes up a 1-bit mask which clips the source, and displays transparently outside it.'!!ScreeningMorph methodsFor: 'initialization'!initialize    super initialize.    displayMode _ #showScreened! !!ScreeningMorph methodsFor: 'menu'!addCustomMenuItems: aCustomMenu hand: aHandMorph    submorphs size = 0 ifTrue:        [^ aCustomMenu add: '*Please add a source morph*' action: #itself].    submorphs size = 1 ifTrue:        [^ aCustomMenu add: '*Please add a screen morph*' action: #itself].    submorphs size > 2 ifTrue:        [^ aCustomMenu add: '*I have too many submorphs*' action: #itself].    aCustomMenu add: 'show screen only' action: #showScreenOnly.    aCustomMenu add: 'show source only' action: #showSourceOnly.    aCustomMenu add: 'show screen over source' action: #showScreenOverSource.    aCustomMenu add: 'show source screened' action: #showScreened.    aCustomMenu add: 'exchange source and screen' action: #exchange.    displayMode == #showScreenOnly ifTrue:        [aCustomMenu add: 'choose passing color' action: #choosePassingColor.        aCustomMenu add: 'choose blocking color' action: #chooseBlockingColor].! !!ScreeningMorph methodsFor: 'menu'!chooseBlockingColor    self mapColor: Color fromUser to: 0 othersTo: 16rFFFFFFFF! !!ScreeningMorph methodsFor: 'menu'!choosePassingColor    self mapColor: Color fromUser to: 16rFFFFFFFF othersTo: 0! !!ScreeningMorph methodsFor: 'menu'!exchange    submorphs swap: 1 with: 2.    self changed! !!ScreeningMorph methodsFor: 'menu'!showScreened    displayMode _ #showScreened.    self changed! !!ScreeningMorph methodsFor: 'menu'!showScreenOnly    displayMode _ #showScreenOnly.    self changed! !!ScreeningMorph methodsFor: 'menu'!showScreenOverSource    displayMode _ #showScreenOverSource.    self changed! !!ScreeningMorph methodsFor: 'menu'!showSourceOnly    displayMode _ #showSourceOnly.    self changed! !!ScreeningMorph methodsFor: 'drawing' stamp: 'di 7/17/97 10:09'!fullDrawOn: aCanvas    | mergeForm |    submorphs size = 2 ifFalse: [^ super fullDrawOn: aCanvas].    (aCanvas isVisible: self fullBounds) ifFalse: [^ self].    "self drawOn: aCanvas."    displayMode == #showScreenOnly ifTrue:        [self screenMorph fullDrawOn: aCanvas].    displayMode == #showSourceOnly ifTrue:        [self sourceMorph fullDrawOn: aCanvas].    screenForm ifNil:        [self mapColor: Color black to: 16rFFFFFFFF othersTo: 0].    displayMode == #showScreenOverSource ifTrue:        [self sourceMorph fullDrawOn: aCanvas.        aCanvas image: screenForm at: self position].    displayMode == #showScreened ifTrue:        [mergeForm _ self sourceMorph imageFormForRectangle: self bounds.        (BitBlt toForm: mergeForm) copyForm: screenForm to: 0@0 rule: Form and            colorMap: (Bitmap with: 0 with: 16rFFFFFFFF).        aCanvas image: mergeForm at: self position].! !!ScreeningMorph methodsFor: 'geometry'!containsPoint: aPoint    submorphs size = 2 ifFalse: [^ super containsPoint: aPoint].    ^ self screenMorph containsPoint: aPoint! !!ScreeningMorph methodsFor: 'private'!mapColor: aColor to: pickValue othersTo: elseValue    | screenImage colorMap |    screenImage _ self screenMorph imageForm.    colorMap _ screenImage newColorMap atAllPut: elseValue.    colorMap at: (aColor indexInMap: colorMap) put: pickValue.    screenForm _ Form extent: screenImage extent.    screenForm copyBits: screenForm boundingBox            from: screenImage at: 0@0 colorMap: colorMap.    self changed.    self privateBounds: (screenImage offset extent: screenForm extent).    self changed! !!ScreeningMorph methodsFor: 'private'!screenMorph    ^ submorphs at: 1! !!ScreeningMorph methodsFor: 'private'!sourceMorph    ^ submorphs at: 2! !ScrollBar comment:'Inspired by an oiginal design of Hans-Martin Mosner, this ScrollBar is intended to exercise the handling of input events in Morphic.  With sufficient flexibility in this area, all particular behavior can be concentrated in this single class with no need to specialize any other morphs to achieve button, slider and menu-button behavior.Once we have this working, put in logic for horizontal operation as well.'!!ScrollBar methodsFor: 'initialize'!initialize    super initialize.    scrollDelta _ 0.02.    pageDelta _ 0.2! !!ScrollBar methodsFor: 'initialize'!initializeDownButton    downButton := RectangleMorph        newBounds: (self innerBounds bottomRight - self buttonExtent extent: self buttonExtent)        color: Color lightGray.    downButton on: #mouseDown send: #borderInset to: downButton.    downButton on: #mouseStillDown send: #scrollDown to: self.    downButton on: #mouseUp send: #borderRaised to: downButton.    downButton addMorphCentered: (ImageMorph new image:         (UpArrow rotateBy: (bounds isWide ifTrue: [#right] ifFalse: [#pi]) centerAt: 0@0)).    downButton setBorderWidth: 2 borderColor: #raised.    self addMorph: downButton! !!ScrollBar methodsFor: 'initialize'!initializeMenuButton    menuButton := RectangleMorph            newBounds: (self innerBounds topLeft extent: self buttonExtent)            color: Color lightGray.    menuButton on: #mouseEnter send: #menuButtonMouseEnter: to: self.    menuButton on: #mouseDown send: #menuButtonMouseDown: to: self.    menuButton on: #mouseLeave send: #menuButtonMouseLeave: to: self.    menuButton addMorphCentered:        (RectangleMorph newBounds: (0@0 extent: 4@2) color: Color black).    menuButton setBorderWidth: 2 borderColor: #raised.    self addMorph: menuButton! !!ScrollBar methodsFor: 'initialize'!initializePagingArea    pagingArea := RectangleMorph newBounds: self totalSliderArea                                color: (Color r: 0.6 g: 0.6 b: 0.8).    pagingArea borderWidth: 0.    pagingArea on: #mouseDown send: #nextPage: to: self.    self addMorph: pagingArea! !!ScrollBar methodsFor: 'initialize'!initializeSlider    self initializeMenuButton; initializeUpButton; initializeDownButton; initializePagingArea.    super initializeSlider! !!ScrollBar methodsFor: 'initialize'!initializeUpButton    upButton := RectangleMorph        newBounds: ((bounds isWide ifTrue: [menuButton bounds topRight]                                    ifFalse: [menuButton bounds bottomLeft])                    extent: self buttonExtent)        color: Color lightGray.    upButton on: #mouseDown send: #borderInset to: upButton.    upButton on: #mouseStillDown send: #scrollUp to: self.    upButton on: #mouseUp send: #borderRaised to: upButton.    upButton addMorphCentered: (ImageMorph new image:         (bounds isWide ifTrue: [UpArrow rotateBy: #left centerAt: 0@0] ifFalse: [UpArrow])).    upButton setBorderWidth: 2 borderColor: #raised.    self addMorph: upButton! !!ScrollBar methodsFor: 'access'!interval: d    "Supply an optional floating fraction so slider can expand to indicate range"    interval _ d.    self computeSlider! !!ScrollBar methodsFor: 'access'!scrollDelta    ^ scrollDelta! !!ScrollBar methodsFor: 'access'!scrollDelta: d1 pageDelta: d2    "Supply optional increments for better scrolling of, eg, text"    scrollDelta _ d1.    pageDelta _ d2.! !!ScrollBar methodsFor: 'geometry'!buttonExtent    ^ bounds isWide        ifTrue: [9 @ self innerBounds height]        ifFalse: [self innerBounds width @ 9]! !!ScrollBar methodsFor: 'geometry'!computeSlider    super computeSlider.    interval ifNotNil: [self expandSlider]! !!ScrollBar methodsFor: 'geometry'!expandSlider    | r val2 |    val2 _ value + interval min: 1.0.    r _ self roomToMove.    slider extent: (bounds isWide        ifTrue: [((r width * (val2 - value)) asInteger + self sliderThickness) @ slider height]        ifFalse: [slider width @ ((r height * (val2 - value)) asInteger + self sliderThickness)])! !!ScrollBar methodsFor: 'geometry'!extent: p    p x > p y    ifTrue: [super extent: (p x max: 36) @ 16]    ifFalse: [super extent: 16 @ (p y max: 36)]! !!ScrollBar methodsFor: 'geometry'!totalSliderArea    ^ bounds isWide        ifTrue: [upButton bounds topRight corner: downButton bounds bottomLeft]        ifFalse: [upButton bounds bottomLeft corner: downButton bounds topRight]! !!ScrollBar methodsFor: 'scrolling' stamp: 'di 6/12/97 12:26'!nextPage: event    event cursorPoint >= slider topLeft        ifTrue: [self setValue: value + pageDelta]        ifFalse: [self setValue: value - pageDelta]! !!ScrollBar methodsFor: 'scrolling'!scrollDown    self setValue: value + scrollDelta! !!ScrollBar methodsFor: 'scrolling'!scrollUp    self setValue: value - scrollDelta! !!ScrollBar methodsFor: 'scrolling'!setValue: newValue    ^ super setValue: (newValue + 0.0001 truncateTo: scrollDelta)! !!ScrollBar methodsFor: 'other events'!menuButtonMouseDown: event    event hand showTemporaryCursor: nil.    self use: menuSelector orMakeModelSelectorFor: 'MenuButtonPressed:'        in: [:sel | menuSelector _ sel.  model perform: sel with: event]! !!ScrollBar methodsFor: 'other events'!menuButtonMouseEnter: event    event hand showTemporaryCursor: Cursor menu! !!ScrollBar methodsFor: 'other events'!menuButtonMouseLeave: event    event hand showTemporaryCursor: nil! !!ScrollBar methodsFor: 'other events'!mouseDownInSlider    slider color: Color veryLightGray! !!ScrollBar methodsFor: 'other events'!mouseUpInSlider    slider color: Color lightGray! !!ScrollBar class methodsFor: 'class initialization'!initialize "ScrollBar initialize"    UpArrow _ Form        extent: 6@3        fromArray: #(2r11e28 2r1111e27 2r111111e26)        offset: 0@0.! !!ScrollController methodsFor: 'initialize-release'!initialize    super initialize.    scrollBar _ Quadrangle new.    scrollBar borderWidthLeft: 2 right: 0 top: 2 bottom: 2.    marker _ Quadrangle new.    marker insideColor: Preferences scrollBarColor.    menuBar _ Quadrangle new.    menuBar borderWidthLeft:  2 right: 0 top: 2 bottom: 2.! !!ScrollController methodsFor: 'basic control sequence'!controlInitialize    "Recompute scroll bars.  Save underlying image unless it is already saved."    | |    super controlInitialize.    scrollBar region: (0 @ 0 extent: 24 @ view apparentDisplayBox height).    scrollBar insideColor: view backgroundColor.    marker region: self computeMarkerRegion.    scrollBar _ scrollBar align: scrollBar topRight with: view apparentDisplayBox topLeft.    marker _ marker align: marker topCenter with: self upDownLine @ (scrollBar top + 2).    savedArea isNil ifTrue: [savedArea _ Form fromDisplay: scrollBar].    scrollBar displayOn: Display.    "Show a border around yellow-button (menu) region""    yellowBar _ Rectangle left: self yellowLine right: scrollBar right + 1        top: scrollBar top bottom: scrollBar bottom.    Display border: yellowBar width: 1 mask: Form veryLightGray."    self moveMarker! !!ScrollController methodsFor: 'control defaults'!isControlActive     view isNil ifTrue: [^ false].    ^ (view insetDisplayBox merge: scrollBar inside)        containsPoint: sensor cursorPoint! !!ScrollController methodsFor: 'scrolling'!downLine    "if cursor before downLine, display down cursor and scroll down on button down"    ^scrollBar left + 6 ! !!ScrollController methodsFor: 'scrolling'!scroll    "Check to see whether the user wishes to jump, scroll up, or scroll down."    | savedCursor |    savedCursor _ sensor currentCursor.            [self scrollBarContainsCursor]                whileTrue:                     [Processor yield.                    sensor cursorPoint x <= self downLine                                ifTrue: [self scrollDown]                                ifFalse: [sensor cursorPoint x <= self upLine                                        ifTrue: [self scrollAbsolute]                                        ifFalse: [sensor cursorPoint x <= self yellowLine                                                ifTrue: [self scrollUp]                                                ifFalse: [sensor cursorPoint x <= scrollBar right                                                        ifTrue: "Might not be, with touch pen"                                                        [self changeCursor: Cursor menu.                                                        sensor anyButtonPressed                                                         ifTrue: [self changeCursor: savedCursor.                                                                 self anyButtonActivity]]]]]].    savedCursor show! !!ScrollController methodsFor: 'scrolling'!upDownLine    "Check to see whether the user wishes to jump, scroll up, or scroll down."    ^scrollBar left + 12! !!ScrollController methodsFor: 'scrolling'!upLine    "if cursor beyond upLine, display up cursor and scroll up on button down"    ^scrollBar left + 12! !!ScrollController methodsFor: 'scrolling'!yellowLine    "Check to see whether the user wishes to jump, scroll up, or scroll down."    ^scrollBar left + 16! !!ScrollController methodsFor: 'marker adjustment'!computeMarkerRegion    "Answer the rectangular area in which the gray area of the scroll bar     should be displayed."    ^0@0 extent: Preferences scrollBarWidth @            ((view window height asFloat /                        view boundingBox height *                            scrollBar inside height)                 rounded min: scrollBar inside height)! !!ScrollController methodsFor: 'marker adjustment'!markerRegion: aRectangle     "Set the area defined by aRectangle as the marker. Fill it with gray tone."    Display fill: marker fillColor: scrollBar insideColor.    marker region: aRectangle.    marker _ marker align: marker topCenter             with: self upDownLine @ (scrollBar top + 2) ! !!ScrollPane methodsFor: 'initialization'!fullCopy    | copy |    self mouseEnter.          "Make sure scrollBar is in morphic structure"    copy _ super fullCopy.  "So that references are updated properly"    self mouseLeave.    ^ copy mouseLeave! !!ScrollPane methodsFor: 'initialization'!initialize    | |    super initialize.    borderWidth _ 2.  borderColor _ #inset.    retractableScrollBar _ scrollBarOnLeft _ true.    scrollBar := ScrollBar new model: self slotName: 'scrollBar'.    scrollBar borderWidth: 2; borderColor: #inset.    retractableScrollBar ifFalse: [self addMorph: scrollBar].    scroller := TransformMorph new color: Color transparent.    scroller offset: -3@0.    self addMorph: scroller.    self on: #mouseEnter send: #mouseEnter to: self.    self on: #mouseLeave send: #mouseLeave to: self.    self extent: 150@120! !!ScrollPane methodsFor: 'access'!colorForInsets    "My submorphs use the surrounding color"    ^ owner color! !!ScrollPane methodsFor: 'access' stamp: '6/6/97 13:37 di'!paneColor: aColor    self color: aColor! !!ScrollPane methodsFor: 'access'!scroller    ^ scroller! !!ScrollPane methodsFor: 'access' stamp: '6/7/97 10:42 di'!wantsSlot    "For now do it the old way, until we sort this out"    ^ true! !!ScrollPane methodsFor: 'geometry'!containsPoint: aPoint    (super containsPoint: aPoint) ifTrue: [^ true].    "Also include scrollbar when it is extended..."    ^ (retractableScrollBar and: [submorphs includes: scrollBar]) and:        [scrollBar containsPoint: aPoint]! !!ScrollPane methodsFor: 'geometry'!extent: newExtent    super extent: (newExtent max: 16@36).    self resizeScrollBar; resizeScroller! !!ScrollPane methodsFor: 'geometry' stamp: '6/6/97 11:59 di'!resizeScrollBar    | d | d _ retractableScrollBar ifTrue: [14@0] ifFalse: [0@0].    scrollBar bounds: (scrollBarOnLeft        ifTrue: [bounds topLeft - d extent: 16 @ bounds height]        ifFalse: [bounds topRight - (16@0) + d extent: 16 @ bounds height])! !!ScrollPane methodsFor: 'geometry'!resizeScroller    | d inner |    d _ retractableScrollBar ifTrue: [16@0] ifFalse: [0@0].    inner _ self innerBounds.    scroller bounds: (scrollBarOnLeft        ifTrue: [inner topLeft + (16@0) - d corner: inner bottomRight]        ifFalse: [inner topLeft corner: inner bottomRight - (16@0) + d])! !!ScrollPane methodsFor: 'geometry'!totalScrollRange    ^ (scroller submorphBounds encompass: 0@0) height - (bounds height // 2) max: 0! !!ScrollPane methodsFor: 'retractable scroll bar'!mouseEnter    (retractableScrollBar and: [(submorphs includes: scrollBar) not])        ifTrue: [self resizeScrollBar.                self privateAddMorph: scrollBar atIndex: 1]! !!ScrollPane methodsFor: 'retractable scroll bar'!mouseLeave    retractableScrollBar ifTrue: [self privateRemoveMorph: scrollBar]! !!ScrollPane methodsFor: 'scroll bar events'!scrollBarMenuButtonPressed: event    self use: menuSelector orMakeModelSelectorFor: 'MenuButtonPressed:'        in: [:sel | menuSelector _ sel.  model perform: sel with: event]! !!ScrollPane methodsFor: 'scroll bar events'!scrollBarValue: scrollValue    scroller hasSubmorphs ifFalse: [^ self].    scroller offset: -3 @ (self totalScrollRange * scrollValue)! !!ScrollPane methodsFor: 'menu'!addCustomMenuItems: aCustomMenu hand: aHandMorph    retractableScrollBar    ifTrue: [aCustomMenu add: 'make scrollbar inboard' action: #makeInboardScrollBar]    ifFalse: [aCustomMenu add: 'make scrollbar retractable' action: #makeRetractableScrollBar]! !!ScrollPane methodsFor: 'menu' stamp: '6/6/97 12:01 di'!makeInboardScrollBar  "On the right, by default"    retractableScrollBar _ scrollBarOnLeft _ false.    self extent: self extent! !!ScrollPane methodsFor: 'menu' stamp: '6/6/97 12:01 di'!makeRetractableScrollBar  "On the left, by default"    retractableScrollBar _ scrollBarOnLeft _ true.    self extent: self extent! !!SelectionMenu methodsFor: 'basic control sequence'!invokeOn: targetObject    "Pop up this menu and return the result of sending to the target object     the selector corresponding to the menu item selected by the user. Return     nil if no item is selected."    | sel |    sel _ self startUp.    sel = nil ifFalse: [^ targetObject perform: sel].    ^ nil"(SelectionMenu labels:'sincosneg' lines: #() selections: #(sin cos negated)) invokeOn: 0.7"! !!SelectionMenu methodsFor: 'marker management'!manageMarker    "Returns the selected item. If no selection, return nil."    super manageMarker.    (selections = nil or: [(selection between: 1 and: selections size) not])        ifTrue: [^ nil].    ^ selections at: selection! !!SelectionMenu class methodsFor: 'instance creation'!confirm: queryString     "Put up a yes/no menu with caption queryString. Answer true if the response is yes, false if no. This is a modal question--the user must respond yes or no."    "SelectionMenu confirm: 'Are you hungry?'"    | menu choice |    menu _ self selections: #('yes' 'no').    [true] whileTrue: [        choice _ menu startUpWithCaption: queryString.        choice = 'yes' ifTrue: [^ true].        choice = 'no' ifTrue: [^ false]]! !!SelectionMenu class methodsFor: 'instance creation'!labels: aString lines: linesArray selections: selectionsArray    "Answer an instance of me whose items are in aString, with lines drawn     after each item indexed by anArray. Record the given array of selections    corresponding to the items in labelsArray."    ^ (self labels: aString lines: linesArray) selections: selectionsArray! !!SelectionMenu class methodsFor: 'instance creation'!labels: aString selections: selectionsArray    "Answer an instance of me whose items are in aString, recording     the given array of selections corresponding to the items in aString."    ^ self labels: aString lines: #() selections: selectionsArray! !!SelectionMenu class methodsFor: 'instance creation' stamp: 'sw 6/27/96'!selections: aList    "Answer an instance of me whose labels and selections are identical.  "    ^ self labelList: aList lines: nil selections: aList! !!SelectionMenu class methodsFor: 'instance creation'!selections: aList lines: lineList    "Answer an instance of me whose labels and selections are identical"    ^ self labelList: aList lines: lineList selections: aList! !!SelectorNode methodsFor: 'code generation'!emit: stack args: nArgs on: aStream super: supered    | index |    stack pop: nArgs.    (supered not and: [code - Send < SendLimit and: [nArgs < 3]]) ifTrue:        ["short send"        code < Send            ifTrue: [^ aStream nextPut: code "special"]            ifFalse: [^ aStream nextPut: nArgs * 16 + code]].    index _ code < 256 ifTrue: [code - Send] ifFalse: [code \\ 256].    (index <= 31 and: [nArgs <= 7]) ifTrue:         ["extended (2-byte) send [131 and 133]"        aStream nextPut: SendLong + (supered ifTrue: [2] ifFalse: [0]).        ^ aStream nextPut: nArgs * 32 + index].    (supered not and: [index <= 63 and: [nArgs <= 3]]) ifTrue:        ["new extended (2-byte) send [134]"        aStream nextPut: SendLong2.        ^ aStream nextPut: nArgs * 64 + index].    "long (3-byte) send"    aStream nextPut: DblExtDoAll.    aStream nextPut: nArgs + (supered ifTrue: [32] ifFalse: [0]).    aStream nextPut: index! !!SelectorNode methodsFor: 'code generation'!size: encoder args: nArgs super: supered    | index |    self reserve: encoder.    (supered not and: [code - Send < SendLimit and: [nArgs < 3]])        ifTrue: [^1]. "short send"    (supered and: [code < Send]) ifTrue:         ["super special:"        code _ self code: (encoder litIndex: key) type: 5].    index _ code < 256 ifTrue: [code - Send] ifFalse: [code \\ 256].    (index <= 31 and: [nArgs <= 7])        ifTrue: [^ 2]. "medium send"    (supered not and: [index <= 63 and: [nArgs <= 3]])        ifTrue: [^ 2]. "new medium send"    ^ 3 "long send"! !!Semaphore methodsFor: 'communication' stamp: 'jm 9/15/97 17:11'!waitTimeoutMSecs: anInteger    "Wait on this semaphore for up to the given number of milliseconds, then timeout. It is up to the sender to determine the difference between the expected event and a timeout."    | d |    d _ Delay timeoutSemaphore: self afterMSecs: (anInteger max: 0).    self wait.    d unschedule.! !!Semaphore methodsFor: 'communication' stamp: 'jm 9/12/97 11:39'!waitTimeoutSeconds: anInteger    "Wait on this semaphore for up to the given number of seconds, then timeout. It is up to the sender to determine the difference between the expected event and a timeout."    self waitTimeoutMSecs: anInteger * 1000.! !!SequenceableCollection methodsFor: 'accessing'!allButFirst    ^ self copyFrom: 2 to: self size! !!SequenceableCollection methodsFor: 'accessing'!allButLast    ^ self copyFrom: 1 to: self size - 1! !!SequenceableCollection methodsFor: 'accessing' stamp: 'di 7/13/97 09:49'!atAll: indexArray    "Return the selected elements in order"    ^ indexArray collect: [:i | self at: i]! !!SequenceableCollection methodsFor: 'accessing' stamp: 'di 7/13/97 09:50'!atAll: indexArray putAll: valueArray    "Store the elements of valueArray into the slots    of this collection selected by indexArray."    indexArray with: valueArray do:        [:i :x | self at: i put: x]! !!SequenceableCollection methodsFor: 'accessing'!indexOf: anElement startingAt: start ifAbsent: exceptionBlock    "Answer the index of anElement within the receiver. If the receiver does     not contain anElement, answer the result of evaluating the argument,     exceptionBlock."    start to: self size do:        [:i | (self at: i) = anElement ifTrue: [^ i]].    ^ exceptionBlock value! !!SequenceableCollection methodsFor: 'copying'!copyAt: anIndex put: anElement    "Answer a copy of the receiver with anElement inserted at anIndex."    ^ self copyReplaceFrom: anIndex to: anIndex with: (Array with: anElement)! !!SequenceableCollection methodsFor: 'copying' stamp: 'di 9/20/97 22:42'!shuffled    | copy |  "($A to: $Z) shuffled"    copy _ self shallowCopy.    copy size to: 1 by: -1 do:         [:i | copy swap: i with: (1 to: i) atRandom].    ^ copy! !!SequenceableCollection methodsFor: 'enumerating' stamp: 'di 7/13/97 09:44'!collectWithIndex: elementAndIndexBlock    "Use the new version with consistent naming"    ^ self withIndexCollect: elementAndIndexBlock! !!SequenceableCollection methodsFor: 'enumerating' stamp: 'di 7/13/97 09:43'!doWithIndex: elementAndIndexBlock    "Use the new version with consistent naming"    ^ self withIndexDo: elementAndIndexBlock! !!SequenceableCollection methodsFor: 'enumerating' stamp: 'sw 12/23/96'!pairsDo: aBlock     "March through the receiver two elements at a time.  If there's an odd number of items, ignore the last one.  Allows use of a flattened array for things that naturally group into pairs.  "    | i |    1 to: self size // 2 do:        [:index |            i _ 2 * index - 1.             aBlock value: (self at: i) value: (self at: i + 1)]"#(1 'fred' 2 'charlie' 3 'elmer') pairsDo:    [:a :b | Transcript cr; show: b, ' is number ', a printString]"! !!SequenceableCollection methodsFor: 'enumerating' stamp: 'di 7/13/97 09:30'!with: otherCollection collect: twoArgBlock     "Collect and return the result of evaluating twoArgBlock with corresponding elements from this collection and otherCollection."    | result |    result _ self species new: self size.    1 to: self size do:        [:index | result at: index put:        (twoArgBlock            value: (self at: index)            value: (otherCollection at: index))].    ^ result! !!SequenceableCollection methodsFor: 'enumerating' stamp: 'di 7/13/97 09:32'!with: otherCollection do: twoArgBlock     "Evaluate twoArgBlock with corresponding elements from this collection and otherCollection."    1 to: self size do:        [:index |        twoArgBlock value: (self at: index)                value: (otherCollection at: index)]! !!SequenceableCollection methodsFor: 'enumerating' stamp: 'di 7/13/97 09:35'!withIndexCollect: elementAndIndexBlock     "Just like with:collect: except that the iteration index supplies the second argument to the block."    | result |    result _ self species new: self size.    1 to: self size do:        [:index | result at: index put:        (elementAndIndexBlock            value: (self at: index)            value: index)]! !!SequenceableCollection methodsFor: 'enumerating' stamp: 'di 7/13/97 09:35'!withIndexDo: elementAndIndexBlock     "Just like with:do: except that the iteration index supplies the second argument to the block."    1 to: self size do:        [:index |        elementAndIndexBlock            value: (self at: index)            value: index]! !!SequenceableCollection methodsFor: 'converting' stamp: 'di 7/7/97 09:51'!reversed    "Answer a copy of the receiver with element order reversed."    | reversal strm |    reversal _ self species new: self size.    strm _ WriteStream on: reversal.    self reverseDo: [:elem | strm nextPut: elem].    ^ reversal" 'frog' reversed "! !!SequenceableCollection methodsFor: 'private' stamp: 'startSearch 12/8/96:'!copyReplaceAll: oldSubstring with: newSubstring asTokens: ifTokens    "Answer a copy of the receiver in which all occurrences of    oldSubstring have been replaced by newSubstring.    ifTokens (valid for Strings only) specifies that the characters    surrounding the recplacement must not be alphanumeric.        Bruce Simth,  must be incremented by 1 and not     newSubstring if ifTokens is true.  See example below. "    | aString startSearch currentIndex endIndex |    (ifTokens and: [(self isKindOf: String) not])        ifTrue: [self error: 'Token replacement only valid for Strings'].    aString _ self.    startSearch _ 1.    [(currentIndex _ aString indexOfSubCollection: oldSubstring startingAt: startSearch)             > 0]        whileTrue:         [endIndex _ currentIndex + oldSubstring size - 1.        (ifTokens not            or: [(currentIndex = 1                    or: [(aString at: currentIndex-1) isAlphaNumeric not])                and: [endIndex = aString size                    or: [(aString at: endIndex+1) isAlphaNumeric not]]])            ifTrue: [aString _ aString                    copyReplaceFrom: currentIndex                    to: endIndex                    with: newSubstring.                startSearch _ currentIndex + newSubstring size]            ifFalse: [                ifTokens                     ifTrue: [startSearch _ currentIndex + 1]                    ifFalse: [startSearch _ currentIndex + newSubstring size]]].    ^ aString"Test case:    'test te string' copyReplaceAll: 'te' with: 'longone' asTokens: true   "! !!SequenceableCollection class methodsFor: 'stream creation' stamp: 'di 6/20/97 09:07'!streamContents: blockWithArg limitedTo: sizeLimit    | stream |    stream _ LimitedWriteStream on: (self new: (100 min: sizeLimit)).    stream setLimit: sizeLimit limitBlock: [^ stream contents].    blockWithArg value: stream.    ^ stream contents"String streamContents: [:s | 1000 timesRepeat: [s nextPutAll: 'Junk']] limitedTo: 25 'JunkJunkJunkJunkJunkJunkJ'"! !!SequentialSound methodsFor: 'sound generation' stamp: 'jm 8/28/97 01:23'!mixSampleCount: n into: aSoundBuffer startingAt: startIndex pan: pan    "Play a collection of sounds in sequence."    "PluckedSound chromaticScale play"    | finalIndex i snd remaining count |    currentIndex = 0 ifTrue: [ ^ self ].  "already done"    finalIndex _ (startIndex + n) - 1.    i _ startIndex.    [i <= finalIndex] whileTrue: [        snd _ (sounds at: currentIndex).        [(remaining _ snd samplesRemaining) <= 0] whileTrue: [            "find next undone sound"            currentIndex < sounds size ifTrue: [                currentIndex _ currentIndex + 1.                snd _ (sounds at: currentIndex).            ] ifFalse: [                currentIndex _ 0.                ^ self  "no more sounds"            ].        ].        count _ (finalIndex - i) + 1.        remaining < count ifTrue: [ count _ remaining ].        snd mixSampleCount: count into: aSoundBuffer startingAt: i pan: pan.        i _ i + count.    ].! !!SequentialSound methodsFor: 'copying' stamp: 'jm 10/4/97 16:59'!copy    "Copy my component sounds."    ^ self clone copySounds! !!SequentialSound methodsFor: 'copying' stamp: 'jm 10/4/97 16:58'!copySounds    "Private!! Support for copying. Copy my component sounds."    sounds _ (sounds collect: [:s | s copy]).! !!Set methodsFor: 'private'!findElementOrNil: anObject    "Answer the index of a first slot containing either a nil (indicating an empty slot) or an element that matches the given object. Answer the index of that slot or zero. Fail if neither a match nor an empty slot is found."    | index |    index _ self scanFor: anObject.    index > 0 ifTrue: [ ^ index ].    "Bad scene.  Neither have we found a matching element    nor even an empty slot.  No hashed set is ever supposed to get    completely full."    self error: 'There is no free space in this set!!'.! !!Set methodsFor: 'private' stamp: 'di 9/21/97 21:09'!fullCheck    "Keep array at least 1/4 free for decent hash behavior"    array size - tally < (array size // 4 max: 1)        ifTrue: [self grow]! !!Set methodsFor: 'private'!scanFor: anObject    "Scan the key array for the first slot containing either a nil (indicating an empty slot) or an element that matches anObject. Answer the index of that slot or zero if no slot is found. This method will be overridden in various subclasses that have different interpretations for matching elements."    | element start finish |    start _ (anObject hash \\ array size) + 1.    finish _ array size.    "Search from (hash mod size) to the end."    start to: finish do:        [:index | ((element _ array at: index) == nil or: [element = anObject])            ifTrue: [^ index ]].    "Search from 1 to where we started."    1 to: start-1 do:        [:index | ((element _ array at: index) == nil or: [element = anObject])            ifTrue: [^ index ]].    ^ 0  "No match AND no empty slot"! !!Set methodsFor: 'accessing' stamp: 'sw 12/2/96'!asArray    "Return an array whose elements are those of the receiver.  "    ^ self asOrderedCollection asArray! !!Set methodsFor: 'accessing' stamp: 'tk 2/14/97'!someElement    "Return some element of the Set.  "    ^ array detect: [:each | each ~~ nil] ifNone: [ nil]! !!Set methodsFor: 'objects from disk' stamp: 'tk 1/8/97'!readDataFrom: aDataStream size: anInteger    "Symbols have new hash in this world.  "    | aSet |    aSet _ super readDataFrom: aDataStream size: anInteger.    aSet rehash.    ^ aSet! !!Set class methodsFor: 'instance creation' stamp: 'tk 9/7/96'!readDataFrom: aDataStream size: anInteger    "Symbols have new hash in this world.  "    | aSet |    self halt.    aSet _ super readDataFrom: aDataStream size: anInteger.    aSet rehash.    ^ aSet! !!Set class methodsFor: 'initialization'!rehashAllSets  "Set rehashAllSets"    | insts |    self withAllSubclassesDo:        [:c | insts _ c allInstances.        insts isEmpty ifFalse:        ['Rehashing instances of ' , c name            displayProgressAt: Sensor cursorPoint            from: 1 to: insts size            during: [:bar |            1 to: insts size do:                [:x | bar value: x.                (insts at: x) rehash]]]]! !!SimpleButtonMorph methodsFor: 'initialization'!initialize    super initialize.    self borderWidth: 1.    self borderColor: #raised.    self color: (Color r: 0.4 g: 0.8 b: 0.6).    target _ nil.    actionSelector _ #flash.    arguments _ EmptyArray.    actWhen _ #buttonUp.    self label: 'Flash'.! !!SimpleButtonMorph methodsFor: 'menu'!addCustomMenuItems: aCustomMenu hand: aHandMorph    super addCustomMenuItems: aCustomMenu hand: aHandMorph.    aCustomMenu add: 'change label' action: #setLabel.    aCustomMenu add: 'change action selector' action: #setActionSelector.    aCustomMenu add: 'change arguments' action: #setArguments.    aCustomMenu add: 'change when to act' action: #setActWhen.    ((self world rootMorphsAt: aHandMorph targetOffset) size > 1) ifTrue: [        aCustomMenu add: 'set target' action: #setTarget:].! !!SimpleButtonMorph methodsFor: 'menu'!setActionSelector    | newSel |    newSel _ FillInTheBlank        request:'Please type the selector to be sent tothe target when this button is pressed'        initialAnswer: actionSelector.    newSel isEmpty ifFalse: [self actionSelector: newSel].! !!SimpleButtonMorph methodsFor: 'menu'!setActWhen    actWhen _ (SelectionMenu selections: #(buttonDown buttonUp whilePressed))        startUpWithCaption: 'Choose one of the following conditions'! !!SimpleButtonMorph methodsFor: 'menu'!setArguments    | s newArgs newArgsArray |    s _ WriteStream on: ''.    arguments do: [:arg | arg printOn: s. s nextPutAll: '. '].    newArgs _ FillInTheBlank        request:'Please type the arguments to be sent to the targetwhen this button is pressed separated by periods'        initialAnswer: s contents.    newArgs isEmpty ifFalse: [        newArgsArray _ Compiler evaluate: '{', newArgs, '}' for: self logged: false.        self arguments: newArgsArray].! !!SimpleButtonMorph methodsFor: 'menu'!setLabel    | newLabel |    newLabel _ FillInTheBlank        request:'Please a new label for this button'        initialAnswer: self label.    newLabel isEmpty ifFalse: [self label: newLabel].! !!SimpleButtonMorph methodsFor: 'menu'!setTarget: evt    | rootMorphs |    rootMorphs _ self world rootMorphsAt: evt hand targetOffset.    rootMorphs size > 1        ifTrue: [target _ rootMorphs at: 2]        ifFalse: [target _ nil. ^ self].! !!SimpleButtonMorph methodsFor: 'accessing'!actionSelector    ^ actionSelector! !!SimpleButtonMorph methodsFor: 'accessing'!actionSelector: aSymbolOrString    (nil = aSymbolOrString or:     ['nil' = aSymbolOrString or:     [aSymbolOrString isEmpty]])        ifTrue: [^ actionSelector _ nil].    actionSelector _ aSymbolOrString asSymbol.! !!SimpleButtonMorph methodsFor: 'accessing'!actWhen: condition    "Accepts symbols:  #buttonDown, #buttonUp, and #whilePressed"    actWhen _ condition! !!SimpleButtonMorph methodsFor: 'accessing'!arguments    ^ arguments! !!SimpleButtonMorph methodsFor: 'accessing'!arguments: aCollection    arguments _ aCollection asArray copy.! !!SimpleButtonMorph methodsFor: 'accessing' stamp: '6/7/97 10:53 di'!extent: newExtent    | label |    super extent: newExtent.    submorphs size = 1 ifTrue:        ["keep the label centered"        "NOTE: may want to test more that it IS a label..."        label _ self firstSubmorph.        label position: self center - (label extent // 2)]! !!SimpleButtonMorph methodsFor: 'accessing'!label    | s |    s _ ''.    self allMorphsDo: [:m | (m isKindOf: StringMorph) ifTrue: [s _ m contents]].    ^ s! !!SimpleButtonMorph methodsFor: 'accessing'!label: aString    | oldLabel m |    (oldLabel _ self findA: StringMorph)        ifNotNil: [oldLabel delete].    m _ StringMorph new contents: aString.    self extent: (m width + 6) @ (m height + 6).    m position: self center - (m extent // 2).    self addMorph: m.! !!SimpleButtonMorph methodsFor: 'accessing'!target    ^ target! !!SimpleButtonMorph methodsFor: 'accessing'!target: anObject    target _ anObject! !!SimpleButtonMorph methodsFor: 'events'!doButtonAction    "Perform the action of this button. Subclasses may override this method. The default behavior is to send the button's actionSelector to its target object with its arguments."    (target ~~ nil and: [actionSelector ~~ nil]) ifTrue: [        Cursor normal showWhile: [            target perform: actionSelector withArguments: arguments]].! !!SimpleButtonMorph methodsFor: 'events'!handlesMouseDown: evt    ^ true! !!SimpleButtonMorph methodsFor: 'events'!mouseDown: evt    oldColor _ color.    actWhen == #buttonDown        ifTrue: [self doButtonAction].! !!SimpleButtonMorph methodsFor: 'events'!mouseMove: evt    (self containsPoint: evt cursorPoint)        ifTrue: [self color: (oldColor mixed: 1/2 with: Color white).                actWhen == #whilePressed ifTrue: [self doButtonAction]]        ifFalse: [self color: oldColor].! !!SimpleButtonMorph methodsFor: 'events'!mouseUp: evt    self color: oldColor.    (actWhen == #buttonUp and: [self containsPoint: evt cursorPoint])        ifTrue: [self doButtonAction].! !SimpleClientSocket comment:'This class supports client for simple network protocols based on sending textual commands and responses. Examples of such protocols include POP3 (mail retrieval), SMTP (mail posting), HTTP (web browsing), and NTTP (network news). Some simple examples are presented as class methods, but a full-service client of some service should be implemented as a subclass.The basic services provided by this class are:    sendCommand:            -- sends a command line terminate with <CR><LF>    getResponse                -- gets a (typically) single-line response to a command    getMultilineResponse    -- gets a multiple line response terminated by a period                            -- on a line by itselfThere are variants of the getResponse commands that display lines on the screen as they are being received. Linefeeds are stripped out of all responses.'!!SimpleClientSocket methodsFor: 'all' stamp: 'jm 9/15/97 15:21'!displayString: aString    "Display the given string on the Display. Used for testing."    | s |    aString isEmpty ifTrue: [^ self].    aString size > 60        ifTrue: [s _ aString copyFrom: 1 to: 60]  "limit to 60 characters"        ifFalse: [s _ aString].    s asParagraph displayOn: Display.! !!SimpleClientSocket methodsFor: 'all' stamp: 'jm 9/15/97 11:36'!endsWithSinglePeriodLine: aString    "Return true if the given string ends with a period on a line by itself."    | sz |    sz _ aString size.    ^ ((sz > 2) and:       [(aString at: sz) = CR and:       [(aString at: sz - 1) = $. and:       [(aString at: sz - 2) = CR]]])! !!SimpleClientSocket methodsFor: 'all' stamp: 'jm 9/15/97 15:43'!getMultilineResponse    "Get a multiple line response to the last command, filtering out LF characters. A multiple line response ends with a line containing only a single period (.) character."    ^ self getMultilineResponseShowing: false.! !!SimpleClientSocket methodsFor: 'all' stamp: 'jm 9/15/97 15:41'!getMultilineResponseShowing: showFlag    "Get a multiple line response to the last command. A multiple line response ends with a line containing only a single period (.) character. Linefeed characters are filtered out. If showFlag is true, each line is shown in the upper-left corner of the Display as it is received."    | response done chunk |    response _ WriteStream on: ''.    done _ false.    [done] whileFalse: [        showFlag            ifTrue: [chunk _ self getResponseShowing: true]            ifFalse: [chunk _ self getResponse].        response nextPutAll: chunk.        done _ self endsWithSinglePeriodLine: chunk].    ^ response contents! !!SimpleClientSocket methodsFor: 'all' stamp: 'jm 9/15/97 15:30'!getResponse    "Get the response to the last command, filtering out LF characters."    ^ self getResponseShowing: false! !!SimpleClientSocket methodsFor: 'all' stamp: 'jm 9/15/97 15:47'!getResponseShowing: showFlag    "Get a the response to the last command, filtering out LF characters. If showFlag is true, each of the response is shown in the upper-left corner of the Display as it is received."    | response line buf bytesRead c |    self waitForDataQueryingUserEvery: 15.    response _ WriteStream on: ''.    line _ WriteStream on: ''.    buf _ String new: 1000.    [self dataAvailable]        whileTrue: [            bytesRead _ self receiveDataInto: buf.            1 to: bytesRead do: [:i |                (c _ buf at: i) ~= LF                    ifTrue: [                        line nextPut: c.                        response nextPut: c]                    ifFalse: [                        showFlag ifTrue: [                            self displayString: line contents.                            line reset]]]].    ^ response contents! !!SimpleClientSocket methodsFor: 'all' stamp: 'jm 9/17/97 16:00'!sendCommand: commandString    "Send the given command as a single line followed by a <CR><LF> terminator."    self sendData: commandString, CrLf.! !!SimpleClientSocket methodsFor: 'all' stamp: 'jm 9/15/97 15:46'!waitForDataQueryingUserEvery: seconds    "Wait for data to arrive, asking the user periodically if they wish to keep waiting. If they don't wish to keep waiting, destroy the socket and raise an error."    | gotData |    gotData _ false.    [gotData]        whileFalse: [            gotData _ self waitForDataUntil: (Socket deadlineSecs: seconds).            gotData ifFalse: [                (self confirm: 'server not responding; keep trying?')                    ifFalse: [                        self destroy.                        self error: 'no response from server']]].! !!SimpleClientSocket class methodsFor: 'class initialization' stamp: 'jm 9/15/97 11:42'!initialize    "SimpleClientSocket initialize"    CR _ Character cr.    LF _ Character linefeed.    "string for command line termination:"    CrLf _ String with: CR with: LF.! !!SimpleClientSocket class methodsFor: 'simple HTTP example' stamp: 'jm 10/4/97 16:02'!httpTestHost: hostName port: port url: url    "This test fetches a URL from the given host and port."    "SimpleClientSocket httpTestHost: 'www.exploratorium.edu' port: 80 url: '/'"    "Tests URL fetch through a local HTTP proxie server:        (SimpleClientSocket            httpTestHost: '127.0.0.1'            port: 8080            url: 'HTTP://www.exploratorium.edu/index.html')"    | hostAddr s result buf bytes totalBytes t |    Transcript cr; show: 'starting http test'; cr.    Socket initializeNetwork.    hostAddr _ NetNameResolver addressForName: hostName timeout: 10.    hostAddr = nil ifTrue: [^ self inform: 'Could not find an address for ', hostName].    s _ SimpleClientSocket new.    Transcript show: '---------- Connecting ----------'; cr.    s connectTo: hostAddr port: port.    s waitForConnectionUntil: "self standardDeadline" (Socket deadlineSecs: 4).    (s isConnected) ifFalse: [        s destroy.        ^ self inform: 'could not connect'].    Transcript show: 'connection open; waiting for data'; cr.    s sendCommand: 'GET ', url, ' HTTP/1.0'.    s sendCommand: 'User-Agent: Squeak 1.19'.    s sendCommand: 'ACCEPT: text/html'.    "always accept plain text"    s sendCommand: 'ACCEPT: application/octet-stream'.    "also accept binary"    s sendCommand: ''.  "blank line"    result _ WriteStream on: (String new: 10000).    buf _ String new: 10000.    totalBytes _ 0.    t _ Time millisecondsToRun: [        [s isConnected] whileTrue: [            s waitForDataUntil: (Socket deadlineSecs: 5).            bytes _ s receiveDataInto: buf.            1 to: bytes do: [:i | result nextPut: (buf at: i)].            totalBytes _ totalBytes + bytes.            Transcript show: totalBytes printString, ' bytes received'; cr]].    s destroy.    Transcript show: '---------- Connection Closed ----------'; cr; endEntry.    Transcript show: 'http test done; ', totalBytes printString, ' bytes read in '.    Transcript show: ((t / 1000.0) roundTo: 0.01) printString, ' seconds'; cr.    Transcript show: ((totalBytes asFloat / t) roundTo: 0.01) printString, ' kBytes/sec'; cr.    Transcript endEntry.    StringHolderView        open: (StringHolder new contents: (result contents))        label: 'HTTP Test Result: URL Contents'.! !!SimpleClientSocket class methodsFor: 'net news example' stamp: 'jm 9/17/97 14:24'!nntpTest    "SimpleClientSocket nntpTest"    | addr s headers msgs header allNewsGroups |    addr _ NetNameResolver promptUserForHostAddress.    s _ SimpleClientSocket new.    Transcript show: '---------- Connecting ----------'; cr.    s connectTo: addr port: 119.  "119 is the NNTP port number"    s waitForConnectionUntil: self standardDeadline.    Transcript show: s getResponse.    s sendCommand: 'group comp.lang.smalltalk'.    Transcript show: s getResponse.    "get all the message headers for the current newsgroup"    s sendCommand: 'xover 1-1000000'.    headers _ s getMultilineResponseShowing: true.    "print the headers of the first 10 messages of comp.lang.smalltalk"    s sendCommand: 'listgroup comp.lang.smalltalk'.    msgs _ self parseIntegerList: s getMultilineResponse.    msgs ifNotNil: [        1 to: 5 do: [:i |            s sendCommand: 'head ', (msgs at: i) printString.            header _ s getMultilineResponse.            Transcript show: (self extractDateFromAndSubjectFromHeader: header); cr]].    "get a full list of usenet newsgroups"    s sendCommand: 'newgroups 010101 000000'.    allNewsGroups _ s getMultilineResponse.    Transcript show: allNewsGroups size printString, ' bytes in full newsgroup list'; cr.    Transcript show: 'Sending quit...'; cr.    s sendCommand: 'QUIT'.    Transcript show: s getResponse.    s closeAndDestroy.    Transcript show: '---------- Connection Closed ----------'; cr; endEntry.    (headers ~~ nil and:     [self confirm: 'show article headers from comp.lang.smalltalk?'])        ifTrue: [            StringHolderView                open: (StringHolder new contents: (self parseHeaderList: headers))                label: 'Newsgroup Headers'].    (allNewsGroups ~~ nil and:     [self confirm: 'show list of all newsgroups available on your server?'])        ifTrue: [            StringHolderView                open: (StringHolder new contents: allNewsGroups)                label: 'All Usenet Newsgroups'].! !!SimpleClientSocket class methodsFor: 'net news example' stamp: 'jm 9/15/97 13:25'!parseHeaderList: aString    "Parse a list of newsgroup headers."    | results s lineStart |    results _ WriteStream on: (String new: aString size).    s _ ReadStream on: aString.    [s atEnd]        whileFalse: [            lineStart _ s position + 1.            3 timesRepeat: [s skipTo: Character tab].  "find fourth tab"            lineStart to: s position - 1 do: [:i | results nextPut: (aString at: i)].            results cr.            s skipTo: Character cr].    ^ results contents! !!SimpleClientSocket class methodsFor: 'net news example' stamp: 'jm 9/15/97 13:26'!parseIntegerList: aString    "Parse a list of integers, each on a line by itself."    | s out |    s _ ReadStream on: aString.    s skipTo: Character cr.  "skip the first line"    out _ OrderedCollection new.    [s atEnd]        whileFalse: [            out addLast: (Integer readFrom: s).            s skipTo: Character cr].    ^ out asArray! !!SimpleClientSocket class methodsFor: 'net news example' stamp: 'jm 9/15/97 13:26'!parseNTTPMsgList: aString    "Parse a list of integers, each on a line by itself."    | s out |    s _ ReadStream on: aString.    s skipTo: Character cr.  "skip the first line"    out _ OrderedCollection new.    [s atEnd]        whileFalse: [            out addLast: (Integer readFrom: s).            s skipTo: Character cr].    ^ out asArray! !!SimpleClientSocket class methodsFor: 'POP mail example' stamp: 'jm 9/15/97 14:47'!extractDateFromAndSubjectFromHeader: headerString    | date from subject s lineBuf c line i |    date _ from _ subject _ ''.    s _ ReadStream on: headerString.    lineBuf _ WriteStream on: ''.    [s atEnd] whileFalse: [        c _ s next.        c = CR            ifTrue: [                line _ lineBuf contents.                (line beginsWith: 'Date: ')    ifTrue: [date _ line copyFrom: 7 to: line size].                (line beginsWith: 'From: ')    ifTrue: [from _ line copyFrom: 7 to: line size].                (line beginsWith: 'Subject: ')    ifTrue: [subject _ line copyFrom: 10 to: line size].                lineBuf _ WriteStream on: '']            ifFalse: [lineBuf nextPut: c]].    i _ date indexOf: $' ifAbsent: [0].    date _ date copyFrom: i + 1 to: date size.    ^ (self simpleDateString: date), ', ', from, ':  ', subject! !!SimpleClientSocket class methodsFor: 'POP mail example' stamp: 'jm 9/17/97 14:24'!popTest    "SimpleClientSocket popTest"    | addr userName userPassword s msgs header |    addr _ NetNameResolver promptUserForHostAddress.    userName _ FillInTheBlank        request: 'What is your email name?'        initialAnswer: 'johnm'.    userPassword _ FillInTheBlank        request: 'What is your email password?'.    s _ SimpleClientSocket new.    Transcript show: '---------- Connecting ----------'; cr.    s connectTo: addr port: 110.  "110 is the POP3 port number"    s waitForConnectionUntil: self standardDeadline.    Transcript show: s getResponse.    s sendCommand: 'USER ', userName.    Transcript show: s getResponse.    s sendCommand: 'PASS ', userPassword.    Transcript show: s getResponse.    s sendCommand: 'LIST'.    "the following should be tweaked to handle an empy mailbox:"    msgs _ self parseIntegerList: s getMultilineResponse.    1 to: (msgs size min: 5) do: [ :i |        s sendCommand: 'TOP ', (msgs at: i) printString, ' 0'.        header _ s getMultilineResponse.        Transcript show: (self extractDateFromAndSubjectFromHeader: header); cr].    msgs size > 0 ifTrue: [        "get the first message"        s sendCommand: 'RETR 1'.        Transcript show: s getMultilineResponse].    Transcript show: 'closing connection'; cr.    s sendCommand: 'QUIT'.    s closeAndDestroy.    Transcript show: '---------- Connection Closed ----------'; cr; endEntry.! !!SimpleClientSocket class methodsFor: 'POP mail example' stamp: 'jm 9/15/97 13:53'!simpleDateString: dateString    | s |    s _ ReadStream on: dateString.    s skipTo: $,.  "scan thru first comma"    s atEnd ifTrue: [s reset].  "no comma found; reset s"    s skipSeparators.    ^ (Date readFrom: s) mmddyy! !!SimpleClientSocket class methodsFor: 'remote cursor example' stamp: 'jm 9/17/97 14:25'!forkingRemoteCursorSender    "This is the client side of a test that sends samples of the local input sensor state to the server, which may be running on a local or remote host. This method opens the connection, then forks a process to send the cursor data. Data is sent continuously until the user clicks in a 20x20 pixel square at the top-left corner of the display. The server should be started first. Note the server's address, since this method will prompt you for it."    "SimpleClientSocket forkingRemoteCursorSender"    | sock addr stopRect |    Transcript show: 'starting remote cursor sender'; cr.    Transcript show: 'initializing network'; cr.    Socket initializeNetwork.    addr _ NetNameResolver promptUserForHostAddress.    Transcript show: 'opening connection'; cr.    sock _ SimpleClientSocket new.    sock connectTo: addr port: 54323.    sock waitForConnectionUntil: self standardDeadline.    (sock isConnected) ifFalse: [self error: 'sock not connected'].    Transcript show: 'connection established'; cr.    stopRect _ 0@0 corner: 20@20.  "click in this rectangle to stop sending"    Display reverse: stopRect.    ["the sending process"        [(stopRect containsPoint: Sensor cursorPoint) and:         [Sensor anyButtonPressed]]            whileFalse: [                sock sendCommand: self sensorStateString.                (Delay forMilliseconds: 20) wait].        sock waitForSendDoneUntil: self standardDeadline.        sock destroy.        Transcript show: 'remote cursor sender done'; cr.        Display reverse: stopRect.    ] fork.! !!SimpleClientSocket class methodsFor: 'remote cursor example' stamp: 'jm 9/15/97 14:49'!parseSensorStateString: aString    "Parse the given sensor stat string and return an array whose first element is the cursor point and whose second is the cursor button state."    "SimpleClientSocket parseSensorStateString: SimpleClientSocket sensorStateString"    | s buttons x y |    s _ ReadStream on: aString.    x _ Integer readFrom: s.    s skipSeparators.    y _ Integer readFrom: s.    s skipSeparators.    buttons _ Integer readFrom: s.    ^ Array with: x@y with: buttons! !!SimpleClientSocket class methodsFor: 'remote cursor example' stamp: 'jm 9/15/97 15:16'!remoteCursorReceiver    "Wait for a connection, then display data sent by the client until the client closes the stream. This server process is usually started first (optionally in a forked process), then the sender process is started (optionally on another machine). Note this machine's address, which is printed in the transcript, since the sender process will ask for it."    "[SimpleClientSocket remoteCursorReceiver] fork"    | sock response |    Transcript show: 'starting remote cursor receiver'; cr.    Transcript show: 'initializing network'; cr.    Socket initializeNetwork.    Transcript show: 'my address is ', NetNameResolver localAddressString; cr.    Transcript show: 'opening connection'; cr.    sock _ SimpleClientSocket new.    sock listenOn: 54323.    sock waitForConnectionUntil: (Socket deadlineSecs: 60).    sock isConnected        ifFalse: [             sock destroy.            Transcript show: 'remote cursor receiver did not receive a connection in 60 seconds; aborting.'.            ^ self].    Transcript show: 'connection established'; cr.    [sock isConnected]        whileTrue: [            sock dataAvailable                ifTrue: [                    response _ sock getResponse.                    response asParagraph displayOn: Display at: 10@10]                ifFalse: [                    "if no data available, let other processes run for a while"                    (Delay forMilliseconds: 20) wait]].    sock destroy.    Transcript show: 'remote cursor receiver done'; cr.! !!SimpleClientSocket class methodsFor: 'remote cursor example' stamp: 'jm 9/15/97 15:16'!remoteCursorTest    "This version of the remote cursor test runs both the client and the server code in the same loop."    "SimpleClientSocket remoteCursorTest"    | sock1 sock2 samplesToSend samplesSent done t |    Transcript show: 'starting remote cursor test'; cr.    Transcript show: 'initializing network'; cr.    Socket initializeNetwork.    Transcript show: 'opening connection'; cr.    sock1 _ SimpleClientSocket new.    sock2 _ SimpleClientSocket new.    sock1 listenOn: 54321.    sock2 connectTo: (NetNameResolver localHostAddress) port: 54321.    sock1 waitForConnectionUntil: self standardDeadline.    sock2 waitForConnectionUntil: self standardDeadline.    (sock1 isConnected) ifFalse: [self error: 'sock1 not connected'].    (sock2 isConnected) ifFalse: [self error: 'sock2 not connected'].    Transcript show: 'connection established'; cr.    samplesToSend _ 100.    t _ Time millisecondsToRun: [        samplesSent _ 0.        done _ false.        [done]            whileFalse: [                (sock1 sendDone and: [samplesSent < samplesToSend]) ifTrue: [                    sock1 sendCommand: self sensorStateString.                    samplesSent _ samplesSent + 1].                sock2 dataAvailable ifTrue: [                    sock2 getResponse asParagraph displayOn: Display at: 10@10].                done _ samplesSent = samplesToSend]].    sock1 destroy.    sock2 destroy.    Transcript show: 'remote cursor test done'; cr.    Transcript show:        samplesSent printString, ' samples sent in ',        t printString, ' milliseconds'; cr.    Transcript show: ((samplesSent * 1000) // t) printString, ' samples/sec'; cr.! !!SimpleClientSocket class methodsFor: 'remote cursor example' stamp: 'jm 9/15/97 13:11'!sensorStateString    "SimpleClientSocket sensorStateString"    | pt buttons s |    pt _ Sensor cursorPoint.    buttons _ Sensor primMouseButtons.    s _ WriteStream on: (String new: 100).    s nextPutAll: pt x printString.    s space.    s nextPutAll: pt y printString.    s space.    s nextPutAll: buttons printString.    ^ s contents! !!SimpleClientSocket class methodsFor: 'other examples' stamp: 'jm 9/17/97 14:27'!finger: userName    "SimpleClientSocket finger: 'stp'"    | addr s |    addr _ NetNameResolver promptUserForHostAddress.    s _ SimpleClientSocket new.    Transcript show: '---------- Connecting ----------'; cr.    s connectTo: addr port: 79.  "finger port number"    s waitForConnectionUntil: self standardDeadline.    s sendCommand: userName.    Transcript show: s getResponse.    s closeAndDestroy.    Transcript show: '---------- Connection Closed ----------'; cr; endEntry.! !!SimpleClientSocket class methodsFor: 'other examples' stamp: 'jm 9/17/97 14:22'!timeTest    "SimpleClientSocket timeTest"    | addr s |    addr _ NetNameResolver promptUserForHostAddress.    s _ SimpleClientSocket new.    Transcript show: '---------- Connecting ----------'; cr.    s connectTo: addr port: 13.  "time port number"    s waitForConnectionUntil: self standardDeadline.    Transcript show: s getResponse.    s closeAndDestroy.    Transcript show: '---------- Connection Closed ----------'; cr; endEntry.! !SketchEditorMorph comment:'For now, we do not carry the SketchMorph''s registration point, rotation center, or ticksToDwell.Registration point convention:  In a GraphicFrame, reg point is relative to this image''s origin.During painting, it is relative to canvasRectangle origin, and thus us absolute within the canvas.  To convert back, subract newBox origin.Be sure to convert back and forth correctly.  In deliverPainting. initializeFromFrame:inView: '!!SketchEditorMorph methodsFor: 'initialization' stamp: 'tk 6/29/97 11:31'!initializeFor: aHostView    hostView _ aHostView.    self bounds: aHostView world paintArea.  "Let it tell us"    canvasRectangle _ bounds translateBy: aHostView world viewBox origin.    palette _ aHostView world paintBox.    aHostView world fullRepaintNeeded.! !!SketchEditorMorph methodsFor: 'initialization' stamp: 'tk 6/29/97 11:31'!initializeFor: aSketchMorph inWorld: aWorldMorph    hostView _ aSketchMorph.    self bounds: aWorldMorph paintArea.    canvasRectangle _ bounds translateBy: aWorldMorph viewBox origin.    palette _ aWorldMorph paintBox.    aWorldMorph fullRepaintNeeded.! !!SketchEditorMorph methodsFor: 'morphic'!drawOn: aCanvas    "Put the painting on the display"    canvasRectangle _ bounds translateBy: self world viewBox origin.    composite _ self world paintArea origin.    dimToComp setDestForm: aCanvas form.    picToComp setDestForm: aCanvas form.    rotationButton setDestForm: aCanvas form.    scaleButton setDestForm: aCanvas form.    compToDisplay sourceForm: aCanvas form.    self render: paintingForm boundingBox.    "writes on aCanvas and the display both"! !!SketchEditorMorph methodsFor: 'morphic'!handlesMouseDown: evt    "Return true if I implement mouseDown:, mouseMove:, or mouseUp:"    self installed        ifTrue: [^ true]        ifFalse: [^ super handlesMouseDown: evt]! !!SketchEditorMorph methodsFor: 'morphic'!installed    ^ (owner ~= nil) and: [(owner isHandMorph not)]! !!SketchEditorMorph methodsFor: 'morphic' stamp: 'tk 4/18/97'!mouseDown: evt    "Just came back from another window.  Keep painting.  Save the picture after.  "    self installed ifFalse: [^ super mouseDown: evt].    ^ self deliverPainting: self resumePainting! !!SketchEditorMorph methodsFor: 'morphic'!mouseMove: evt    ! !!SketchEditorMorph methodsFor: 'morphic'!mouseUp: evt! !!SketchEditorMorph methodsFor: 'access'!afterNewPicDo: goodBlock    "If the user said 'Save' at the end of drawing, do this block to save the picture"    newPicBlock _ goodBlock! !!SketchEditorMorph methodsFor: 'access'!canvasRectangle    ^ canvasRectangle! !!SketchEditorMorph methodsFor: 'access'!composite    ^ composite! !!SketchEditorMorph methodsFor: 'access'!currentColor    ^ currentColor! !!SketchEditorMorph methodsFor: 'access'!currentColor: aColor    currentColor _ aColor.    "Caller must set the pens' color himself.  It is complicated."! !!SketchEditorMorph methodsFor: 'access'!hostView    ^ hostView! !!SketchEditorMorph methodsFor: 'access'!painting    ^ paintingForm! !!SketchEditorMorph methodsFor: 'access'!palette    ^palette! !!SketchEditorMorph methodsFor: 'access'!registrationPoint    ^ registrationPoint! !!SketchEditorMorph methodsFor: 'access'!registrationPoint: aPoint    registrationPoint _ aPoint! !!SketchEditorMorph methodsFor: 'access' stamp: 'tk 5/6/97'!save: aForm    "Save these bits.  Not to be confused with the Save command.  "    savedBits _ aForm! !!SketchEditorMorph methodsFor: 'access'!ticksToDwell    ticksToDwell == nil ifTrue: [ticksToDwell _ 1].    ^ ticksToDwell! !!SketchEditorMorph methodsFor: 'access'!ticksToDwell: t    ticksToDwell _ t! !!SketchEditorMorph methodsFor: 'start & finish'!backgroundFromUser    ^ self deliverPainting: (self getPaintingStartingWith: nil at: nil).    "Caller will want to fetch (aSketchEditorMorph painting) to get one that has not been trimmed"! !!SketchEditorMorph methodsFor: 'start & finish' stamp: 'tk 4/20/97'!cancel    "Palette is telling us that the use wants to end the painting session.  "    Cursor blank show.    self deliverPainting: #cancel.! !!SketchEditorMorph methodsFor: 'start & finish' stamp: 'tk 4/21/97'!deliverPainting: result    "Done painting.  May come from resume, or from original call.  Execute user's post painting instructions in the block.  Always use this standard one.  "    | newBox newForm evt rot |    result == #interrupt ifTrue: ["Catch this click in Morphic!!"        evt _ MorphicEvent new            setMousePoint: Sensor cursorPoint - self world viewBox origin            buttons: 4    "red down"            lastEvent: MorphicEvent new "red up"            hand: self world hands first.        self world hands first handleEvent: evt.        ^nil].    "will come back and finish later"    palette setAction: palette paint.    "Get out of odd modes"    rot _ palette getRotations.    "rotate with heading, or turn to and fro"    palette setRotation: #normal.    result == #cancel ifTrue: [        hostView changed.        self delete.        ^ nil].    "for Morphic""    dirty no longer used"    hostView rotationStyle: rot.    "rotate with heading, or turn to and fro"    newBox _ paintingForm innerPixelRectFor: 0 orNot: true.    "minimum size"    newBox _ newBox insetBy:         ((18 - newBox width max: 0)//2) @ ((18 - newBox height max: 0)//2) * -1.    registrationPoint ifNotNil: [        registrationPoint _ registrationPoint - newBox origin]. "relative to newForm origin"    newForm _     Form extent: newBox extent depth: paintingForm depth.    newForm copyBits: newBox from: paintingForm at: 0@0         clippingBox: newForm boundingBox rule: Form over fillColor: nil.    newPicBlock value: newForm value: (newBox copy translateBy: bounds origin).    self delete.! !!SketchEditorMorph methodsFor: 'start & finish' stamp: 'tk 3/19/97'!dimTheWindow    "Whiten the window by making every other pixel be white. 7/96 sw    12/12/96 tk: Made to work in > 8 bits..Really ugly, but I can't get it to work    3/12/97 sw: Reinstated working version for 8 bits    : Massive rework.  Keep dimmed form, recomposite after every brush stroke."    | worldForm |    "*** for repainting, must display without self? no?  For background, do you want to see objects?  Yes.  For background repainting see old background non-dimmed? Yes."    worldForm _ self world canvas form.    "create a dim version of the stuff on the screen"    dimForm _ Form fromDisplay: canvasRectangle.    dimForm        fill: dimForm boundingBox         rule: (dimForm depth < 16 ifTrue: [Form and] ifFalse: [Form under])        fillColor: (Color pixelScreenForDepth: dimForm depth).    "Create the BitBlts to render the changes with no flashing.  See render:.  We do dim->compositon, paint->composition, composition->display."    dimToComp _ (BitBlt toForm: worldForm)        sourceForm: dimForm;        combinationRule: Form over.    compToDisplay _ (BitBlt toForm: Display)        sourceForm: worldForm;         combinationRule: Form over.    picToComp _ (BitBlt toForm: worldForm)        sourceForm: paintingForm;        combinationRule: Form paint.    "establish colormaps if needed"    dimToComp colorMap:        (Color colorMapIfNeededFrom: dimToComp sourceForm depth                                  to: dimToComp destForm depth).    compToDisplay colorMap:        (Color colorMapIfNeededFrom: compToDisplay sourceForm depth                                  to: compToDisplay destForm depth).    picToComp colorMap:        (Color colorMapIfNeededFrom: picToComp sourceForm depth                                  to: picToComp destForm depth).! !!SketchEditorMorph methodsFor: 'start & finish'!getPaintingStartingWith: initialForm at: aRectangle    canvasRectangle _ bounds translateBy: self world viewBox origin.    composite _ self world paintArea origin.    paintingForm _ Form extent: canvasRectangle extent         depth: self world canvas depth.    self dimTheWindow.    "And set up the bitBlts"    dirty _ false.    initialForm ~~ nil ifTrue:        ["paintingForm copy: (0@0 extent: aRectangle extent)             from: 0@0 in: initialForm form rule: Form over."        initialForm displayOn: paintingForm             at: (aRectangle origin - bounds origin)            clippingBox: (0@0 extent: paintingForm extent)            rule: Form over            fillColor: nil.            "assume they are the same depth"        "initialForm displayOn: Display             at: (aRectangle translateBy: canvasRectangle origin) origin            clippingBox: (aRectangle translateBy: canvasRectangle origin)            rule: Form over            fillColor: nil."        ].    ^ self resumePainting.    ! !!SketchEditorMorph methodsFor: 'start & finish'!getRepaintedBackgroundStartingWith: startingForm    "Obtain a revised background painting from the user, given that the point of departure is startingForm, to be displayed in aRectangle."    | result |    result _ self getPaintingStartingWith: startingForm at: canvasRectangle.    ^ self deliverPainting: result    "Caller will want to fetch (aSketchEditorMorph painting) to get one that has not been trimmed"! !!SketchEditorMorph methodsFor: 'start & finish' stamp: 'sw 12/8/96'!getRepaintingStaringWith: startingForm at: aRectangle    "Obtain a revised painting from the user, given that the point of departure is startingForm, to be displayed at aRectangle.    : accept the new graphic even if no fresh paint laid down, so other edits can stick."    | result |    result _ self getPaintingStartingWith: startingForm at: aRectangle.    ^ self deliverPainting: result! !!SketchEditorMorph methodsFor: 'start & finish'!handlesMouseOver: evt    ^true! !!SketchEditorMorph methodsFor: 'start & finish' stamp: 'tk 3/14/97'!prepareToPaint    "Figure out what the current brush, fill, etc is.  Return an action to take every drag cycle.  Set up instance variable and pens.  Prep for normal painting is inlined here.      Use a composition form.  "    | specialMode temp |    "Install the brush, color, (replace mode), and cursor."    specialMode _ palette getSpecial.     currentColor  _ palette getColor.    brush _ temp _ palette getNib.    paintingFormPen _ Pen newOnForm: paintingForm.    specialMode == #paint: ifTrue: [        "get it to one bit depth.  For speed, instead of going through a colorMap every time ."        brush _ Form extent: brush extent depth: 1.        brush offset: (0@0) - (brush extent // 2).        temp displayOn: brush.        paintingFormPen sourceForm: brush.        paintingFormPen combinationRule: Form paint.        paintingFormPen color: currentColor.        currentColor = Color transparent ifTrue: [            paintingFormPen combinationRule: Form erase1bitShape.            paintingFormPen color: Color black].        ^ #layDownPaintStartingAt:     "paint:"].    specialMode == #transBrush: ifTrue: [        self transBrushPrep.        ^ #transBrush:].    "special brush in 32 bits, slewing buffer, double resolution"    specialMode == #areaFill: ifTrue: [        "Cursor bucket show.   ???"        ^ #areaFill:]."    specialMode == #gradientFill: ifTrue: [        ^ #gradientFill:].    Cursor bucket show.   ???""    specialMode == #gradientFillY: ifTrue: [        ^ #gradientFillY:].    Cursor bucket show.   ???""    specialMode == #gradientFillXY: ifTrue: [        ^ #gradientFillXY:].        Cursor bucket show.   ???"    specialMode == #replaceOnly: ifTrue: [        self replaceOnlyPrep.        ^ #replaceOnly:].    specialMode == #replaceAllBut: ifTrue: [        self replaceAllButPrep.        ^ #replaceOnly:].    "same inner loop works""    specialMode == #rotateScale: ifTrue: [        self rotateScalePrep.        ^ #rotateScale:].        now has sliders in picture window""    specialMode == #pickup: ifTrue: [        self pickupPrep.        ^ #pickup:].        Done entirely in the palette. Stores a form into savedBits"    specialMode == #stamp: ifTrue: [        "self stampPrep.        no prep needed"        ^ #stamp:].    "Don't recognise the command"    palette setAction: palette paint.    "set it to Paint"    ^ self prepareToPaint! !!SketchEditorMorph methodsFor: 'start & finish' stamp: 'tk 3/14/97'!resume    "Just came back from another window.  Keep painting.  Save the picture after.  "    ^ self deliverPainting: self resumePainting! !!SketchEditorMorph methodsFor: 'start & finish'!resumePainting    | mousePoint prevRedDown didIt stillScaling |    rotationButton _ BitBlt toForm: self world canvas form "composite".    "sets clipRect"    rotationButton sourceForm: nil; combinationRule: Form over.    "store"    rotationButton destX: canvasRectangle width // 2 - 6 + composite x;         destY: 0 + composite y; width: 12; height: 12.    rotationButton fillColor: Color green.    scaleButton _ BitBlt toForm: self world canvas form "composite".    "sets clipRect"    scaleButton sourceForm: nil; combinationRule: Form over.    "store"    scaleButton  destX: canvasRectangle width - 12 + composite x;         destY: canvasRectangle height //2 - 6 + composite y;         width: 12; height: 12; fillColor: Color green.    palette thumbnailOn: hostView.    "May be a sketchMorph.  Won't update picture"    self render: paintingForm boundingBox.    "show initially"    palette setRotation: hostView rotationStyle.    (canvasRectangle containsPoint: Sensor mousePoint) ifFalse: [^ #interrupt].    Cursor normal show.    "until put brush on cursor"    action _ self prepareToPaint.        "can't be rotate or scale"    prevRedDown _ false.    stillScaling _ false.        "[Sensor anyButtonPressed] whileTrue: []. Wait until mouse is clear "[true] whileTrue: [Sensor redButtonPressed     ifTrue:        [mousePoint _ Sensor mousePoint.        didIt _ false.        "Save and Cancel done from the palette now"        (rotationButton destRect containsPoint: mousePoint - self world viewBox origin) ifTrue: [                stillScaling ifFalse: [self rotateScalePrep. stillScaling _ true].                self rotateBy: mousePoint.    "does all the work"                rotationButton destX: canvasRectangle width // 2 + composite x.                self render: paintingForm boundingBox.                didIt _ true].         (scaleButton destRect containsPoint: mousePoint - self world viewBox origin) ifTrue: [                stillScaling ifFalse: [self rotateScalePrep. stillScaling _ true].                self scaleBy: mousePoint.    "does all the work"                scaleButton destY: canvasRectangle height //2 + composite y.                self render: paintingForm boundingBox.                didIt _ true].        didIt ifFalse: [        (canvasRectangle containsPoint: mousePoint)                ifFalse:                    [prevRedDown ifFalse: ["clicked outside"                        "hostView stillPainting: self."                        Cursor blank show.                        ^ #interrupt "save the state and come back"]                    "accidentally drew outside, keep going"]                ifTrue:                    [stillScaling ifTrue: [action _ self prepareToPaint.    "can be slow"                         stillScaling _ false].                    undoBuffer _ paintingForm deepCopy.    "know we will draw something"                    self perform: action with: mousePoint]].        prevRedDown _ true]    ifFalse: [prevRedDown _ false]]    "Watch out for Yellow-button in another window?"! !!SketchEditorMorph methodsFor: 'start & finish' stamp: 'tk 4/20/97'!save    "Palette is telling us that the use wants to end the painting session.  "    Cursor blank show.    self deliverPainting: #okay.! !!SketchEditorMorph methodsFor: 'start & finish' stamp: 'tk 4/3/97'!setRotations: num    "Tell the palette what number of rotations (or background) to show.  "    | key |    key _ 'ItTurns'.    "default and value for num > 1"    num == 1 ifTrue: [key _ 'JustAsIs'].    num == 18 ifTrue: [key _ 'ItTurns'].    num == 99 ifTrue: [key _ 'ToAndFro'].    num == #Background ifTrue: [key _ 'Background'].    num == #Repeated ifTrue: [key _ 'Repeated'].    palette setRotations: (palette contentsAtKey: key).! !!SketchEditorMorph methodsFor: 'start & finish' stamp: 'sw 8/13/96'!singleImageFromUser    "Let the user paint a single image, and return an array consisting of the form and its bounding box.  "    | result |    ticksToDwell _ 1.    result _ self getPaintingStartingWith: nil at: nil.    ^ self deliverPainting: result! !!SketchEditorMorph methodsFor: 'start & finish' stamp: 'tk 6/3/97'!undo    "revert to a previous state.  "    | temp |    undoBuffer         ifNil: [self beep]    "nothing to go back to"        ifNotNil: [temp _ paintingForm.            paintingForm _ undoBuffer.            undoBuffer _ temp.        "can get back to what you had by undoing again"            picToComp sourceForm: paintingForm.    "fix users of paintingForm"            self render: paintingForm boundingBox].! !!SketchEditorMorph methodsFor: 'actions & preps' stamp: 'tk 3/21/97'!areaFill: interiorPoint    "Find the area that is the same color as where you clicked.  Fill it with the current paint color.  "    Cursor execute showWhile:            [paintingForm shapeFill: self currentColor                 interiorPoint: interiorPoint - canvasRectangle origin.            self render: paintingForm boundingBox.    "show it"            dirty _ true].    Sensor waitNoButton.! !!SketchEditorMorph methodsFor: 'actions & preps' stamp: 'tk 3/15/97'!brushAlphaFromGray    "Get currentNib again, (a gray-scale Form) and transform it into an alpha brush.  "    | currentNib d alphaMap this alpha colorMaker newBox smallNib |    currentNib _ palette getNib.    newBox _ currentNib innerPixelRectFor: 0 orNot: true.    "minimum size"    smallNib _ Form extent: newBox extent depth: currentNib depth.    smallNib copyBits: newBox from: currentNib at: 0@0         clippingBox: smallNib boundingBox rule: Form over fillColor: nil."smallNib display.  newBox printString displayAt: 0@50."    d _ currentNib depth.    "usually 8"    alphaMap _ (Color cachedColormapFrom: d to: 32) copy.    "force a map to be there"    1 to: alphaMap size do: [:pixVal |        this _ Color colorFromPixelValue: pixVal-1 depth: d.        alpha _ 1.0 - this brightness.    "based on brightness"        "alpha _ alpha * 0.14 - 0.01."    "Adjust sensitivity for buffer depth"        "alpha _ alpha raisedTo: 2.0."    "Adjust sensitivity for buffer depth"        alphaMap at: pixVal                 put: ((currentColor alpha: alpha) pixelWordForDepth: 32)].        brush _ Form extent: smallNib extent depth: 32.    "brush offset: smallNib offset."    colorMaker _ BitBlt toForm: brush.    colorMaker sourceForm: smallNib; colorMap: alphaMap.    colorMaker sourceOrigin: 0@0; destOrigin: 0@0; combinationRule: Form over;        width: brush width; height: brush height; copyBits.    ^ brush    ! !!SketchEditorMorph methodsFor: 'actions & preps' stamp: 'tk 3/21/97'!gradientFill: interiorPoint    "Find the area that is the same color as where you clicked.  Fill it with a gradient of colors between the two mentioned in the palette.  "| bwForm tieDye pour color1 color2 |Cursor execute showWhile:        [bwForm _ paintingForm             shapeFill: (Color colorFromPixelValue: 0 depth: paintingForm depth)             interiorPoint: interiorPoint - canvasRectangle origin.        "cut a hole"        tieDye _ Form extent: paintingForm extent depth: paintingForm depth.        color1 _ (palette contentsAtKey: 'colorXMin') parameters at: #BoxColor.        color2 _ (palette contentsAtKey: 'colorXMax') parameters at: #BoxColor.        tieDye fillFromXColorBlock: [:x | Color             r: (color2 red * x) + (color1 red * (1.0-x))            g: (color2 green * x) + (color1 green * (1.0-x))            b: (color2 blue * x) + (color1 blue * (1.0-x))].        bwForm reverse displayOn: tieDye            at: 0@0            clippingBox: tieDye boundingBox            rule: Form erase1bitShape    "Cut away the stuff outside the fill area"            fillColor: nil.        pour _ BitBlt toForm: paintingForm.        pour sourceForm: tieDye; combinationRule: Form under.        pour destRect: paintingForm boundingBox; sourceOrigin: 0@0; copyBits.        self render: paintingForm boundingBox.    "show it"        dirty _ true].! !!SketchEditorMorph methodsFor: 'actions & preps' stamp: 'tk 3/21/97'!gradientFillXY: interiorPoint    "Find the area that is the same color as where you clicked.  Fill it with a gradient of colors between the two mentioned in the palette in both X and Y.  "| bwForm tieDye pour color1 color2 color3 |Cursor execute showWhile:        [bwForm _ paintingForm             shapeFill: (Color colorFromPixelValue: 0 depth: paintingForm depth)             interiorPoint: interiorPoint - canvasRectangle origin.        "cut a hole"        tieDye _ Form extent: paintingForm extent depth: paintingForm depth.        color1 _ (palette contentsAtKey: 'colorXMin') parameters at: #BoxColor.        color2 _ (palette contentsAtKey: 'colorXMax') parameters at: #BoxColor.        color3 _ (palette contentsAtKey: 'colorYMax') parameters at: #BoxColor.        tieDye fillFromXYColorBlock: [:x :y | Color             r: (color2 red * x * 0.5) + (color3 red * x * 0.5) + (color1 red * (2.0-x-y) * 0.5)            g: (color2 green * x * 0.5) + (color3 green * x * 0.5) + (color1 green * (2.0-x-y) * 0.5)            b: (color2 blue * x * 0.5) + (color3 blue * x * 0.5) + (color1 blue * (2.0-x-y) * 0.5)].        bwForm reverse displayOn: tieDye    "bwForm changed in place"            at: 0@0            clippingBox: tieDye boundingBox            rule: Form erase1bitShape    "Cut away the stuff outside the fill area"            fillColor: nil.        pour _ BitBlt toForm: paintingForm.        pour sourceForm: tieDye; combinationRule: Form under.        pour destRect: paintingForm boundingBox; sourceOrigin: 0@0; copyBits.        self render: paintingForm boundingBox.    "show it"        dirty _ true].! !!SketchEditorMorph methodsFor: 'actions & preps' stamp: 'tk 3/21/97'!gradientFillY: interiorPoint    "Find the area that is the same color as where you clicked.  Fill it with a gradient of colors between the two mentioned in the palette.  "| bwForm tieDye pour color1 color2 |Cursor execute showWhile:        [bwForm _ paintingForm             shapeFill: (Color colorFromPixelValue: 0 depth: paintingForm depth)             interiorPoint: interiorPoint - canvasRectangle origin.        "cut a hole"        tieDye _ Form extent: paintingForm extent depth: paintingForm depth.        color1 _ (palette contentsAtKey: 'colorXMin') parameters at: #BoxColor.        color2 _ (palette contentsAtKey: 'colorYMax') parameters at: #BoxColor.        tieDye fillFromYColorBlock: [:x | Color             r: (color2 red * x) + (color1 red * (1.0-x))            g: (color2 green * x) + (color1 green * (1.0-x))            b: (color2 blue * x) + (color1 blue * (1.0-x))].        bwForm reverse displayOn: tieDye    "bwForm changed in place"            at: 0@0            clippingBox: tieDye boundingBox            rule: Form erase1bitShape    "Cut away the stuff outside the fill area"            fillColor: nil.        pour _ BitBlt toForm: paintingForm.        pour sourceForm: tieDye; combinationRule: Form under.        pour destRect: paintingForm boundingBox; sourceOrigin: 0@0; copyBits.        self render: paintingForm boundingBox.    "show it"        dirty _ true].! !!SketchEditorMorph methodsFor: 'actions & preps' stamp: 'sw 11/28/96'!layDownPaintStartingAt: initialMousePoint    "While the mouse is down, lay down paint, but only within window bounds.     : no longer stop painting when pen strays out of window; once it comes back in, resume painting rather than waiting for a mouse up"    |  mousePoint startRect endRect |    mousePoint _ initialMousePoint.    paintingFormPen place: (mousePoint - canvasRectangle origin).    [Sensor redButtonPressed] whileTrue:        [mousePoint _ Sensor mousePoint.        startRect _ paintingFormPen location + brush offset extent: brush extent.        paintingFormPen goto: mousePoint - canvasRectangle origin.        endRect _ paintingFormPen location + brush offset extent: brush extent.        self render: (startRect merge: endRect).    "Show the user what happened"        dirty _ true]! !!SketchEditorMorph methodsFor: 'actions & preps'!notes    "Singleton costumes.Registration points"! !!SketchEditorMorph methodsFor: 'actions & preps' stamp: 'tk 5/6/97'!pickup: aPoint    "Grab a part of the picture (or screen) and store it in a known place.  Like Copy on the Mac menu.  Then switch to the stamp tool. (Not performed in the resumePainting, but called from PaintBox pickupMouseUp:)  "    | rr pp pForm |    rr _ Rectangle fromUser.    pp _ rr translateBy: (0@0) - canvasRectangle origin.    (pp intersects: paintingForm boundingBox) ifTrue: [        pForm _ paintingForm copy: pp.        pForm primCountBits > 0 ifTrue: [            ^ self save: pForm].    "normal case.  Can be transparent in parts"        "Get an un-dimmed picture of other objects on the playfield"        "don't know how yet"].    self save: (Form fromDisplay: rr).        "Anywhere on the screen"! !!SketchEditorMorph methodsFor: 'actions & preps' stamp: 'tk 3/27/97'!pickupPrep    "Grab a part of the picture (or screen) and store it in a known place.  Like Copy on the Mac menu.  Then switch to the stamp tool.  "    "temp _ Form fromUser."    PopUpMenu notify: 'Sorry, not implemented yet.  Please choose another tool.'.! !!SketchEditorMorph methodsFor: 'actions & preps' stamp: 'tk 3/19/97'!render: damageRect    "Compose the damaged area again and store on the display.  damageRect is relative to paintingForm origin.  "    | rect |    rect _ damageRect translateBy: composite.    "just within this window"    dimToComp destRect: rect;         sourceOrigin: damageRect origin; copyBits.    picToComp destRect: rect;         sourceOrigin: damageRect origin; copyBits.    rotationButton copyBits.    scaleButton copyBits.    compToDisplay sourceRect: rect;         destOrigin: canvasRectangle origin + damageRect origin; copyBits.! !!SketchEditorMorph methodsFor: 'actions & preps' stamp: 'sw 11/15/96'!replaceAllButPrep    "Let the user designate a color to retain, and a color to replace all the others with, then let him happily paint away -- derived from a method of Dan's, .  split "    | depth colorMap saveColor brushWidth len ppd |    brushWidth _ 8.    depth _ paintingForm depth.    colorMap _ Bitmap new: (1 bitShift: (depth min: 12)).  "Not calling newColorMap.  All             Length is 2 to 4096.".    ppd _ depth.    "256 long color map in depth 8 is not one of the following cases"    3 to: 5 do: [:bits |         len _ (2 raisedTo: bits*3).        len = colorMap size ifTrue: [ppd _ bits*3]].    saveColor _ palette repAllButColor color.    "Make the substitution in the color map"    colorMap atAllPut: (currentColor pixelValueForDepth: depth).    colorMap at: (saveColor pixelValueForDepth: ppd)+1            put: (saveColor pixelValueForDepth: depth).    "Build a BitBlt with that color map."    reColor _ (BitBlt toForm: paintingForm)        sourceForm: paintingForm;        combinationRule: Form over;        width: brushWidth; height: brushWidth;        colorMap: colorMap.    "put up brush as a cursor.  Later use brush as shape to be replaced"! !!SketchEditorMorph methodsFor: 'actions & preps' stamp: 'tk 3/15/97'!replaceOnly: initialMousePoint    "Paint replacing only one color!!  Call this each stroke.  Also works for replacing all but one color.  "    |  mousePoint |    mousePoint _ initialMousePoint - canvasRectangle origin.    reColor sourceOrigin: mousePoint;         destOrigin: mousePoint; copyBits.    self render: reColor destRect.        "show changed area"    dirty _ true.    [Sensor redButtonPressed] whileTrue:        [mousePoint _ Sensor mousePoint - canvasRectangle origin.        reColor sourceOrigin: mousePoint;             destOrigin: mousePoint; copyBits.        self render: reColor destRect.        "show changed area"        ]! !!SketchEditorMorph methodsFor: 'actions & preps' stamp: 'sw 11/15/96'!replaceOnlyPrep    "Let the user designate a color to erase, and a color to replace it with, then let him happily paint/erase away -- derived from a method of Dan's, .  Split into two parts & render from combined bitmap. "    | depth colorMap eraseColor brushWidth len ppd |    brushWidth _ 8.    "Set up a color map that leaves everything alone"    depth _ paintingForm depth.    colorMap _ (Color cachedColormapFrom: depth to: depth) copy.    "must not be nil"    colorMap at: 1 put: 0.    ppd _ depth.    "256 long color map in depth 8 is not one of the following cases"    3 to: 5 do: [:bits |         len _ (2 raisedTo: bits*3).        len = colorMap size ifTrue: [ppd _ bits*3]].    eraseColor _ palette repOnlyColor color.    "Make the substitution in the color map"    colorMap at: (eraseColor pixelValueForDepth: ppd)+1        put: (currentColor pixelValueForDepth: depth).    "Build a BitBlt with that color map."    reColor _ (BitBlt toForm: paintingForm)        sourceForm: paintingForm;        combinationRule: Form over;        width: brushWidth; height: brushWidth;        colorMap: colorMap.    "put up brush as a cursor.  Later use brush as shape to be replaced"! !!SketchEditorMorph methodsFor: 'actions & preps' stamp: 'tk 3/26/97'!rotateBy: initialPoint    "Left-right is rotation, up-down is scale.    Slider at top of window.  "| pt temp amt smooth |pt _ initialPoint - canvasRectangle center."cy _ canvasRectangle width * 45 // 100."smooth _ paintingForm depth > 8 ifTrue: [2] ifFalse: [2].    "When smoothing is 1, no problems with black halo in 16 bits (color mixing)"[Sensor redButtonPressed] whileTrue:    [amt _ pt x abs < 12 ifTrue: [0 "detent"] ifFalse: [pt x - (12 * pt x abs // pt x)].    temp _ buff rotateBy: amt * 1.8 + cumRot magnify: cumMag smoothing: smooth.    temp displayOn: paintingForm at: (paintingForm center - temp center + buff offset).    rotationButton destX: amt - 6 + (canvasRectangle width // 2) + composite x.    self render: paintingForm boundingBox.    pt _ Sensor mousePoint - canvasRectangle center.    dirty _ true].cumRot _ amt * 1.8 + cumRot.    "what we settled on"! !!SketchEditorMorph methodsFor: 'actions & preps' stamp: 'di 6/29/97 09:54'!rotateScalePrep    "Make a source that is the paintingForm.  Work from that.  "    | newBox field |    paintingForm width > 120         ifTrue: [newBox _ paintingForm innerPixelRectFor: 0 orNot: true.            "minimum size"            newBox _ newBox insetBy:                 ((18 - newBox width max: 0)//2) @ ((18 - newBox height max: 0)//2) * -1]        ifFalse: [newBox _ paintingForm boundingBox].    newBox _ newBox expandBy: 1.    buff _ Form extent: newBox extent depth: paintingForm depth.    buff offset: newBox center - paintingForm center.    buff copyBits: newBox from: paintingForm at: 0@0         clippingBox: buff boundingBox rule: Form over fillColor: nil.    "Could just run up owner chain asking colorUsed, but may not be embedded"    "field _ self world findA: PlayfieldMorph."    field ifNil: [field _ self world].    "Right color for edge of object to merge with"    cumRot _ 0.0.  cumMag _ 1.0.    "start over"! !!SketchEditorMorph methodsFor: 'actions & preps' stamp: 'tk 3/26/97'!scaleBy: initialPoint    "up-down is scale.    Now a slider on the right  "| pt temp cy oldRect amt |pt _ initialPoint - canvasRectangle center.cy _ canvasRectangle height * 0.5.temp _ buff.[Sensor redButtonPressed] whileTrue:    [oldRect _ temp boundingBox.    amt _ pt y abs < 12 ifTrue: [1.0 "detent"] ifFalse: [pt y- (12 * pt y abs // pt x)].    temp _ buff rotateBy: cumRot magnify: (amt asFloat / cy + 1.0) * cumMag             smoothing: 2.    oldRect width > temp width ifTrue: ["shrinking"        oldRect _ oldRect translateBy: (paintingForm center - oldRect center + buff offset).        paintingForm fill: (oldRect expandBy: 1@1) rule: Form over fillColor: Color transparent].    temp displayOn: paintingForm at: (paintingForm center - temp center + buff offset).    scaleButton destY: pt y - 6 + (canvasRectangle height // 2) + composite y.    self render: paintingForm boundingBox.    pt _ Sensor mousePoint - canvasRectangle center.    dirty _ true].cumMag _ cumMag * (amt asFloat / cy + 1.0).    "what we settled on"! !!SketchEditorMorph methodsFor: 'actions & preps' stamp: 'tk 4/23/97'!stamp: aPoint    "plop one copy of the user's chosen Form down.  It is saved in savedBits.  Later it will be in the Palette.  "    savedBits ifNil: [^ PopUpMenu notify:                 'First PickUp a picture.  Click PickUp in the Palette'].    Sensor redButtonPressed ifTrue: [        "Check depths"        savedBits displayOn: paintingForm             at: aPoint - canvasRectangle origin            clippingBox: paintingForm boundingBox            rule: Form paint            fillColor: nil.        self render: (aPoint - canvasRectangle origin extent: savedBits extent).    ].! !!SketchEditorMorph methodsFor: 'actions & preps' stamp: 'tk 3/27/97'!stampPrep    "Place one copy of the picBuffer into the picture each time the user clicks.  "    "temp _ Form fromUser."    PopUpMenu notify: 'Sorry, not implemented yet.  Please choose another tool.'.! !!SketchEditorMorph methodsFor: 'actions & preps' stamp: 'tk 3/21/97'!transBrush: initialMousePoint    "Paint with a semi-transparent brush.  Call this each stroke.  , di"    |  prevP p buffSize theta brushRect buffRect delta newBuffRect updateRect scale half |    scale _ buffToPic cellSize.    "2"    buffSize _ (buff width - brush width) // scale.    "100"    half _ brush extent // 2.    "center"    "buffRect now relative to pictureForm"    buffRect _ (Sensor cursorPoint - canvasRectangle origin) - (buff extent // scale // 2)         extent: buff extent // scale.    picToBuff copyQuad: buffRect innerCorners toRect: buff boundingBox.    prevP _ ((initialMousePoint - canvasRectangle origin) - buffRect origin) * scale - half.    [Sensor redButtonPressed] whileTrue:        [p _ ((Sensor mousePoint - canvasRectangle origin) - buffRect origin) * scale - half.                "p, prevP are rel to buff origin"        p ~= prevP ifTrue: [        (p farFrom: prevP by: 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-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 new areas 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 | picToBuff 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.        "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.        "And finally store into the painting""buff displayAt: 0@0."        buffToPic copyQuad: updateRect innerCorners                    toRect: (updateRect origin // scale + buffRect origin                                extent: updateRect extent // scale).        prevP _ p.        dirty _ true.        self render: (updateRect origin // scale + buffRect origin                                        extent: updateRect extent // scale)]].! !!SketchEditorMorph methodsFor: 'actions & preps' stamp: 'tk 3/26/97'!transBrushPrep    "Prepare to paint with a transparent brush at twice the resolution.  Do the work in 32-bits.  See BitBlt.alphaBlendDemo8 for details.  "    | buffSize scale cm1 cm2 |    currentColor class == Bitmap ifTrue: [currentColor _ palette getColor]. "do not force white"    brush _ self brushAlphaFromGray.    "Get currentNib again,         (a gray-scale Form) and transform it into an alpha brush"    scale _ 3.  "Actual drawing happens at this magnification"    "Scale brush up for painting in magnified buffer"    brush _ brush magnify: brush boundingBox by: scale.    buffSize _ 100.    buff _ Form extent: (buffSize * scale) asPoint + brush extent depth: 32.  "Travelling 32-bit buffer"    picToBuff _ (WarpBlt toForm: buff)  "from Picture to buff - magnify by 2"        sourceForm: paintingForm;        combinationRule: Form over.    cm1 _ (Color cachedColormapFrom: paintingForm depth to: 32) copy.    cm1 ifNotNil: [        "map off-the-edge pixels to the background color, so blend will look right at edge"        cm1 at: 1 put: (self world color pixelValueForDepth: 32)].    picToBuff colorMap: cm1.    brushToBuff _ (BitBlt toForm: buff)  "from brush to buff"        sourceForm: brush;        sourceOrigin: 0@0;        combinationRule: Form blend.    "use buffToPic instead of paintingFormPen"    buffToPic _ (WarpBlt toForm: paintingForm)  "from buff to Picture - shrink by 2"        sourceForm: buff;        cellSize: scale;    "...and use smoothing"        combinationRule: Form over.    cm2 _ (Color cachedColormapFrom: 32 to: paintingForm depth) copy.    cm2 ifNotNil: [        "remap background color to transparent"        cm2 at: (self world color indexInMap: cm2) put: 0].    buffToPic colorMap: cm2.    buffToBuff _ BitBlt toForm: buff.  "for slewing the buffer"! !!SketchEditorMorph methodsFor: 'actions & preps' stamp: 'tk 3/15/97'!transBrushPrepW    "Prepare to paint with a transparent brush.  Do the work in 32-bits.alphaBlendDemo4 for details.  See BitBlt.  "    | buffSize |    currentColor class == Bitmap ifTrue: [currentColor _ palette getColor]. "do not force white"    brush _ self brushAlphaFromGray.    "Get currentNib again,         (a gray-scale Form) and transform it into an alpha brush"    buffSize _ 100.    buff _ Form extent: brush extent + buffSize depth: 32.  "Travelling 32-bit buffer"    paintingFormPen sourceForm: buff.    "nils colorMap!!"    paintingFormPen colorMap:         (Color colorMapIfNeededFrom: 32 to: paintingForm depth).    picToBuff _ BitBlt toForm: buff.  "This is from Display to buff"    picToBuff colorMap:        (Color colorMapIfNeededFrom: paintingForm depth to: 32).    brushToBuff _ BitBlt toForm: buff.  "This is from brush to buff"    brushToBuff sourceForm: brush.    brushToBuff sourceOrigin: 0@0; combinationRule: Form blend.    buffToBuff _ BitBlt toForm: buff.  "This is for slewing the buffer"! !!SketchEditorMorph methodsFor: 'actions & preps' stamp: 'tk 3/21/97'!transBrushW: initialMousePoint    "Paint with a semi-transparent brush.  Call this each stroke.  , di"    |  prevP p buffSize theta brushRect buffRect delta newBuffRect updateRect |    prevP _ p _ initialMousePoint - canvasRectangle origin.    buffSize _ 100.    "buffRect now relative to pictureForm"    buffRect _ Sensor cursorPoint - canvasRectangle origin - (buffSize // 2) extent: buff extent.    picToBuff copyFrom: buffRect in: paintingForm to: 0@0.    [Sensor redButtonPressed] whileTrue:        [p _ Sensor mousePoint - canvasRectangle origin.        (p farFrom: prevP by: 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 new areas 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 | picToBuff copyFrom: r in: paintingForm                         to: r origin - newBuffRect origin].            buffRect _ newBuffRect].        brushToBuff drawFrom: prevP - buffRect origin to: p - buffRect origin.        "Update only the altered pixels of the destination"        updateRect _ (p min: prevP) corner: (p max: prevP) + brush extent.        paintingFormPen copy: updateRect from: updateRect origin - buffRect origin in: buff.            "paintingFormPen copyFrom: (0@0 extent: buffRect extent)                     in: buff to: buffRect origin."        prevP _ p.        dirty _ true.        self render: buffRect].! !!SketchEditorMorph methodsFor: 'old?' stamp: 'sw 11/14/96'!getPositionFrom: oldPosition    "Obtain a position designation from the user, showing feedback re the previous position if relevant.  Used to obtain centers of rotation and registration points.  "    oldPosition == nil ifFalse:        [self flag: #deferred.  "Give old-position feedback"].    Cursor crossHair showWhile: [Sensor waitClickButton].    ^ Sensor mousePoint! !!SketchEditorMorph methodsFor: 'old?'!paintAnotherFrame    self notYetImplemented! !!SketchEditorMorph methodsFor: 'old?'!setCenterOfRotation    | aPosition |    true ifTrue: [self beep.  ^ self notYetImplemented].    aPosition _ self getPositionFrom: nil.    self flag: #deferred.  "Want to obtain old location from somewhere"    aPosition == nil ifTrue: [^ self].    rotationCenter _ aPosition - hostView insetDisplayBox origin! !!SketchEditorMorph methodsFor: 'old?' stamp: 'sw 11/19/96'!setCustomNib    "Let the user designate a custom nib to use.  , derived from code supplied  di"    | selection interiorPoint interiorColor brush2 |    selection _ Form fromUser.    "determine color at the middle"    interiorPoint _ selection extent // 2.    interiorColor _ selection colorAt: interiorPoint.    "make a BW  form with interior color -> black"    brush2 _ (selection makeBWForm: interiorColor).    "get rid of everything that's not contiguous with the center"    brush2 _ brush2 reverse findShapeAroundSeedBlock:                [:f | f pixelValueAt: interiorPoint put: 1].    "trim the result to minimum size"    brush2 _ brush2 trimToPixelValue: 1 orNot: false.    self eachPenDo: [:aPen | aPen sourceForm: brush2]! !!SketchEditorMorph methodsFor: 'old?'!setRegistrationPoint    | aPosition aDot |    true ifTrue: [self beep.  ^ self notYetImplemented].    registrationPoint == nil ifTrue: [registrationPoint _ canvasRectangle  extent // 2].    (Form dotOfSize: 5) displayAt: hostView insetDisplayBox origin + registrationPoint.    aPosition _ self getPositionFrom: registrationPoint.    self flag: #deferred.  "Want to obtain old location from somewhere"    aPosition == nil ifTrue: [^ self].    Transcript cr; show: 'point = ', aPosition printString.    registrationPoint _ aPosition - hostView insetDisplayBox origin! !!SketchEditorMorph methodsFor: 'old?'!setTicksToDwell    | result |    result _ FillInTheBlank request: 'Dwell on this frame forhow many ticks? ' initialAnswer: self ticksToDwell printString.    result == nil        ifFalse: [ticksToDwell _ result asNumber]! !!SketchEditorMorph class methodsFor: 'instance creation' stamp: 'di 6/22/97 09:07'!includeInNewMorphMenu    "Not to be instantiated from the menu"    ^ false! !!SketchMorph methodsFor: 'initialization'!initialize    super initialize.    originalForm _ (Form extent: 14@10 depth: 8) fillColor: Color gray.    rotationCenter _ 7@5.        "relative to the top-left corner of the Form"    rotationDegrees _ 0.0.        "counter-clockwise angle of rotation"    rotationStyle _ #normal.        "styles: #normal, #leftRight, #upDown, or #none"    framesToDwell _ 1.    rotatedForm _ originalForm.    "cached rotation of originalForm"    offsetWhenRotated _ 0@0.    "offset for rotated form"    self extent: originalForm extent.! !!SketchMorph methodsFor: 'accessing'!form    ^ originalForm! !!SketchMorph methodsFor: 'accessing'!form: aForm    originalForm _ aForm.    rotationCenter _ aForm extent // 2.    rotationDegrees _ 0.0.    "coming in unrotates, is base picture"    offsetWhenRotated _ 0@0.    "cancel leftover one"    self layoutChanged.! !!SketchMorph methodsFor: 'accessing'!framesToDwell    ^ framesToDwell! !!SketchMorph methodsFor: 'accessing'!framesToDwell:  anInteger    framesToDwell _ anInteger.! !!SketchMorph methodsFor: 'accessing'!referencePosition    ^ (bounds origin - offsetWhenRotated) + rotationCenter! !!SketchMorph methodsFor: 'accessing'!referencePosition: aPoint    self position: (aPoint - rotationCenter) + offsetWhenRotated.! !!SketchMorph methodsFor: 'accessing'!rotatedForm    rotatedForm ifNil: [self layoutChanged].    ^ rotatedForm! !!SketchMorph methodsFor: 'accessing'!rotationCenter    ^ rotationCenter! !!SketchMorph methodsFor: 'accessing'!rotationCenter:  aPoint    rotationCenter _ aPoint.    self layoutChanged.! !!SketchMorph methodsFor: 'accessing'!rotationDegrees    ^ rotationDegrees! !!SketchMorph methodsFor: 'accessing'!rotationDegrees: angleInDegrees    rotationDegrees ~=  angleInDegrees ifTrue: [        rotationDegrees _ angleInDegrees \\ 360.0.        self layoutChanged].! !!SketchMorph methodsFor: 'accessing'!rotationStyle    ^ rotationStyle! !!SketchMorph methodsFor: 'accessing'!rotationStyle:  aSymbol    "Set my rotation style to #normal, #leftRight, #upDown, or #none. Styles mean:        #normal        -- continuous 360 degree rotation        #leftRight        -- quantize angle to left or right facing        #upDown        -- quantize angle to up or down facing        #none            -- do not rotate"    rotationStyle _ aSymbol.    self layoutChanged.! !!SketchMorph methodsFor: 'drawing'!drawOn: aCanvas    aCanvas image: self rotatedForm at: bounds origin.! !!SketchMorph methodsFor: 'geometry-testing'!containsPoint: aPoint    ^ (self bounds containsPoint: aPoint) and:      [(self rotatedForm isTransparentAt: aPoint - bounds origin) not]! !!SketchMorph methodsFor: 'menu'!addCustomMenuItems: aCustomMenu hand: aHandMorph    | movies |    super addCustomMenuItems: aCustomMenu hand: aHandMorph.    aCustomMenu add: 'edit drawing' action: #editDrawing.    aCustomMenu add: 'set rotation center' action: #setRotationCenter.    movies _        (self world rootMorphsAt: aHandMorph targetOffset)            select: [:m | (m isKindOf: MovieMorph) or:                        [m isKindOf: SketchMorph]].    (movies size > 1) ifTrue: [        aCustomMenu add: 'insert into movie' action: #insertIntoMovie:].! !!SketchMorph methodsFor: 'menu'!editDrawing    self editDrawingInWorld: self world.! !!SketchMorph methodsFor: 'menu' stamp: 'jm 9/28/97 19:36'!editDrawingInWorld: w    | oldRotation aPaintWindow startForm where |    w displayWorld.    aPaintWindow _ SketchEditorMorph new initializeFor: self.    oldRotation _ rotationDegrees.    self rotationDegrees: 0.    where _ self position extent: self form extent.    startForm _ self form deepCopy.    self rotationDegrees: oldRotation.    "while drawing is still rotated.  Cancel leaves it right"    aPaintWindow afterNewPicDo: [:aForm :aRect |        self form: aForm.        self position: aRect origin.        self rotationDegrees: oldRotation.        owner changed].    w addMorphFront: aPaintWindow.    aPaintWindow changed.    Cursor normal showWhile: [        aPaintWindow deliverPainting:             (aPaintWindow getPaintingStartingWith: startForm                at: where)].! !!SketchMorph methodsFor: 'menu'!insertIntoMovie: evt    | movies target |    movies _        (self world rootMorphsAt: evt hand targetOffset)            select: [:m | ((m isKindOf: MovieMorph) or:                         [m isKindOf: SketchMorph]) and: [m ~= self]].    movies isEmpty ifTrue: [^ self].    target _ movies first.    (target isKindOf: SketchMorph) ifTrue: [        target _ target replaceSelfWithMovie].    target insertFrames: (Array with: self).    self delete.! !!SketchMorph methodsFor: 'menu'!replaceSelfWithMovie    "Replace this SketchMorph in its owner with a MovieMorph containing this sketch as its only frame. This allows a SketchMorph to be turned into a MovieMorph by just insering additional frames."    | movie |    self changed.    movie _ MovieMorph new position: self referencePosition.    movie insertFrames: (Array with: self).    owner ifNil: [^ movie].    owner addMorphFront: movie.    self delete.    ^ movie! !!SketchMorph methodsFor: 'menu'!setRotationCenter    | oldRotation p |    oldRotation _ rotationDegrees.    self rotationDegrees: 0.    self world displayWorld.    Cursor crossHair showWhile:        [p _ Sensor waitButton - self world viewBox origin].    self rotationCenter: p - bounds origin.    self rotationDegrees: oldRotation.! !!SketchMorph methodsFor: 'change reporting'!layoutChanged    "Update rotatedForm and offsetWhenRotated and compute new bounds."    | unrotatedOrigin |    self changed.    unrotatedOrigin _ bounds origin - offsetWhenRotated.    (rotationDegrees = 0.0 or: [rotationStyle = #none])        ifTrue: [            "zero rotation; use original Form"            rotatedForm _ originalForm.            offsetWhenRotated _ 0@0]        ifFalse: [self generateRotatedForm].    "changes offsetWhenRotated"    bounds _ (unrotatedOrigin + offsetWhenRotated) extent: rotatedForm extent.    super layoutChanged.    self changed.! !!SketchMorph methodsFor: 'other' stamp: 'jm 6/30/97 15:30'!colorUnder    "Return the color of under the receiver's reference position."    | w |    w _ self world.    w == nil        ifTrue: [^ self color]        ifFalse: [^ w colorAt: self referencePosition belowMorph: self].! !!SketchMorph methodsFor: 'other'!generateRotatedForm    "Compute my rotatedForm and offsetWhenRotated."    | pair |    rotationStyle = #leftRight ifTrue: [        (rotationDegrees >= 270.0 or: [rotationDegrees <= 90.0]) ifTrue: [            rotatedForm _ originalForm.  "right"            offsetWhenRotated _ 0@0.        ] ifFalse: [  "left"            rotatedForm _ originalForm flipBy: #horizontal centerAt: 0@0.            offsetWhenRotated _ (2 * (rotationCenter x - (originalForm width // 2)))@0.        ].        ^ self].    rotationStyle = #upDown ifTrue: [        rotationDegrees <= 180.0 ifTrue: [            rotatedForm _ originalForm.  "up"            offsetWhenRotated _ 0@0.        ] ifFalse: [  "down"            rotatedForm _ originalForm flipBy: #vertical centerAt: 0@0.            offsetWhenRotated _ 0@(2 * (rotationCenter y - (originalForm height // 2))).        ].        ^ self].    "do the actual rotation!!"    pair _ WarpBlt        rotate: originalForm        degrees: rotationDegrees        center: rotationCenter        smoothing: 1.    rotatedForm _ pair first.    offsetWhenRotated _ pair last.! !!SketchMorph methodsFor: 'other'!prepareToBeSaved    "Clear cached of rotated form."    super prepareToBeSaved.    rotatedForm _ nil.! !!SketchMorph methodsFor: 'other'!wearCostume: aMorph    "If the receiver and argument are both kinds of SketchMorph, make the receiver wear the costume of the argument. Otherwise, do nothing. This default implementation does nothing."    | p |    ((aMorph isKindOf: SketchMorph) or:     [aMorph isKindOf: MovieMorph]) ifTrue: [        self changed.        p _ self referencePosition.        originalForm _ aMorph form.        rotationCenter _ aMorph rotationCenter.        self referencePosition: p.        self layoutChanged].! !!SlantedList methodsFor: 'input events'!listPane1MenuButtonPressed: arg1    self confirm: 'Should the menu be slanted too?'! !!SlantedList methodsFor: 'input events'!listPane1NewSelection: arg1    string1 contents: arg1! !!SlantedList methodsFor: 'input events'!slider1Value: arg1    transform1 scale: slider1 value * 5.0 + 0.2! !!SlantedList methodsFor: 'input events'!slider2Value: arg1    transform1 offset: ((slider4 value @ slider2 value) * 400 - 200) asIntegerPoint! !!SlantedList methodsFor: 'input events'!slider3Value: arg1    transform1 angle: slider3 value - 0.5 * Float pi * 2! !!SlantedList methodsFor: 'input events'!slider4Value: arg1    transform1 offset: ((slider4 value @ slider2 value) * 400 - 200) asIntegerPoint! !!Slider methodsFor: 'initialize'!initialize    super initialize.    bounds := 0@0 corner: 16@100.    color := Color gray.    borderWidth := 2.    borderColor := #inset.    value _ 0.0.    self initializeSlider! !!Slider methodsFor: 'initialize'!initializeSlider    slider := RectangleMorph newBounds: self totalSliderArea color: Color veryLightGray.    slider on: #mouseStillDown send: #scrollAbsolute: to: self.    slider setBorderWidth: 2 borderColor: #raised.    self addMorph: slider.    self computeSlider.! !!Slider methodsFor: 'access'!value    ^ value! !!Slider methodsFor: 'access' stamp: '6/7/97 10:42 di'!wantsSlot    "For now do it the old way, until we sort this out"    ^ true! !!Slider methodsFor: 'geometry'!computeSlider    | r |    r _ self roomToMove.    slider position: (bounds isWide        ifTrue: [r topLeft + ((r width * value) asInteger @ 0)]        ifFalse: [r topLeft + (0 @ (r height * value)  asInteger)]).    slider extent: self sliderExtent! !!Slider methodsFor: 'geometry'!extent: aPoint    super extent: (aPoint x max: self sliderThickness * 2)                    @ (aPoint y max: self sliderThickness * 2).    self removeAllMorphs; initializeSlider! !!Slider methodsFor: 'geometry'!roomToMove    ^ self totalSliderArea insetBy: (0@0 extent: self sliderExtent)! !!Slider methodsFor: 'geometry'!sliderExtent    ^ bounds isWide        ifTrue: [self sliderThickness @ self innerBounds height]        ifFalse: [self innerBounds width @ self sliderThickness]! !!Slider methodsFor: 'geometry'!sliderThickness    ^ 6! !!Slider methodsFor: 'geometry'!totalSliderArea    ^ self innerBounds! !!Slider methodsFor: 'scrolling'!scrollAbsolute: event    | r p |    r _ self roomToMove.    p _ event targetPoint adhereTo: r.    self setValue: (bounds isWide         ifTrue: [(p x - r left) asFloat / r width]        ifFalse: [(p y - r top) asFloat / r height])! !!Slider methodsFor: 'model access'!setValue: newValue    "Called internally for propagation to model"    self value: newValue.    self use: setValueSelector orMakeModelSelectorFor: 'Value:'        in: [:sel | setValueSelector _ sel.  model perform: sel with: value]! !!Slider methodsFor: 'model access'!value: newValue    "Drive the slider position externally..."    value _ newValue min: 1.0 max: 0.0.    self computeSlider! !!SmallInteger methodsFor: 'comparing'!hash    ^self! !!SmallInteger methodsFor: 'comparing'!identityHash    ^self! !!SmallInteger methodsFor: 'comparing' stamp: 'di 9/27/97 20:32'!identityHashMappedBy: map    ^ self! !!SmallInteger methodsFor: 'converting'!adaptToFloat    "Fast conversion equivalent to self asFloat."    <primitive: 40>    self primitiveFailed! !!SmallInteger methodsFor: 'printing'!printOn: aStream base: b    "Refer to the comment in Integer|printOn:base:."    "SmallInteger maxVal printStringBase: 2"    | digitsInReverse x i |    self < 0 ifTrue: [        aStream nextPut: $-.        ^ self negated printOn: aStream base: b.    ].    b = 10 ifFalse: [aStream print: b; nextPut: $r].    digitsInReverse _ Array new: 32.    x _ self.    i _ 0.    [x >= b] whileTrue: [        digitsInReverse at: (i _ i + 1) put: x \\ b.        x _ x // b.    ].    digitsInReverse at: (i _ i + 1) put: x.    [i > 0] whileTrue: [        aStream nextPut: (Character digitValue: (digitsInReverse at: i)).        i _ i - 1.    ].! !SmartRefStream comment:'Ordinary ReferenceStreams cannot bring in objects whose instance variables have changed.  This class does that.  1/13/97 tk>>>>See SmartRefStream.aComment for details of how to transform incoming classes to newer versions.<<<< * Allows incoming object to have fewer instance variables than the current class.* Recognises that conversion to new versions is only done after the fact.  Nothing special needs to be done at object file write time.  Prompts for a new version number when there are new inst vars with same initials, and tells how to make conversion work when some files have already been written.* Works best with only one (large) tree of objects per file.  Can nextPut: more than once, but each gets its own class structure, which is big.  Writes triplets of (version, class structure dictionary, object) on the file.  Has methods for creating the structure description for file-out.* Version of a class is indicated by the first letters of all instance varaibles followed by a class version number.  Form has inst vars "bits width height depth offset ", so version 2 of it has version tag #bwhdo2.* Methods to convert versions of objects are named     Form new convertbwhdo2: aDictionary bwhdo3: aSmartRefStream.Note that aDictionary has (old inst var name -> value) * There is a dispatch method to avoid N squared conversions when there are lots of old versions.  It can cascade calls on conversion methods. (not yet)* Prompts the user to write (or file in) a conversion method when needed.* (Does not use DiskProxy, DiskProxyQ, or IOWeakArray)writing        true if writing a file.  To avoid mixing next with nextPut:.structures     Dictionary of (#Rectangle -> #(<classVersionInteger> origin corner)).  Inst                 var names are strings.steady         Set of Classes who have the same structure now as on the incoming file.                Includes classes with same inst vars except some added on end now.reshaped     Dictionary of Classes who have a different structure now as on the incoming file.                  Includes those with same inst vars but new version number.                (old class name -> method selector to fill in data for version to version)renamed    Dictionary of Classes who have a different name.                 (old class name symbol -> new class name).  Then look new class up in reshaped.topCall        Tells if next or nextPut: coming from the outside.  nil if outside, a Context if                 internal call.>>>>> See DataStream.typeIDFor: for where the tangle of objects is clipped, so the whole system will not be written on the file. '!!SmartRefStream methodsFor: 'all'!aComment"SmartRefStream implements the 'Seeds' object storage system.  Please see the class comment.Headlines:    To bring in an instance of a class whose instance variables have changed, you need only define one conversion method.  The method is named    convertxxxxx: aDictionary yyyyyy: aSmartRefStream.Where xxxxxx is the first letters of all the instance variables in the old instance, and yyyyy are the first letters of all instance variables in the current version of the class.  A Form has inst vars 'bits width height depth offset', so version 2 of it has version tag #bwhdo2.  If the old instance had variables 'bitMap extent depth offsetPoint textDescription', its code would be #bedot0.    Form new convertbedot0: aDictionary bwhdo3: aSmartRefStream.All you have to do is to write the method.  aDictionary has entries (old inst var name -> value), so you can fetch the old vars by name.  See SmartRefStream.catalogValues:size:.  aSmartRefStream is available so you can get at 'structures' which tells the inst vars of other old classes in this file.In the Squeak Goodies Folder, we provide an example.    Suppose there once was a file named ArrayTwoDee.  If it like Array2D in this system, but is implemented differently.  ArrayTwoDee was defined like this: (Array variableSubclass: #ArrayTwoDee instanceVariableNames: 'height '...) so it is a variable class with the array values directly in the instance.      Array2D uses an instance var for 'contents' instead.   It has width varying most quickly, whereas the old ArrayTwoDee had height varying first.  The order of the elements must be changed.    File in the file ConvArrayTwoDee2.st.It defines SmartRefStream.arrayTwoDeeh2 to return Array2D, so we know what class to convert to.It defines Array2D.converth2:wc0: to do the actual conversion.  Look at the method.  The method 'test' has the code for actually doing the conversion:    | new2D ss |    ss _ SmartRefStream fileNamed: 'ArrayTwoDee.test.obj'.    new2D _ ss next.    ss close.    new2D class == Array2D ifFalse: [self error: 'Class conversion failed'].    (new2D atCol: 1) = #(1 2 3 4) ifFalse: [self error: 'not flipped properly'].    ^ new2D    The file ArrayTwoDee.test.obj has the object data in it, and is the actual file we converted.  Note that we never had to file in the old class ArrayTwoDee.  It is never needs to be defined in our system.      If ArrayTwoDee held an instance variable of another old class, say WeirdNumber, what form would it be in when converth2:wc0: gets run?  All objects get assigned instances in the current system before they are put into the value dictionary.  Generally, leaves of the object tree get converted first, so the values in an instance variable should be fully functioning objects in the current system."! !!SmartRefStream methodsFor: 'all' stamp: 'tk 1/7/97'!catalogValues: instVarList size: varsOnDisk    "Create a dictionary of (name -> value) for the inst vars of this reshaped object.  Indexed vars as (1 -> val) etc.  "    | dict sz |    dict _ Dictionary new.    2 to: instVarList size do: [:ind |        dict at: (instVarList at: ind) put: self next].    sz _ varsOnDisk - (instVarList size - 1).    1 to: sz do: [:ii |         dict at: ii put: self next].    "Total number read MUST be equal to varsOnDisk!!"    sz > 0 ifTrue: [dict at: #SizeOfVariablePart put: sz].    ^ dict! !!SmartRefStream methodsFor: 'all' stamp: 'tk 1/10/97'!fixObjVer1: className    "Temporary bug fix.  Old obj files have no structure entry for Obj and other HyperSqueak classes that have unique instances.  Add the data to structures.  Will also have to read in ObjConvertDec96.st  "    | data ind |    Smalltalk at: #Obj ifAbsent: [^ self].    "non HyperSqueak"    data _ #( "Alias" ()  "BooleanObj" ()  "FastObj" ('blitter' 'fastVelocity ')         "Folder" ('contentsDictionary') "NumberObj" ()         "Obj" (0 'dependents' 'objectContainedIn' 'workingsBackToFront' 'workingsDictionary' 'contents' 'costumes' 'currentCostume' 'parameters' 'canvas' 'canvasValid' 'layoutRectangle' 'windowBounds' 'flags' 'velocity' 'type' 'heading' 'speed' 'pen' )        "StringObj" ()  "TextObj" ('prevTextFrame' 'nextTextFrame' 'suppressDisplay')).    ind _ #(Alias BooleanObj FastObj Folder NumberObj Obj StringObj TextObj) indexOf: className.    ind = 0 ifTrue: [^ self].    structures at: className put:         (className == #Obj                ifTrue: [data at: ind]                ifFalse: [(data at: 6 "Obj"), (data at: ind)]).    self verifyStructure! !!SmartRefStream methodsFor: 'all' stamp: 'tk 9/10/97 21:11'!instVarInfo: anObject    "Return the object to write on the outgoing file that contains the structure of each class we are about to write out.  Must be an Array whose first element is 'class structure'.  Its second element is a Dictionary of pairs of the form #Rectangle -> #(<classVersion> 'origin' 'corner').  "    "Make a pass through the objects, not writing, but recording the classes.  Construct a database of their inst vars and any version info (classVersion)."    | dummy refs cls newSupers |    dummy _ ReferenceStream on: (DummyStream on: nil).        "Write to a fake Stream, not a file"    "Collect all objects"    dummy rootObject: anObject.    "inform him about the root"    dummy nextPut: anObject.    refs _ dummy references.    structures _ Dictionary new.    superclasses _ Dictionary new.    objCount _ refs size.        "for progress bar"        "Note that Dictionary must not change its implementation!!  If it does, how do we read this reading information?"    refs keysDo: [:each |         cls _ each class.        (cls category asString = 'HyperSqueak-UserObjects')             ifTrue: [structures at: cls officialClass name put: false]             ifFalse: [structures at: cls name put: false]].    "Save work by only computing inst vars once for each class"    newSupers _ Set new.    structures keysDo: [:nm |         cls _ Smalltalk at: nm.        cls allSuperclasses do: [:aSuper |            structures at: aSuper name ifAbsent: [newSupers add: aSuper name]]].            "Don't modify structures during iteration"    newSupers do: [:nm | structures at: nm put: 3].    "Get all superclasses into list"    structures keysDo: [:nm | "Nothing added to classes during loop"        cls _ Smalltalk at: nm.        structures at: nm put:             ((Array with: cls classVersion), (cls allInstVarNames)).        superclasses at: nm ifAbsent: [                superclasses at: nm put: cls superclass name]].    ^ Array with: 'class structure' with: structures with: 'superclasses' with: superclasses! !!SmartRefStream methodsFor: 'all' stamp: 'tk 1/8/97'!mapClass: nm    "See if the old class named nm exists.  If so, return it.  If not, map it to a new class, and save the mapping in renamed.  "    | cls oldVer sel |    cls _ Smalltalk at: nm ifAbsent: [nil].    cls ifNotNil: [^ cls].     "Known class.  It will know how to translate the instance."    oldVer _ self versionSymbol: (structures at: nm).    sel _ nm asString.    sel at: 1 put: (sel at: 1) asLowercase.    sel _ sel, oldVer.    "i.e. #rectangleoc4"    Symbol hasInterned: sel ifTrue: [:symb |         (self class canUnderstand: sel asSymbol) ifTrue: [            cls _ self perform: sel asSymbol]].    "This class will take responsibility"    cls ifNotNil: [            renamed at: nm put: cls name.            ^ cls].    "Never heard of it!!"    ^ self writeClassRenameMethod: sel was: nm                fromInstVars: (structures at: nm).! !!SmartRefStream methodsFor: 'all' stamp: 'tk 1/6/97'!next    "Really write three objects: (version, class structure, object). But only when called from the outside.  "    | version ss object |    ^ topCall == nil         ifTrue:             [topCall _ thisContext.            writing _ false.            version _ super next.            version class == SmallInteger ifFalse: [^ version].                    "version number, else just a regular object, not in our format, "            ss _ super next.            ss class == Array ifFalse: [^ ss].  "just a regualr object"            (ss at: 1) = 'class structure' ifFalse: [^ ss].            structures _ ss at: 2.            superclasses _ (ss size > 3 and: [(ss at: 3) = 'superclasses'])                 ifTrue: [ss at: 4]        "class name -> superclass name"                ifFalse: [Dictionary new].            (self verifyStructure = 'conversion method needed') ifTrue: [^ nil].            writing _ #Unclassed.    "Pass 1"            object _ super next.    "all the action here"            topCall _ writing _ nil.    "reset it"            object]        ifFalse:            [super next]! !!SmartRefStream methodsFor: 'all' stamp: 'tk 9/10/97 21:17'!nextPut: anObject    "Really write three objects: (version, class structure, object). But only when called from the outside.  "    | info |    topCall == nil         ifTrue:            [topCall _ anObject.  writing _ true.             super nextPut: ReferenceStream versionCode.            'Please wait while objects are counted' displayProgressAt: Sensor cursorPoint                from: 0 to: 10                during: [:bar |                    info _ self instVarInfo: anObject].            'Writing an object file' displayProgressAt: Sensor cursorPoint                from: 0 to: objCount*4    "estimate"                during: [:bar |                    objCount _ 0.                    progressBar _ bar.                    super nextPut: info.                    super nextPut: anObject].    "<- the real writing"            "references is an IDict of every object that got written            (in case you want totake statistics)"            "Transcript cr; show: structures keys printString."        "debug"            topCall _ writing _ progressBar _ nil]    "reset it"        ifFalse:            [super nextPut: anObject.            progressBar ifNotNil: [progressBar value: (objCount _ objCount + 1)]].! !!SmartRefStream methodsFor: 'all'!readInstance    "PRIVATE -- Read the contents of an arbitrary instance.     ASSUMES: readDataFrom:size: sends me beginReference: after it       instantiates the new object but before reading nested objects.     NOTE: We must restore the current reference position after       recursive calls to next. jhm.Three cases for files from older versions of the system:1) Class has not changed shape, read it straight.2) Class has changed instance variables (or needs fixup).  Call a particular method to do it.3) There is a new class instead.  Find it, call a particular method to read.1/7/97 tk    All classes used to construct the structures dictionary *itself* need to be in 'steady' and they must not change!!  See setStream:"    | instSize className refPosn anObject newName newClass dict oldInstVars sel supers this |    instSize _ (byteStream nextNumber: 4) - 1.    refPosn _ self getCurrentReference.    className _ self next asSymbol.    self setCurrentReference: refPosn.  "remember pos before readDataFrom:size:"    (Smalltalk includesKey: className) ifTrue: [        newClass _ Smalltalk at: className.        (steady includes: newClass) ifTrue: [             anObject _ newClass isVariable "Create it here"                ifFalse: [newClass basicNew]                ifTrue: [newClass basicNew: instSize - (newClass instSize)].            anObject _ anObject readDataFrom: self size: instSize.            self setCurrentReference: refPosn.  "before returning to next"            ^ anObject]].    newName _ renamed at: className ifAbsent: [className].    newClass _ Smalltalk at: newName.    oldInstVars _ structures at: className ifAbsent: [        "self fixObjVer1: className.    HyperSqueak"        structures at: className ifAbsent: [            self error: 'class is not in structures list']].    "Missing in object file"    anObject _ newClass createFrom: self size: instSize version: oldInstVars.        "only create the instance"    self beginReference: anObject.    dict _ self catalogValues: oldInstVars size: instSize.        "indexed vars as (1 -> val) etc."    "Give each superclass a chance to make its changes"    self storeInstVarsIn: anObject from: dict.    "ones with the same names"    supers _ OrderedCollection with: className.    this _ className.    [(this _ superclasses at: this) = 'nil'] whileFalse: [        supers addFirst: this].    supers do: [:aName |            sel _ reshaped at: aName ifAbsent: [nil].        sel ifNotNil: [            anObject perform: sel with: dict with: self]].    "exceptions"    self setCurrentReference: refPosn.  "before returning to next"    ^ anObject! !!SmartRefStream methodsFor: 'all'!renamed    ^ renamed! !!SmartRefStream methodsFor: 'all' stamp: 'tk 1/9/97'!setStream: aStream    "Initialize me. "    super setStream: aStream.    steady _ Set new.    #(Array Dictionary Association String SmallInteger) do: [:sym |        steady add: (Smalltalk at: sym)].        "These must stay constant.  When structures read in, then things can change."    reshaped _ Dictionary new.            "(old class name -> method selector to fill in data for version to version)"    renamed _ Dictionary new.        "(old class name symbol -> new class name)"! !!SmartRefStream methodsFor: 'all' stamp: 'tk 5/26/97'!storeInstVarsIn: anObject from: dict    "For instance variables with the same names, store them in the new instance.  Values in variable-length part also.  This is NOT the normal inst var transfer!!  See Object.readDataFrom:size:.  This is for when inst var names have changed and some additional conversion is needed.  Here we handle the unchanged vars.  "    (anObject class allInstVarNames) doWithIndex: [:varName :index |        (dict includesKey: varName) ifTrue: [            anObject instVarAt: index put: (dict at: varName)]].    "variable part"    (dict includesKey: #SizeOfVariablePart) ifFalse: [^ anObject].    1 to: (dict at: #SizeOfVariablePart) do: [:index |         anObject basicAt: index put: (dict at: index)].    ^ anObject! !!SmartRefStream methodsFor: 'all'!structures    ^ structures! !!SmartRefStream methodsFor: 'all' stamp: 'tk 5/24/97'!verifyClass: newClass was: nm selector: sel newList: newShort oldList: oldShort    "Compare the incoming inst var name lists with the existing class.  See if the proper conversion method is present.  Works for either comparing inst vars for THIS class, or for allInstVars of the superclasses.  "    Symbol hasInterned: sel ifTrue: [:symb | reshaped at: nm put: symb].    newShort = oldShort ifFalse: ["Did change inst vars"        (reshaped includesKey: nm) ifFalse: ["No conversion method exists"                self close.                self writeConversionMethod: sel class: newClass was: nm                        fromInstVars: oldShort to: newShort.                ^ 'conversion method needed']]. "you need to restart the read-in"    (reshaped includesKey: nm) ifTrue: ["Symbol exists"        (newClass canUnderstand: sel asSymbol) ifFalse: ["But not in this class!!"            self close.                self writeConversionMethod: sel class: newClass was: nm                        fromInstVars: oldShort to: newShort.                ^ 'conversion method needed']]. "you need to restart the read-in"    "any other cases to test?"! !!SmartRefStream methodsFor: 'all' stamp: 'tk 1/6/97'!verifyStructure    "Compare the incoming inst var name lists with the existing classes.  Prepare tables that will help to restructure those who need it (renamed, reshaped, steady).    If all superclasses are recorded in the file, only compare inst vars of this class, not of superclasses.  They will get their turn.  "| sel newClass oldVer newList newVer oldList ans newShort oldShort sup |structures keysDo: [:nm "an old className (symbol)" |    "For missing classes, there needs to be a method in SmartRefStream like         #rectangleoc2 that returns the new class."    newClass _ self mapClass: nm.        "does (renamed at: nm put: newClass name)"    newClass class == String ifTrue: [^ newClass].    "error, fileIn needed"    oldVer _ self versionSymbol: (structures at: nm).    newList _ (Array with: newClass classVersion), (newClass allInstVarNames).    newVer _ self versionSymbol: newList.    sel _ 'convert',oldVer,':',newVer, ':'.            "method name of conversion routine that is send after the object is created."    oldList _ structures at: nm.    superclasses ifNil: [newShort _ newList.  oldShort _ oldList]        ifNotNil: ["just compare inst vars for this class"            sup _ superclasses at: nm.            oldShort _ sup = 'nil'                 ifFalse: [oldList copyFrom: (structures at: sup) size + 1 to: oldList size]                ifTrue: [oldList copyFrom: 2 to: oldList size].            oldShort _ (Array with: (oldList at: 1)), oldShort.    "put version back".            newShort _ (Array with: newClass classVersion), (newClass instVarNames)].    newList = oldList ifTrue: [steady add: newClass].        ans _ self verifyClass: newClass was: nm selector: sel newList: newShort oldList: oldShort.    ans = 'conversion method needed' ifTrue: [^ ans]].! !!SmartRefStream methodsFor: 'all' stamp: 'tk 1/7/97'!versionSymbol: instVarList    "Create the symbolic code (like a version number) for this class in some older version.  First initials of all the inst vars, followed by the class version number.  Returns a string, caller makes it into a compound selector.  "    | str |    str _ instVarList size = 1 ifFalse: [''] ifTrue: ['x'].        "at least one letter"    2 to: instVarList size do: [:ind |        str _ str, (instVarList at: ind) first asString].    str _ str, instVarList first printString.    "the number"    ^ str" | list | list _ (Array with: Paragraph classVersion), (Paragraph alistInstVarNames).(SmartRefStream  on: (DummyStream on: nil)) versionSymbol: list"! !!SmartRefStream methodsFor: 'all' stamp: 'tk 5/8/97'!writeClassRenameMethod: sel was: oldName fromInstVars: oldList    "The class coming is unknown.  Ask the user for the existing class it maps to.  If got one, write a method, and restart the obj fileIn.  If none, write a dummy method and get the user to complete it later.  "| tell choice  newName answ code |tell _ 'Reading an instance of ', oldName, '.Which modern class should it translate to?'.answ _ (PopUpMenu labels: 'Let me type the name nowLet me think about itLet me find a conversion file on the disk') startUpWithCaption: tell. answ = 1 ifTrue: [    tell _ 'Name of the modern class that ', oldName, 's should it translate to:'.    choice _ FillInTheBlank request: tell.        "class name"    (choice size = 0)         ifTrue: [answ _ 'conversion method needed']        ifFalse: [newName _ choice.            answ _ Smalltalk at: newName asSymbol                 ifAbsent: ['conversion method needed']]].(answ = 3) | (answ = 0) ifTrue: [self close.        ^ 'conversion method needed'].answ = 2 ifTrue: [answ _ 'conversion method needed'].answ = 'conversion method needed' ifTrue: [        self close.          newName _ 'PutNewClassHere'].code _ WriteStream on: (String new: 500).code nextPutAll: sel; cr; tab.code nextPutAll: '^ ', newName.    "Return new class"self class compile: code contents classified: 'conversion'.newName = 'PutNewClassHere' ifTrue: [    PopUpMenu notify: 'Please complete the following method and then read-in the object file again.'.    Smalltalk browseAllImplementorsOf: sel asSymbol].     "The class version number only needs to change under one specific circumstance.  That is when the first letters of the instance variables have stayed the same, but their meaning has changed.  A conversion method is needed, but this system does not know it.      If this is true for class Foo, define classVersion in Foo class.      Beware of previous object fileouts already written after the change in meaning, but before bumping the version number.  They have the old (wrong) version number, say 2.  If this is true, your method must be able to test the data and successfully read files that say version 2 but are really 3."    ^ answ! !!SmartRefStream methodsFor: 'all' stamp: 'tk 4/26/97'!writeConversionMethod: sel class: newClass was: oldName fromInstVars: oldList to: newList    "No method sel was found in newClass.  Ask user to look for the fileIn.  Or help by writing a prototype conversion method.  "| tell choice code keywords newOthers oldOthers copied |newClass name = oldName     ifTrue: [tell _ 'The class ', oldName]    ifFalse: [tell _ 'An instance of ', oldName, ' is coming in as an ', newClass name, '.  It'].tell _ tell, ' has different instance variables than before.  It needs a conversion method.  You may:'.choice _ (PopUpMenu labels: 'Find a conversion file on the disk and file it inWrite a conversion method by editing a prototype') startUpWithCaption: tell. choice = 1 ifTrue: [PopUpMenu notify: 'After filing in the conversion file, please read-in the object file again.'].    "you need to restart the read-in"choice = 2 ifTrue: [    code _ WriteStream on: (String new: 500).    keywords _ sel keywords.    code nextPutAll: (keywords at: 1); nextPutAll: ' varDict ';             nextPutAll: (keywords at: 2); nextPutAll: ' smartRefStrm'; cr; tab.    newOthers _ newList asOrderedCollection "copy".    oldOthers _ oldList asOrderedCollection "copy".    copied _ OrderedCollection new.    newList do: [:instVar |        (oldList includes: instVar) ifTrue: [            instVar isInteger ifFalse: [copied add: instVar].            newOthers remove: instVar.            oldOthers remove: instVar]].    code nextPutAll: '"These variables are automatically stored into the new instance '.    code nextPutAll: copied asArray printString; nextPut: $. .    code cr; tab; nextPutAll: 'This method is for additional changes.';         nextPutAll: ' Use statements like (foo _ varDict at: ''foo'')."'; cr; cr; tab.    (newOthers size = 0) & (oldOthers size = 0)         ifTrue: [code nextPutAll: '"Instance variables are the same.  Only the order changed.  This method should work as written."']        ifFalse: [code nextPutAll: '"Be sure to to fill in ', newOthers asArray printString,             ' and deal with the information in ', oldOthers asArray printString, '"'].    newClass compile: code contents classified: 'object fileIn'.    PopUpMenu notify: 'Please complete the following method and then read-in the object file again.'.    Smalltalk browseAllImplementorsOf: sel asSymbol].     "If you write a conversion method beware that the class may need a version number change.  This only happens when two conversion methods in the same class have the same selector name.  (A) The inst var lists of the new and old versions intials as some older set of new and old inst var lists.  or (B) Twice in a row, the class needs a conversion method, but the inst vars stay the same the whole time.  (For an internal format change.)    If either is the case, fileouts already written with the old (wrong) version number, say 2.  Your method must be able to read files that say version 2 but are really 3, until you expunge the erroneous version 2 files from the universe." ! !!SmartRefStream methodsFor: 'all'!writing    ^ writing! !!SmartRefStream class methodsFor: 'all' stamp: 'tk 5/8/97'!example    "Here is how to use SmartRegStream to write out any object and all of its subobjects.  "    "    Foo new saveOnFile2.    And to bring it back(SmartRefStream oldFileNamed: 'Foo.objs') nextAndClose    "! !!SmartRefStream class methodsFor: 'all' stamp: 'tk 5/20/97'!scanFrom: aByteStream    "During a code fileIn, we need to read in an object, and stash it in ScannedObject.  "    | me |    me _ self on: aByteStream.    ScannedObject _ me next.    aByteStream ascii.    aByteStream next == $!! ifFalse: [        aByteStream close.        self error: 'Object did not end correctly'].     "caller will close the byteStream"    "HandMorph.readMorphFile will retrieve the ScannedObject"! !!SmartRefStream class methodsFor: 'all' stamp: 'tk 5/20/97'!scannedObject    "The most recently read in object.  Watch out for read-in that is interrupted and resumed.  May want to make this a dictionary?  "    ^ ScannedObject! !!SmartRefStream class methodsFor: 'all' stamp: 'tk 5/20/97'!scannedObject: objOrNil    "Used to free up the last object stashed here.  "    ScannedObject _ objOrNil! !Socket comment:'A Socket represents a network connection point. Current sockets are designed to support the TCP/IP and UDP protocols, although UDP is not yet implemented. It should be possible to support other protocols (such as AppleTalk) sockets by extending the socket primitives.Subclasses of socket provide support for network protocols such as POP, NNTP, and HTTP. Sockets also allow you to implement your own custom services and may be used to support Remote Procedure Call or Remote Method Invocation some day.'!!Socket methodsFor: 'initialize-destroy' stamp: 'jm 9/15/97 12:28'!destroy    "Destroy this socket. Its connection, if any, is aborted and its resources are freed. Do nothing if the socket has already been destroyed (i.e., if its socketHandle is nil)."    socketHandle = nil        ifFalse: [            self primSocketDestroy: socketHandle.            Smalltalk unregisterExternalObject: semaphore.            socketHandle _ nil.            semaphore _ nil].! !!Socket methodsFor: 'initialize-destroy' stamp: 'jm 9/11/97 20:36'!initialize    "Create a new socket handle."    | semaIndex |    semaphore _ Semaphore new.    semaIndex _ Smalltalk registerExternalObject: semaphore.    socketHandle _        self primSocketCreateNetwork: 0            type: 0            receiveBufferSize: 8000            sendBufSize: 8000            semaIndex: semaIndex.! !!Socket methodsFor: 'accessing' stamp: 'jm 9/17/97 14:34'!localAddress    ^ self primSocketLocalAddress: socketHandle! !!Socket methodsFor: 'accessing' stamp: 'jm 9/17/97 14:33'!localPort    ^ self primSocketLocalPort: socketHandle! !!Socket methodsFor: 'accessing' stamp: 'jm 9/17/97 14:34'!remoteAddress    ^ self primSocketRemoteAddress: socketHandle! !!Socket methodsFor: 'accessing' stamp: 'jm 9/17/97 14:34'!remotePort    ^ self primSocketRemotePort: socketHandle! !!Socket methodsFor: 'queries' stamp: 'jm 9/11/97 20:27'!dataAvailable    "Return true if this socket has unread received data."    ^ self primSocketReceiveDataAvailable: socketHandle! !!Socket methodsFor: 'queries' stamp: 'jm 9/11/97 20:27'!isConnected    "Return true if this socket is connected."    ^ (self primSocketConnectionStatus: socketHandle) == Connected! !!Socket methodsFor: 'queries' stamp: 'jm 9/26/97 11:31'!isUnconnectedOrInvalid    "Return true if this socket is completely disconnected or is invalid."    | status |    socketHandle ifNil: [^ true].    status _ self primSocketConnectionStatus: socketHandle.    ^ (status = Unconnected) | (status = InvalidSocket)! !!Socket methodsFor: 'queries' stamp: 'jm 9/26/97 08:41'!isValid    "Return true if this socket contains a valid, non-nil socket handle."    | status |    socketHandle ifNil: [^ false].    status _ self primSocketConnectionStatus: socketHandle.    ^ status ~= InvalidSocket! !!Socket methodsFor: 'queries' stamp: 'jm 9/11/97 20:28'!sendDone    "Return true if the most recent send operation on this socket has completed."    ^ self primSocketSendDone: socketHandle! !!Socket methodsFor: 'queries' stamp: 'jm 9/17/97 16:10'!statusString    "Return a string describing the status of this socket."    | status |    status _ self primSocketConnectionStatus: socketHandle.    status = InvalidSocket ifTrue: [^ 'invalidSocketHandle'].    status = Unconnected ifTrue: [^ 'unconnected'].    status = WaitingForConnection ifTrue: [^ 'waitingForConnection'].    status = Connected ifTrue: [^ 'connected'].    status = OtherEndClosed ifTrue: [^ 'otherEndClosedButNotThisEnd'].    status = ThisEndClosed ifTrue: [^ 'thisEndClosedButNotOtherEnd'].    ^ 'unknown socket status'! !!Socket methodsFor: 'connection open/close' stamp: 'jm 9/11/97 20:29'!close    "Close this connection gracefully. For TCP, this sends a close request, but the stream remains open until the other side also closes it."    self primSocketCloseConnection: socketHandle.  "close this end"! !!Socket methodsFor: 'connection open/close' stamp: 'jm 9/25/97 22:01'!closeAndDestroy    "First, try to close this connection gracefully. If the close attempt fails or times out, abort the connection. In either case, destroy the socket. Do nothing if the socket has already been destroyed (i.e., if its socketHandle is nil)."    self closeAndDestroy: 20.! !!Socket methodsFor: 'connection open/close' stamp: 'jm 9/25/97 22:01'!closeAndDestroy: timeoutSeconds    "First, try to close this connection gracefully. If the close attempt fails or times out, abort the connection. In either case, destroy the socket. Do nothing if the socket has already been destroyed (i.e., if its socketHandle is nil)."    socketHandle = nil        ifFalse: [            self close.  "close this end"            (self waitForDisconnectionUntil: (Socket deadlineSecs: timeoutSeconds))                ifFalse: [                    "if the other end doesn't close soon, just abort the connection"                    self primSocketAbortConnection: socketHandle].            self destroy].! !!Socket methodsFor: 'connection open/close'!connectTo: hostAddress port: port    "Initiate a connection to the given port at the given host address. This operation will return immediately; follow it with waitForConnectionUntil: to wait until the connection is established."    | status |    status _ self primSocketConnectionStatus: socketHandle.    (status == Unconnected)        ifFalse: [self error: 'Socket status must Unconnected before opening a new connection'].    self primSocket: socketHandle connectTo: hostAddress port: port.! !!Socket methodsFor: 'connection open/close'!listenOn: port    "Listen for a connection on the given port. This operation will return immediately; follow it with waitForConnectionUntil: to wait until a connection is established."    | status |    status _ self primSocketConnectionStatus: socketHandle.    (status == Unconnected)        ifFalse: [self error: 'Socket status must Unconnected before listening for a new connection'].    self primSocket: socketHandle listenOn: port.! !!Socket methodsFor: 'sending-receiving' stamp: 'jm 9/15/97 12:22'!discardReceivedData    "Discard any data received up until now, and return the number of bytes discarded."    | buf totalBytesDiscarded |    buf _ String new: 10000.    totalBytesDiscarded _ 0.    [self isConnected and: [self dataAvailable]] whileTrue: [        totalBytesDiscarded _            totalBytesDiscarded + (self receiveDataInto: buf)].    ^ totalBytesDiscarded! !!Socket methodsFor: 'sending-receiving' stamp: 'jm 9/15/97 12:21'!receiveDataInto: aStringOrByteArray    "Receive data into the given buffer and return the number of bytes received. Note the given buffer may be only partially filled by the received data."    ^ self primSocket: socketHandle        receiveDataInto: aStringOrByteArray        startingAt: 1        count: aStringOrByteArray size! !!Socket methodsFor: 'sending-receiving' stamp: 'jm 9/17/97 16:00'!sendData: aStringOrByteArray    "Send all of the data in the given array, even if it requires multiple calls to send it all. Return the number of bytes sent."    | bytesSent bytesToSend count |    bytesToSend _ aStringOrByteArray size.    bytesSent _ 0.    [bytesSent < bytesToSend] whileTrue: [        (self waitForSendDoneUntil: (Socket deadlineSecs: 20))            ifFalse: [self error: 'send data timeout; data not sent'].        count _ self primSocket: socketHandle            sendData: aStringOrByteArray            startIndex: bytesSent + 1            count: bytesToSend - bytesSent.        bytesSent _ bytesSent + count].    ^ bytesSent! !!Socket methodsFor: 'sending-receiving' stamp: 'jm 9/17/97 15:55'!sendSomeData: aStringOrByteArray    "Send as much of the given data as possible and return the number of bytes actually sent."    "Note: This operation may have to be repeated many times to send a large amount of data."    | bytesSent |    (self waitForSendDoneUntil: (Socket deadlineSecs: 20))        ifTrue: [            bytesSent _ self primSocket: socketHandle                sendData: aStringOrByteArray                startIndex: 1                count: aStringOrByteArray size]        ifFalse: [self error: 'send data timeout; data not sent'].    ^ bytesSent! !!Socket methodsFor: 'waiting' stamp: 'jm 9/15/97 17:05'!waitForConnectionUntil: deadline    "Wait up until the given deadline for a connection to be established. Return true if it is established by the deadline, false if not."    | status |    status _ self primSocketConnectionStatus: socketHandle.    [(status ~= Connected) and: [Time millisecondClockValue < deadline]] whileTrue: [        semaphore waitTimeoutMSecs: (deadline - Time millisecondClockValue).        status _ self primSocketConnectionStatus: socketHandle].    ^ status = Connected! !!Socket methodsFor: 'waiting' stamp: 'jm 9/15/97 17:05'!waitForDataUntil: deadline    "Wait up until the given deadline for data to arrive. Return true if data arrives by the deadline, false if not."    | dataArrived |    dataArrived _ self primSocketReceiveDataAvailable: socketHandle.    [dataArrived not and:     [self isConnected and:     [Time millisecondClockValue < deadline]]] whileTrue: [        semaphore waitTimeoutMSecs: (deadline - Time millisecondClockValue).        dataArrived _ self primSocketReceiveDataAvailable: socketHandle].    ^ dataArrived! !!Socket methodsFor: 'waiting' stamp: 'jm 9/15/97 17:06'!waitForDisconnectionUntil: deadline    "Wait up until the given deadline for the the connection to be broken. Return true if it is broken by the deadline, false if not."    "Note: The client should know the the connect is really going to be closed (e.g., because he has called 'close' to send a close request to the other end) before calling this method."    | extraBytes status |    extraBytes _ 0.    status _ self primSocketConnectionStatus: socketHandle.    [((status = Connected) or: [status = ThisEndClosed]) and:     [Time millisecondClockValue < deadline]] whileTrue: [        self dataAvailable            ifTrue: [extraBytes _ extraBytes + self discardReceivedData].        semaphore waitTimeoutMSecs: (deadline - Time millisecondClockValue).        status _ self primSocketConnectionStatus: socketHandle].    extraBytes > 0        ifTrue: [self inform: 'Discarded ', extraBytes printString, ' bytes while closing connection.'].    ^ status ~= Connected! !!Socket methodsFor: 'waiting' stamp: 'jm 9/15/97 17:06'!waitForSendDoneUntil: deadline    "Wait up until the given deadline for the current send operation to complete. Return true if it completes by the deadline, false if not."    | sendDone |    sendDone _ self primSocketSendDone: socketHandle.    [sendDone not and:     [self isConnected and:     [Time millisecondClockValue < deadline]]] whileTrue: [        semaphore waitTimeoutMSecs: (deadline - Time millisecondClockValue).        sendDone _ self primSocketSendDone: socketHandle].    ^ sendDone! !!Socket methodsFor: 'primitives'!primSocket: socketID connectTo: hostAddress port: port    "Attempt to establish a connection to the given port of the given host. This is an asynchronous call; query the socket status to discover if and when the connection is actually completed."    <primitive: 217>    self primitiveFailed! !!Socket methodsFor: 'primitives'!primSocket: socketID listenOn: port    "Listen for a connection on the given port. This is an asynchronous call; query the socket status to discover if and when the connection is actually completed."    <primitive: 218>    self primitiveFailed! !!Socket methodsFor: 'primitives'!primSocket: socketID receiveDataInto: aStringOrByteArray startingAt: startIndex count: count    "Receive data from the given socket into the given array starting at the given index. Return the number of bytes read or zero if no data is available."    <primitive: 221>    self primitiveFailed! !!Socket methodsFor: 'primitives'!primSocket: socketID sendData: aStringOrByteArray startIndex: startIndex count: count    "Send data to the remote host through the given socket starting with the given byte index of the given byte array. The data sent is 'pushed' immediately. Return the number of bytes of data actually sent; any remaining data should be re-submitted for sending after the current send operation has completed."    "Note: In general, it many take several sendData calls to transmit a large data array since the data is sent in send-buffer-sized chunks. The size of the send buffer is determined when the socket is created."    <primitive: 223>    self primitiveFailed! !!Socket methodsFor: 'primitives'!primSocketAbortConnection: socketID    "Terminate the connection on the given port immediately without going through the normal close sequence. This is an asynchronous call; query the socket status to discover if and when the connection is actually terminated."    <primitive: 220>    self primitiveFailed! !!Socket methodsFor: 'primitives'!primSocketCloseConnection: socketID    "Close the connection on the given port. The remote end is informed that this end has closed and will do no further sends. This is an asynchronous call; query the socket status to discover if and when the connection is actually closed."    <primitive: 219>    self primitiveFailed! !!Socket methodsFor: 'primitives' stamp: 'jm 9/17/97 14:45'!primSocketConnectionStatus: socketID    "Return an integer reflecting the connection status of this socket. For a list of possible values, see the comment in the 'initialize' method of this class. If the primitive fails, return a status indicating that the socket handle is no longer valid, perhaps because the Squeak image was saved and restored since the socket was created. (Sockets do not survive snapshots.)"    <primitive: 211>    ^ InvalidSocket! !!Socket methodsFor: 'primitives' stamp: 'jm 9/11/97 20:35'!primSocketCreateNetwork: netType type: socketType receiveBufferSize: rcvBufSize sendBufSize: sendBufSize semaIndex: semaIndex    "Return a new socket handle for a socket of the given type and buffer sizes.    The netType parameter is platform dependent and can be used to encode both the protocol type (IP, Xerox XNS, etc.) and/or the physical network interface to use if this host is connected to multiple networks. A zero netType means to use IP protocols and the primary (or only) network interface.    The socketType parameter specifies:        0    unreliable datagram socket (UDP if the protocol is IP) [NOTE: UDP is not yet implemented]        1    reliable stream socket (TCP if the protocol is IP)    The buffer size parameters allow performance to be tuned to the application. For example, a larger receive buffer should be used when the application expects to be receiving large amounts of data, especially from a host that is far away. These values are considered requests only; the underlying implementation will ensure that the buffer sizes actually used are within allowable bounds. Note that memory may be limited, so an application that keeps many sockets open should use smaller buffer sizes.     If semaIndex is > 0, it is taken to be the index of a Semaphore in the external objects array to be associated with this socket. This semaphore will be signalled when the socket status changes, such as when data arrives or a send completes. All processes waiting on the semaphore will be awoken for each such event; each process must then query the socket state to figure out if the conditions they are waiting for have been met. For example, a process waiting to send some data can see if the last send has completed."    <primitive: 209>    self primitiveFailed! !!Socket methodsFor: 'primitives'!primSocketDestroy: socketID    "Release the resources associated with this socket. If a connection is open, it is aborted."    <primitive: 210>    self primitiveFailed! !!Socket methodsFor: 'primitives'!primSocketError: socketID    "Return an integer encoding the most recent error on this socket. Zero means no error."    <primitive: 212>    self primitiveFailed! !!Socket methodsFor: 'primitives'!primSocketLocalAddress: socketID    "Return the local host address for this socket."    <primitive: 213>    self primitiveFailed! !!Socket methodsFor: 'primitives'!primSocketLocalPort: socketID    "Return the local port for this socket, or zero if no port has yet been assigned."    <primitive: 214>    self primitiveFailed! !!Socket methodsFor: 'primitives' stamp: 'jm 9/11/97 20:22'!primSocketReceiveDataAvailable: socketID    "Return true if data may be available for reading from the current socket."    <primitive: 222>    self primitiveFailed! !!Socket methodsFor: 'primitives'!primSocketRemoteAddress: socketID    "Return the remote host address for this socket, or zero if no connection has been made."    <primitive: 215>    self primitiveFailed! !!Socket methodsFor: 'primitives'!primSocketRemotePort: socketID    "Return the remote port for this socket, or zero if no connection has been made."    <primitive: 216>    self primitiveFailed! !!Socket methodsFor: 'primitives'!primSocketSendDone: socketID    "Return true if there is no send in progress on the current socket."    <primitive: 224>    self primitiveFailed! !!Socket class methodsFor: 'class initialization' stamp: 'jm 9/17/97 14:42'!initialize    "Socket initialize"    "Socket Status Values"    InvalidSocket _ -1.    Unconnected _ 0.    WaitingForConnection _ 1.    Connected _ 2.    OtherEndClosed _ 3.    ThisEndClosed _ 4.! !!Socket class methodsFor: 'instance creation' stamp: 'jm 9/15/97 06:16'!new    "Return a new, unconnected Socket."    ^ super new initialize! !!Socket class methodsFor: 'network initialization' stamp: 'jm 9/25/97 21:58'!ensureNetworkConnected    "Try to ensure that an intermittent network connection, such as a dialup or ISDN line, is actually connected. This is necessary to make sure a server is visible in order to accept an incoming connection."    "Socket ensureNetworkConnected"    NetNameResolver initializeNetwork.    Utilities        informUser: 'Contacting domain name server...'        during: [            NetNameResolver                addressForName: 'bogusNameToForceDNSToBeConsulted.org'                timeout: 30].! !!Socket class methodsFor: 'network initialization' stamp: 'jm 9/15/97 09:30'!initializeNetwork    "Initialize the network drivers and the NetNameResolver. Do nothing if the network is already initialized."    "Note: The network must be re-initialized every time Squeak starts up, so applications that persist across snapshots should be prepared to re-initialize the network as needed. Such applications should call 'Socket initializeNetwork' before every network transaction. "    NetNameResolver initializeNetwork.! !!Socket class methodsFor: 'network initialization' stamp: 'jm 9/15/97 06:53'!initializeNetwork: ignored    "Old message for backward compatibility. This method will be removed in some future release; clients should use 'Socket initializeNetwork' instead."    Socket initializeNetwork.! !!Socket class methodsFor: 'tests' stamp: 'jm 10/4/97 15:50'!loopbackTest    "Send data from one socket to another on the local machine. Tests most of the socket primitives."    "Socket loopbackTest"    | sock1 sock2 bytesToSend sendBuf receiveBuf done bytesSent bytesReceived t extraBytes |    Transcript cr; show: 'starting loopback test'; cr.    Transcript show: '---------- Connecting ----------'; cr.    Socket initializeNetwork.    sock1 _ Socket new.    sock2 _ Socket new.    sock1 listenOn: 54321.    sock2 connectTo: (NetNameResolver localHostAddress) port: 54321.    sock1 waitForConnectionUntil: self standardDeadline.    sock2 waitForConnectionUntil: self standardDeadline.    (sock1 isConnected) ifFalse: [self error: 'sock1 not connected'].    (sock2 isConnected) ifFalse: [self error: 'sock2 not connected'].    Transcript show: 'connection established'; cr.    bytesToSend _ 5000000.    sendBuf _ String new: 4000 withAll: $x.    receiveBuf _ String new: 50000.    done _ false.    bytesSent _ bytesReceived _ 0.    t _ Time millisecondsToRun: [        [done] whileFalse: [            (sock1 sendDone and: [bytesSent < bytesToSend]) ifTrue: [                bytesSent _ bytesSent + (sock1 sendSomeData: sendBuf)].            sock2 dataAvailable ifTrue: [                bytesReceived _ bytesReceived +                    (sock2 receiveDataInto: receiveBuf)].            done _ (bytesSent >= bytesToSend) and: [bytesReceived = bytesSent]]].    Transcript show: 'closing connection'; cr.    sock1 waitForSendDoneUntil: self standardDeadline.    sock1 close.    sock2 waitForDisconnectionUntil: self standardDeadline.    extraBytes _ sock2 discardReceivedData.    extraBytes > 0 ifTrue: [        Transcript show: ' *** received ', extraBytes size printString, ' extra bytes ***'; cr.    ].    sock2 close.    sock1 waitForDisconnectionUntil: self standardDeadline.    (sock1 isUnconnectedOrInvalid) ifFalse: [self error: 'sock1 not closed'].    (sock2 isUnconnectedOrInvalid) ifFalse: [self error: 'sock2 not closed'].    Transcript show: '---------- Connection Closed ----------'; cr.    sock1 destroy.    sock2 destroy.    Transcript show: 'loopback test done; time = ', t printString; cr.    Transcript show: ((bytesToSend asFloat / t) roundTo: 0.01) printString, ' kBytes/sec'; cr.    Transcript endEntry.! !!Socket class methodsFor: 'tests' stamp: 'jm 9/17/97 15:55'!sendTest    "Send data to the 'discard' socket of the given host. Tests the speed of one-way data transfers across the network to the given host. Note that many host hosts do not run a discard server."    "Socket sendTest"    | sock bytesToSend sendBuf bytesSent t serverName serverAddr |    Transcript cr; show: 'starting send test'; cr.    Socket initializeNetwork.    serverName _ FillInTheBlank        request: 'What is the destination server?'        initialAnswer: 'bobo.rd.wdi.disney.com'.    serverAddr _ NetNameResolver addressForName: serverName timeout: 10.    serverAddr = nil ifTrue: [^ self inform: 'Could not find an address for ', serverName].    sock _ Socket new.    Transcript show: '---------- Connecting ----------'; cr.    sock connectTo: serverAddr port: 9.    sock waitForConnectionUntil: self standardDeadline.    (sock isConnected) ifFalse: [        sock destroy.        ^ self inform: 'could not connect'].    Transcript show: 'connection established; sending data'; cr.    bytesToSend _ 100000.    sendBuf _ String new: 5000 withAll: $x.    bytesSent _ 0.    t _ Time millisecondsToRun: [        [bytesSent < bytesToSend] whileTrue: [            sock sendDone ifTrue: [                bytesSent _ bytesSent + (sock sendSomeData: sendBuf)]]].    sock destroy.    Transcript show: '---------- Connection Closed ----------'; cr.    Transcript show: 'send test done; time = ', t printString; cr.    Transcript show: ((bytesToSend asFloat / t) roundTo: 0.01) printString, ' kBytes/sec'; cr.    Transcript endEntry.! !!Socket class methodsFor: 'utilities' stamp: 'jm 9/15/97 06:56'!deadlineSecs: secs    "Return a deadline time the given number of seconds from now."    ^ Time millisecondClockValue + (secs * 1000)! !!Socket class methodsFor: 'utilities' stamp: 'jm 9/15/97 06:56'!standardDeadline    "Return a default deadline time some seconds into the future."    ^ self deadlineSecs: 45! !!Socket class methodsFor: 'temporary' stamp: 'jm 9/19/97 07:09'!httpGet: url accept: mimeType    "Temporary. For backward compatibility."    ^ HTTPSocket httpGet: url accept: mimeType! !!SoundBuffer methodsFor: 'accessing' stamp: 'jm 9/17/97 13:00'!monoSampleCount    "Return the number of monaural 16-bit samples that fit into this SoundBuffer."    ^ super size * 2! !!SoundBuffer methodsFor: 'accessing' stamp: 'jm 9/17/97 13:28'!size    "Return the number of 16-bit sound samples that fit in this sound buffer. To avoid confusion, it is better to get the size of SoundBuffer using monoSampleCount or stereoSampleCount."    ^ self monoSampleCount! !!SoundBuffer methodsFor: 'accessing' stamp: 'jm 9/17/97 13:01'!stereoSampleCount    "Return the number of stereo slices that fit into this SoundBuffer. A stereo 'slice' consists of two 16-bit samples, one for each channel."    ^ super size! !!SoundBuffer methodsFor: 'primitives' stamp: 'jm 9/17/97 13:03'!at: index    "Return the 16-bit integer value at the given index of the receiver."    <primitive: 143>    index isInteger ifTrue: [self errorSubscriptBounds: index].    index isNumber ifTrue: [^ self at: index truncated].    self errorNonIntegerIndex.! !!SoundBuffer methodsFor: 'primitives' stamp: 'jm 9/17/97 13:03'!at: index put: value    "Store the given 16-bit integer at the given index in the receiver."    <primitive: 144>    index isInteger        ifTrue: [            (index >= 1 and: [index <= self size])                ifTrue: [self errorImproperStore]                ifFalse: [self errorSubscriptBounds: index]].    index isNumber ifTrue: [^ self at: index truncated put: value].    self errorNonIntegerIndex.! !!SoundBuffer methodsFor: 'primitives' stamp: 'jm 9/2/97 16:07'!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."    "Note: Since 16-bit word arrays are not built into the virtual machine, this primitive fills by 32-bit words."    <primitive: 145>    self errorImproperStore.! !!SoundBuffer class methodsFor: 'instance creation' stamp: 'jm 9/17/97 12:39'!fromArray: anArray    "Return a new SoundBuffer whose contents are copied from the given Array or ByteArray."    | new |    new _ SoundBuffer newMonoSampleCount: anArray size.    1 to: anArray size do: [:i | new at: i put: (anArray at: i)].    ^ new! !!SoundBuffer class methodsFor: 'instance creation' stamp: 'jm 9/17/97 13:25'!new: anInteger    "See the comment in newMonoSampleCount:. To avoid confusion, it is best to create new instances using newMonoSampleCount: or newStereoSampleCount:."    ^ self newMonoSampleCount: anInteger! !!SoundBuffer class methodsFor: 'instance creation' stamp: 'jm 9/17/97 12:44'!newMonoSampleCount: anInteger    "Return a SoundBuffer large enough to hold the given number of monaural samples (i.e., 16-bit words)."    "Details: The size is rounded up to an even number, since the underlying representation is in terms of 32-bit words."    ^ self basicNew: (anInteger + 1) // 2! !!SoundBuffer class methodsFor: 'instance creation' stamp: 'jm 9/17/97 12:52'!newStereoSampleCount: anInteger    "Return a SoundBuffer large enough to hold the given number of stereo slices. A stereo 'slice' consists of two 16-bit samples, one for each channel."    ^ self basicNew: anInteger! !!SoundPlayer class methodsFor: 'initialization' stamp: 'jm 9/18/97 19:00'!initialize    "SoundPlayer initialize"    "Details: BufferMSecs represents a tradeoff between latency and quality. If BufferMSecs is too low, the sound will not play smoothing, especially during other activities. If it is too high, there will be an overly long time lag between when a sound buffer is submitted to be played and when that sound is actually heard. It is typically in the range 50-200."    "SoundPlayer shutDown; startUp"    SamplingRate _ 11025.    BufferMSecs _ 200.    Stereo _ true.! !!SoundPlayer class methodsFor: 'accessing'!stereo    ^ Stereo! !!SoundPlayer class methodsFor: 'snapshotting'!shutDown    "Stop player process, for example before snapshotting."    self stopPlayerProcess.! !!SoundPlayer class methodsFor: 'snapshotting' stamp: 'jm 9/21/97 18:13'!startUp    "Start up the player process."    SoundPlayer initialize.    SoundPlayer        startPlayerProcessBufferSize: (BufferMSecs * SamplingRate) // 1000        rate: SamplingRate        stereo: Stereo.! !!SoundPlayer class methodsFor: 'playing' stamp: 'jm 8/23/97 20:38'!pauseSound: aSound    "Stop playing the given sound. Playing can be resumed from this point later."    PlayerSemaphore critical: [        ActiveSounds remove: aSound ifAbsent: []].! !!SoundPlayer class methodsFor: 'playing' stamp: 'jm 9/13/97 19:47'!playSound: aSound    "Reset and start playing the given sound from its beginning."    aSound reset.    self resumePlaying: aSound.! !!SoundPlayer class methodsFor: 'playing' stamp: 'jm 9/18/97 15:49'!resumePlaying: aSound    "Start playing the given sound without resetting it; it will resume playing from where it last stopped."    | quickStart |    quickStart _ true.    PlayerProcess == nil        ifTrue: [self startUp. quickStart _ false].    PlayerSemaphore critical: [        (ActiveSounds includes: aSound)            ifTrue: [quickStart _ false]            ifFalse: [                quickStart ifFalse: [ActiveSounds add: aSound]]].    "quick-start the given sound, unless the sound player has just started"    quickStart ifTrue: [self startPlayingImmediately: aSound].! !!SoundPlayer class methodsFor: 'playing' stamp: 'jm 9/13/97 19:49'!waitUntilDonePlaying: aSound    "Wait until the given sound is no longer playing."    [PlayerSemaphore critical: [ActiveSounds includes: aSound]]        whileTrue: [(Delay forMilliseconds: 100) wait].! !!SoundPlayer class methodsFor: 'player process' stamp: 'jm 10/4/97 16:19'!oldStylePlayLoop    "This version of the play loop is used if the VM does not yet support the new sound playing that signals a semaphore when a sound buffer becomes available."    | samples |    [true] whileTrue: [        [(samples _ self primSoundAvailableBytes // 4) > 100]            whileFalse: [(Delay forMilliseconds: 1) wait].        samples _ samples min: Buffer stereoSampleCount.        PlayerSemaphore critical: [            ActiveSounds _ ActiveSounds select: [:snd | snd samplesRemaining > 0].            ActiveSounds do: [:snd |                snd ~~ SoundJustStarted ifTrue: [                    snd playSampleCount: samples into: Buffer startingAt: 1 stereo: Stereo]].            self primSoundPlaySamples: samples from: Buffer startingAt: 1.            Buffer primFill: 0.            SoundJustStarted _ nil]].! !!SoundPlayer class methodsFor: 'player process' stamp: 'jm 10/4/97 16:19'!playLoop    "The sound player process loop."    | samples |    [true] whileTrue: [        [(samples _ self primSoundAvailableBytes // 4) > 100]            whileFalse: [ReadyForBuffer wait].        samples _ samples min: Buffer stereoSampleCount.        PlayerSemaphore critical: [            ActiveSounds _ ActiveSounds select: [:snd | snd samplesRemaining > 0].            ActiveSounds do: [:snd |                snd ~~ SoundJustStarted ifTrue: [                    snd playSampleCount: samples into: Buffer startingAt: 1 stereo: Stereo]].            self primSoundPlaySamples: samples from: Buffer startingAt: 1.            Buffer primFill: 0.            SoundJustStarted _ nil]].! !!SoundPlayer class methodsFor: 'player process' stamp: 'jm 9/17/97 20:24'!startPlayerProcessBufferSize: bufferSize rate: samplesPerSecond stereo: stereoFlag    "Start the sound player process. Terminate the old process, if any."    "SoundPlayer startPlayerProcessBufferSize: 1000 rate: 11025 stereo: false"    self stopPlayerProcess.    ActiveSounds _ OrderedCollection new.    Buffer _ SoundBuffer newStereoSampleCount: (bufferSize // 4) * 4.    PlayerSemaphore _ Semaphore forMutualExclusion.    SamplingRate _ samplesPerSecond.    Stereo _ stereoFlag.    ReadyForBuffer _ Semaphore new.    UseReadySemaphore _ true.  "set to false if ready semaphore not supported by VM"    self primSoundStartBufferSize: Buffer stereoSampleCount        rate: samplesPerSecond        stereo: Stereo        semaIndex: (Smalltalk registerExternalObject: ReadyForBuffer).    UseReadySemaphore        ifTrue: [PlayerProcess _ [SoundPlayer playLoop] newProcess]        ifFalse: [PlayerProcess _ [SoundPlayer oldStylePlayLoop] newProcess].    PlayerProcess priority: Processor userInterruptPriority.    PlayerProcess resume.! !!SoundPlayer class methodsFor: 'player process' stamp: 'jm 9/17/97 20:31'!stopPlayerProcess    "Stop the sound player process."    "SoundPlayer stopPlayerProcess"    PlayerProcess == nil ifFalse: [PlayerProcess terminate].    PlayerProcess _ nil.    self primSoundStop.    ActiveSounds _ OrderedCollection new.    Buffer _ nil.    PlayerSemaphore _ Semaphore forMutualExclusion.    ReadyForBuffer ifNotNil:        [Smalltalk unregisterExternalObject: ReadyForBuffer].    ReadyForBuffer _ nil.! !!SoundPlayer class methodsFor: 'primitive test' stamp: 'jm 9/13/97 20:01'!boinkPitch: p dur: d loudness: l waveTable: waveTable pan: pan    "Play a decaying note on the given stream using the given wave table. Used for testing only."    | decay tableSize amplitude increment cycles i |    decay _ 0.96.    tableSize _ waveTable size.    amplitude _ l asInteger min: 1000.    increment _ ((p asFloat * tableSize asFloat) / SamplingRate asFloat) asInteger.    increment _ (increment max: 1) min: (tableSize // 2).    cycles _ (d * SamplingRate asFloat) asInteger.    i _ 1.    1 to: cycles do: [:cycle |        (cycle \\ 100) = 0            ifTrue: [amplitude _ (decay * amplitude asFloat) asInteger].        i _ (((i - 1) + increment) \\ tableSize) + 1.        self playTestSample: (amplitude * (waveTable at: i)) // 1000 pan: pan].! !!SoundPlayer class methodsFor: 'primitive test' stamp: 'jm 9/17/97 12:55'!boinkScale    "Tests the sound output primitives by playing a scale."    "SoundPlayer boinkScale"    | sineTable pan |    self shutDown.    SamplingRate _ 11025.    Stereo _ true.    sineTable _ self sineTable: 1000.    Buffer _ SoundBuffer newStereoSampleCount: 1000.    BufferIndex _ 1.    self primSoundStartBufferSize: Buffer stereoSampleCount        rate: SamplingRate        stereo: Stereo.    pan _ 0.    #(261.626 293.665 329.628 349.229 391.996 440.001 493.884 523.252) do: [:p |        self boinkPitch: p dur: 0.3 loudness: 300 waveTable: sineTable pan: pan.        pan _ pan + 125].    self boinkPitch: 261.626 dur: 1.0 loudness: 300 waveTable: sineTable pan: 500.    self primSoundStop.    self shutDown.    SoundPlayer initialize.  "reset sampling rate, buffer size, and stereo flag"! !!SoundPlayer class methodsFor: 'primitive test' stamp: 'jm 9/17/97 12:55'!playTestSample: s pan: pan    "Append the given sample in the range [-32767..32767] to the output buffer, playing the output buffer when it is full. Used for testing only."    | sample leftSample |    BufferIndex >= Buffer size        ifTrue: [            "current buffer is full; play it"            [self primSoundAvailableBytes > 0]                whileFalse. "wait for space to be available"            self primSoundPlaySamples: Buffer stereoSampleCount from: Buffer startingAt: 1.            Buffer primFill: 0.            BufferIndex _ 1].    sample _ s.    sample >  32767 ifTrue: [ sample _  32767 ].     sample < -32767 ifTrue: [ sample _ -32767 ].    Stereo        ifTrue: [            leftSample _ (sample * pan) // 1000.            Buffer at: BufferIndex        put: sample - leftSample.            Buffer at: BufferIndex + 1    put: leftSample]        ifFalse: [            Buffer at: BufferIndex + 1 put: sample].    BufferIndex _ BufferIndex + 2.! !!SoundPlayer class methodsFor: 'primitive test' stamp: 'jm 9/17/97 20:06'!sineTable: size    "Compute a sine table of the given size. Used for testing only."    | radiansPerStep table |    table _ Array new: size.    radiansPerStep _ (2.0 * Float pi) / table size asFloat.    1 to: table size do: [:i |        table at: i put:            (32767.0 * (radiansPerStep * i) sin) asInteger].    ^ table! !!SoundPlayer class methodsFor: 'private' stamp: 'jm 9/13/97 20:11'!primSoundAvailableBytes    "Return the number of bytes of available space in the sound output buffer."    "Note: Squeak always uses buffers containing 4-bytes per sample (2 channels at 2 bytes per channel) regardless of the state of the Stereo flag."    <primitive: 173>    ^ self primitiveFailed! !!SoundPlayer class methodsFor: 'private' stamp: 'jm 9/17/97 16:55'!primSoundInsertSamples: count from: aSoundBuffer samplesOfLeadTime: anInteger    "Mix the given number of sample frames from the given sound buffer into the queue of samples that has already been submitted to the sound driver. This primitive is used to start a sound playing with minimum latency, even if large sound output buffers are being used to ensure smooth sound output. Returns the number of samples consumed, or zero if the primitive is not implemented or fails."    <primitive: 189>    ^ 0! !!SoundPlayer class methodsFor: 'private' stamp: 'jm 9/13/97 20:07'!primSoundPlaySamples: count from: aSampleBuffer startingAt: index    "Copy count bytes into the current sound output buffer from the given sample buffer starting at the given index."    <primitive: 174>    ^ self primitiveFailed! !!SoundPlayer class methodsFor: 'private' stamp: 'jm 9/13/97 20:05'!primSoundStartBufferSize: bufferSize rate: samplesPerSecond stereo: stereoFlag    "Start double-buffered sound output with the given buffer size and sampling rate. This version has been superceded by primitive 171 (primSoundStartBufferSize:rate:stereo:semaIndex:)."    <primitive: 170>    ^ self primitiveFailed! !!SoundPlayer class methodsFor: 'private' stamp: 'jm 9/18/97 16:21'!primSoundStartBufferSize: bufferSize rate: samplesPerSecond stereo: stereoFlag semaIndex: anInteger    "Start double-buffered sound output with the given buffer size and sampling rate. If the given semaphore index is > 0, it is taken to be the index of a Semaphore in the external objects array to be signalled when the sound driver is ready to accept another buffer of samples."    "Details: If this primitive fails, this method tries to use the older version instead."    <primitive: 171>    UseReadySemaphore _ false.    self primSoundStartBufferSize: bufferSize rate: samplesPerSecond stereo: stereoFlag.! !!SoundPlayer class methodsFor: 'private' stamp: 'jm 9/13/97 20:04'!primSoundStop    "Stop double-buffered sound output."    <primitive: 172>    ^ self primitiveFailed! !!SoundPlayer class methodsFor: 'private' stamp: 'jm 10/4/97 16:24'!startPlayingImmediately: aSound    "Private!! Start playing the given sound as soon as possible by mixing it into the sound output buffers of the underlying sound driver."    | dontInsertSamples totalSamples buf n leftover src rest |    dontInsertSamples _ true.  "temporary, until insert samples primitive is ported"    dontInsertSamples ifTrue: [        ActiveSounds add: aSound.        ^ self].    "first, fill a double-size buffer with samples"    totalSamples _ Buffer stereoSampleCount * 2.  "two buffer's worth"    buf _ SoundBuffer newStereoSampleCount: totalSamples.    aSound playSampleCount: totalSamples into: buf startingAt: 1 stereo: Stereo.    PlayerSemaphore critical: [        "insert as many samples as possible into the sound driver's buffers"        n _ self primSoundInsertSamples: totalSamples            from: buf            samplesOfLeadTime: 1024.        leftover _ totalSamples - n.        "copy the remainder of buf into Buffer"        "Note: the following loop iterates over 16-bit words, not two-word stereo slices"        "assert: 0 < leftover <= Buffer stereoSampleCount"        src _ 2 * n.        1 to: 2 * leftover do:            [:dst | Buffer at: dst put: (buf at: (src _ src + 1))].        "generate enough additional samples to finish filling Buffer"        rest _ Buffer stereoSampleCount - leftover.        aSound playSampleCount: rest into: Buffer startingAt: leftover + 1 stereo: Stereo.        "record the fact that this sound has already been played into Buffer so that  we don't process it again this time around"        SoundJustStarted _ aSound.        ActiveSounds add: aSound].! !!SoundRecorder methodsFor: 'initialization' stamp: 'jm 9/18/97 14:27'!initialize    "SoundRecorder new"    stereo _ false.    recordedBuffers _ OrderedCollection new: 1000.    meteringBuffer _ SoundBuffer newMonoSampleCount: 1024.    self stopRecording.! !!SoundRecorder methodsFor: 'accessing' stamp: 'jm 9/2/97 16:16'!isPaused    "Return true if recording is paused."    ^ paused! !!SoundRecorder methodsFor: 'accessing' stamp: 'jm 9/18/97 19:19'!meterLevel    "Return the meter level, an integer in the range [0..100] where zero is silence and 100 represents the maximum signal level possible without clipping."    ^ (100 * meterLevel) // 32768! !!SoundRecorder methodsFor: 'accessing' stamp: 'jm 10/4/97 17:55'!recordedSound    "Return the sound that was recorded."    | snd |    stereo ifTrue: [^ self condensedStereoSound].    snd _ SequentialSound new.    recordedBuffers do: [:buf |        snd add: (SampledSound new setSamples: buf samplingRate: samplingRate)].    ^ snd! !!SoundRecorder methodsFor: 'recording controls' stamp: 'jm 9/18/97 14:10'!clearRecordedSound    "Clear the sound recorded thus far. Go into pause mode if currently recording."    paused _ true.    recordedBuffers _ OrderedCollection new: 1000.    self allocateBuffer.! !!SoundRecorder methodsFor: 'recording controls' stamp: 'jm 10/4/97 16:09'!pause    "Go into pause mode. The record level continues to be updated, but no sound is recorded."    paused _ true.    ((currentBuffer ~~ nil) and: [nextIndex > 1])        ifTrue: [            recordedBuffers addLast: (currentBuffer copyFrom: 1 to: nextIndex - 1).            self allocateBuffer].    soundPlaying ifNotNil: [        soundPlaying pause.        soundPlaying _ nil].    CanRecordWhilePlaying ifFalse: [self stopRecording].! !!SoundRecorder methodsFor: 'recording controls' stamp: 'jm 9/18/97 14:16'!playback    "Playback the sound that has been recorded."    soundPlaying _ self recordedSound.    soundPlaying play.! !!SoundRecorder methodsFor: 'recording controls' stamp: 'jm 9/17/97 19:47'!recordLevel: anInteger    "Set the desired recording level to the given value in the range 0-1000, where 0 is the lowest recording level and 1000 is the maximum. Do nothing if the sound input hardware does not support changing the recording level."    self primSetRecordLevel: anInteger.! !!SoundRecorder methodsFor: 'recording controls' stamp: 'jm 10/4/97 16:09'!resumeRecording    "Continue recording from the point at which it was last paused."    CanRecordWhilePlaying ifFalse: [self startRecording].    paused _ false.! !!SoundRecorder methodsFor: 'recording controls' stamp: 'jm 10/4/97 16:08'!startRecording    "Turn of the sound input driver and start the recording process. Initially, recording is paused."    | semaIndex |    CanRecordWhilePlaying ifFalse: [SoundPlayer shutDown].    recordProcess ifNotNil: [self stopRecording].    paused _ true.    meteringBuffer _ SoundBuffer newMonoSampleCount: 1024.    meterLevel _ 0.    self allocateBuffer.    bufferAvailableSema _ Semaphore new.    semaIndex _ Smalltalk registerExternalObject: bufferAvailableSema.    self primStartRecordingDesiredSampleRate: (SoundPlayer samplingRate)        stereo: stereo        semaIndex: semaIndex.    samplingRate _ self primGetActualRecordingSampleRate.    recordProcess _ [self recordLoop] newProcess.    recordProcess priority: Processor userInterruptPriority.    recordProcess resume.! !!SoundRecorder methodsFor: 'recording controls' stamp: 'jm 9/18/97 14:14'!stopRecording    "Stop the recording process and turn of the sound input driver."    recordProcess ifNotNil: [recordProcess terminate].    recordProcess _ nil.    self primStopRecording.    Smalltalk unregisterExternalObject: bufferAvailableSema.    bufferAvailableSema _ nil.    paused _ true.    meteringBuffer _ nil.    meterLevel _ 0.    ((currentBuffer ~~ nil) and: [nextIndex > 1])        ifTrue: [            recordedBuffers addLast: (currentBuffer copyFrom: 1 to: nextIndex - 1)].    currentBuffer _ nil.    nextIndex _ 1.! !!SoundRecorder methodsFor: 'private' stamp: 'jm 9/18/97 14:38'!allocateBuffer    "Allocate a new buffer and reset nextIndex."    currentBuffer _ SoundBuffer newMonoSampleCount: 100000.    nextIndex _ 1.! !!SoundRecorder methodsFor: 'private' stamp: 'jm 9/18/97 14:57'!condensedSamples    "Return a single SoundBuffer that is the contatenation of all my recorded buffers."    | sz newBuf i |    recordedBuffers size < 2 ifTrue: [^ self].    sz _ recordedBuffers inject: 0 into: [:tot :buff | tot + buff size].    newBuf _ SoundBuffer newMonoSampleCount: sz.    i _ 1.    recordedBuffers do: [:b |        1 to: b size do: [:j |            newBuf at: i put: (b at: j).            i _ i + 1]].    ^ newBuf! !!SoundRecorder methodsFor: 'private' stamp: 'jm 10/4/97 17:54'!condensedStereoSound    "Decompose my buffers into left and right channels and return a mixed sound consisting of the those two channels. This may be take a while, since the data must be copied into new buffers."    | sz leftBuf rightBuf leftI rightI left |    sz _ recordedBuffers inject: 0 into: [:tot :buff | tot + buff size].    leftBuf _ SoundBuffer newMonoSampleCount: (sz + 1) // 2.    rightBuf _ SoundBuffer newMonoSampleCount: (sz + 1) // 2.    leftI _ rightI _ 1.    left _ true.    recordedBuffers do: [:b |        1 to: b size do: [:j |            left                ifTrue: [leftBuf at: leftI put: (b at: j). leftI _ leftI + 1. left _ false]                ifFalse: [rightBuf at: rightI put: (b at: j). rightI _ rightI + 1. left _ true]]].    ^ MixedSound new        add: (SampledSound new setSamples: leftBuf samplingRate: samplingRate) pan: 0;        add: (SampledSound new setSamples: rightBuf samplingRate: samplingRate) pan: 1000! !!SoundRecorder methodsFor: 'private' stamp: 'jm 9/2/97 16:16'!meterFrom: start count: count in: buffer    "Update the meter level with the maximum signal level in the given range of the given buffer."    | last max sample |    count = 0 ifTrue: [^ self].  "no new samples"    last _ start + count - 1.    max _ 0.    start to: last do: [:i |        sample _ buffer at: i.        sample < 0 ifTrue: [sample _ sample negated].        sample > max ifTrue: [max _ sample]].    meterLevel _ max.! !!SoundRecorder methodsFor: 'private' stamp: 'jm 9/18/97 14:43'!recordLoop    "Record process loop that records samples."    | n sampleCount |    n _ 0.    [true] whileTrue: [        n = 0 ifTrue: [bufferAvailableSema wait].        paused            ifTrue: [                n _ self primRecordSamplesInto: meteringBuffer startingAt: 1.                self meterFrom: 1 count: n in: meteringBuffer]            ifFalse: [                n _ self primRecordSamplesInto: currentBuffer startingAt: nextIndex.                self meterFrom: nextIndex count: n in: currentBuffer.                nextIndex _ nextIndex + n.                stereo                    ifTrue: [sampleCount _ currentBuffer stereoSampleCount]                    ifFalse: [sampleCount _ currentBuffer monoSampleCount].                nextIndex > sampleCount                    ifTrue: [                        recordedBuffers addLast: currentBuffer.                        self allocateBuffer]]].! !!SoundRecorder methodsFor: 'primitives' stamp: 'jm 9/17/97 16:56'!primGetActualRecordingSampleRate    "Return the actual sample rate being used for recording. This primitive fails unless sound recording is currently in progress."    <primitive: 192>    self primitiveFailed! !!SoundRecorder methodsFor: 'primitives' stamp: 'jm 9/17/97 16:56'!primRecordSamplesInto: aWordArray startingAt: index    "Record a sequence of 16-bit sound samples into the given array starting at the given sample index. Return the number of samples recorded, which may be zero if no samples are currently available."    <primitive: 193>    self primitiveFailed! !!SoundRecorder methodsFor: 'primitives' stamp: 'jm 9/17/97 16:56'!primSetRecordLevel: anInteger    "Set the desired recording level to the given value in the range 0-1000, where 0 is the lowest recording level and 1000 is the maximum. Do nothing if the sound input hardware does not support changing the recording level."    <primitive: 194>    self primitiveFailed! !!SoundRecorder methodsFor: 'primitives' stamp: 'jm 9/18/97 13:11'!primStartRecordingDesiredSampleRate: samplesPerSec stereo: stereoFlag semaIndex: anInteger    "Start sound recording with the given stereo setting. Use a sampling rate as close to the desired rate as the underlying platform will support. If the given semaphore index is > 0, it is taken to be the index of a Semaphore in the external objects array to be signalled every time a recording buffer is filled."    <primitive: 190>    self primitiveFailed! !!SoundRecorder methodsFor: 'primitives' stamp: 'jm 9/17/97 16:56'!primStopRecording    "Stop sound recording. Does nothing if recording is not currently in progress."    <primitive: 191>    self primitiveFailed! !!SoundRecorder class methodsFor: 'class initialization' stamp: 'jm 10/4/97 16:13'!initialize    "SoundRecorder initialize"    "Details: Some computers cannot record and playback sound at the same time. If CanRecordWhilePlaying is false, then the SoundRecorder alternates between recording and playing. If it is true, sounds can be playing during recording."    CanRecordWhilePlaying _ false.! !!SoundRecorder class methodsFor: 'instance creation' stamp: 'jm 8/24/97 01:20'!new    ^ super new initialize! !!Spline class methodsFor: 'examples' stamp: '6/8/97 13:55 di'!example    "Designate points on the Path by clicking the red button. Terminate by    pressing any other button. A curve will be displayed, through the    selected points, using a long black form."    | splineCurve aForm flag|    aForm _ Form extent: 2@2.    aForm  fillBlack.    splineCurve _ Spline new.    splineCurve form: aForm.    flag _ true.    [flag] whileTrue:        [Sensor waitButton.         Sensor redButtonPressed            ifTrue:                 [splineCurve add: Sensor waitButton.                  Sensor waitNoButton.                 aForm displayOn: Display at: splineCurve last]            ifFalse: [flag_false]].    splineCurve computeCurve.    splineCurve isEmpty         ifFalse: [splineCurve displayOn: Display.                Sensor waitNoButton].     "Spline example"! !!StandardFileStream methodsFor: 'properties-setting' stamp: 'jm 9/21/97 18:09'!setFileTypeToObject    "On the Macintosh, set the file type and creator of this file to be a Squeak object file. On other platforms, do nothing. Setting the file type allows Squeak object files to be sent as email attachments and launched by double-clicking. On other platforms, similar behavior is achieved by creating the file with the '.sqo' file name extension."    self setType: 'SOBJ' creator: 'FAST'.! !!StandardFileStream methodsFor: 'properties-setting' stamp: 'sw 2/14/96'!setType: tString creator: cString    "Mac-specific; set the type and creator of the corresponding file; for the moment, we only define this where we have the backward-compatible implementation via fallback stream.  Ultimately, for this to work, some new primitive will need to be added to StandardFileStream.      Just go ahead and make it work anyway.  "    FileDirectory activeDirectoryClass == MacFileDirectory ifTrue: [        MacFileDirectory setMacFileNamed: self fullName type: tString creator: cString].! !!StandardFileStream methodsFor: 'access' stamp: 'di 6/27/97 12:18'!peekFor: item     "Answer false and do not advance if the next element is not equal to item, or if this stream is at the end.  If the next element is equal to item, then advance over it and return true"    | next |    "self atEnd ifTrue: [^ false]. -- SFStream will give nil"    (next _ self next) == nil ifTrue: [^ false].    item = next ifTrue: [^ true].    self skip: -1.    ^ false! !!StandardFileStream methodsFor: 'read, write, position' stamp: 'sw 2/12/96'!atEnd    "Answer whether the receiver is at its end.  "    ^ self primAtEnd: fileID! !!StandardFileStream methodsFor: 'read, write, position' stamp: 'sw 2/12/96'!next    "Read the next object from the file. "    | count |    count _ self primRead: fileID into: buffer1 startingAt: 1 count: 1.    count = 1        ifTrue: [ ^ buffer1 at: 1 ]        ifFalse: [ ^ nil ].! !!StandardFileStream methodsFor: 'read, write, position' stamp: 'sw 1/31/96'!peek    "Answer what would be returned if the message next were sent to the receiver. If the receiver is at the end, answer nil.  "    | next |    self atEnd ifTrue: [^ nil].    next _ self next.    self position: self position - 1.    ^ next! !!StandardFileStream methodsFor: 'read, write, position' stamp: 'di 7/14/97 23:15'!upTo: delim     "Fast version to speed up nextChunk"    | pos buffer count |    pos _ self position.    buffer _ self next: 2000.    (count _ buffer indexOf: delim) > 0 ifTrue:         ["Found the delimiter part way into buffer"        self position: pos + count.        ^ buffer copyFrom: 1 to: count - 1].    self atEnd ifTrue:        ["Never found it, and hit end of file"        ^ buffer].    "Never found it, but there's more..."    ^ buffer , (self upTo: delim)! !!StandardFileStream methodsFor: 'read, write, position' stamp: 'di 6/28/97 21:33'!verbatim: aString    "A copy of nextPutAll that can be called knowing it wont call nextPut: "    self primWrite: fileID from: aString startingAt: 1 count: aString size.    ^ aString! !!StandardFileStream methodsFor: 'added by paul' stamp: 'pm 9/22/97 15:39'!padToNextLongPut: char     "Make position be on long word boundary, writing the padding     character, char, if necessary."    [self position \\ 4 = 0]        whileFalse: [self nextPut: char]! !!StandardFileStream class methodsFor: 'file creation' stamp: 'di 10/4/97 10:09'!newFileNamed: aFileName     "create a file in the default directory (or in the directory contained in the input arg), set for write access."    | result selection |    (self isAFileNamed: aFileName) ifFalse:        [^ self new open: aFileName forWrite: true].    "File already exists..."    selection _ (PopUpMenu labels: 'overwrite that filechoose another namecancel')            startUpWithCaption: (self localNameFor: aFileName) , 'already exists.'.    selection = 1 ifTrue:        [result _ FileDirectory default deleteFileNamed: aFileName.        result == nil ifTrue: "deletion failed"                [self halt: 'Sorry - deletion failed'].        ^ self new open: aFileName forWrite: true].    selection = 2 ifTrue:        [^ self newFileNamed:            (FillInTheBlank request: 'Enter a new file name'                        initialAnswer: aFileName)].    self halt! !!StandardFileStream class methodsFor: 'file creation' stamp: 'di 10/4/97 10:16'!oldFileNamed: aFileName      "Open a file in the default directory (or in the directory contained    in the input arg); by default, it's available for reading.  2/12/96 sw    Prior contents will be overwritten, but not truncated on close.  3/18 di"    | selection |    (self isAFileNamed: aFileName) ifTrue:        [^ self new open: aFileName forWrite: true].    "File does not exist..."    selection _ (PopUpMenu labels: 'create a new filechoose another namecancel')            startUpWithCaption: (self localNameFor: aFileName) , 'does not exist.'.    selection = 1 ifTrue:        [^ self new open: aFileName forWrite: true].    selection = 2 ifTrue:        [^ self oldFileNamed:            (FillInTheBlank request: 'Enter a new file name'                        initialAnswer: aFileName)].    self halt! !!StandardFileStream class methodsFor: 'file creation' stamp: 'di 10/4/97 10:21'!readOnlyFileNamed: aFileName    "Open a file of the given name for read-only access.  1/31/96 sw"    | selection |    (self isAFileNamed: aFileName) ifTrue:        [^ self new open: aFileName forWrite: false].    "File does not exist..."    selection _ (PopUpMenu labels: 'choose another namecancel')            startUpWithCaption: (self localNameFor: aFileName) , 'does not exist.'.    selection = 1 ifTrue:        [^ self readOnlyFileNamed:            (FillInTheBlank request: 'Enter a new file name'                        initialAnswer: aFileName)].    self halt! !!StandardSystemController methodsFor: 'control defaults'!controlActivity    self checkForReframe.    ^ super controlActivity! !!StandardSystemController methodsFor: 'basic control sequence'!controlInitialize    view displayEmphasized.    view uncacheBits.  "Release cached bitmap while active"    sensor waitNoButton.    status _ #active! !!StandardSystemController methodsFor: 'menu messages'!collapse    "Get the receiver's view to change to a collapsed view on the screen."    view collapseToPoint: view chooseCollapsePoint! !!StandardSystemController methodsFor: 'menu messages'!reframe    ^ view reframeTo: view getFrame! !!StandardSystemController methodsFor: 'menu messages'!toggleTwoTone    (view isMemberOf: StandardSystemView) ifTrue:        [^ view become: (view as: ColorSystemView)].    (view isMemberOf: ColorSystemView) ifTrue:        [^ view become: (view as: StandardSystemView)].! !!StandardSystemController methodsFor: 'borders'!adjustPaneBorders     | side sub newRect outerFrame |    outerFrame _ view displayBox.    side = #none.    VBorderCursor showWhile:        [ [sub _ view subviewWithLongestSide: [:s | side _ s]                        near: sensor cursorPoint.          self cursorOnBorder and: [(side = #left) | (side = #right)]]            whileTrue: [sensor redButtonPressed ifTrue:                [side = #left ifTrue:                    [newRect _ sub stretchFrame:                        [:f | (f withLeft: sensor cursorPoint x)                                intersect: outerFrame]                        startingWith: sub displayBox].                side = #right ifTrue:                    [newRect _ sub stretchFrame:                        [:f | (f withRight: sensor cursorPoint x)                                intersect: outerFrame]                        startingWith: sub displayBox].                view reframePanesAdjoining: sub along: side to: newRect]]].    HBorderCursor showWhile:        [ [sub _ view subviewWithLongestSide: [:s | side _ s]                        near: sensor cursorPoint.          self cursorOnBorder and: [(side = #top) | (side = #bottom)]]            whileTrue: [sensor redButtonPressed ifTrue:                [side = #top ifTrue:                    [newRect _ sub stretchFrame:                        [:f | (f withTop: sensor cursorPoint y)                                intersect: outerFrame]                        startingWith: sub displayBox].                side = #bottom ifTrue:                    [newRect _ sub stretchFrame:                        [:f | (f withBottom: sensor cursorPoint y)                                intersect: outerFrame]                        startingWith: sub displayBox].                view reframePanesAdjoining: sub along: side to: newRect]]]! !!StandardSystemController methodsFor: 'borders'!adjustWindowBorders     | side |    VBorderCursor showWhile:        [ [side _ view displayBox sideNearestTo: sensor cursorPoint.          self cursorOnBorder and: [(side = #left) | (side = #right)]]            whileTrue:            [(sensor redButtonPressed and: [self cursorOnBorder]) ifTrue:                [side = #left ifTrue:                    [view newFrame: [:f | f withLeft: sensor cursorPoint x]].                side = #right ifTrue:                    [view newFrame: [:f | f withRight: sensor cursorPoint x]]]]].    HBorderCursor showWhile:        [ [side _ view displayBox sideNearestTo: sensor cursorPoint.          self cursorOnBorder and: [(side = #top) | (side = #bottom)]]            whileTrue:            [(sensor redButtonPressed and: [self cursorOnBorder]) ifTrue:                [side = #top ifTrue:                    [view newFrame: [:f | f withTop: sensor cursorPoint y]].                side = #bottom ifTrue:                    [view newFrame: [:f | f withBottom: sensor cursorPoint y]].        ]]]! !!StandardSystemController methodsFor: 'borders'!adjustWindowCorners     | box cornerBox p clicked f2 |    box _ view windowBox.    clicked _ false.    #(topLeft topRight bottomRight bottomLeft)        do: [:readCorner |            cornerBox _ ((box insetBy: 2) perform: readCorner) - (10@10) extent: 20@20.            (cornerBox containsPoint: sensor cursorPoint)                ifTrue:                 ["Display reverse: cornerBox."                (Cursor perform: readCorner) showWhile:                    [[(cornerBox containsPoint: (p _ sensor cursorPoint))                        and: [(clicked _ sensor anyButtonPressed) not]]                        whileTrue.                "Display reverse: cornerBox."                clicked ifTrue:                    [view newFrame:                        [:f | p _ sensor cursorPoint.                        readCorner = #topLeft ifTrue:                            [f2 _ p corner: f bottomRight].                        readCorner = #bottomLeft ifTrue:                            [f2 _ (f withBottom: p y) withLeft: p x].                        readCorner = #bottomRight ifTrue:                            [f2 _ f topLeft corner: p].                        readCorner = #topRight ifTrue:                            [f2 _ (f withTop: p y) withRight: p x].                        f2]]]]].    ^ clicked! !!StandardSystemController methodsFor: 'borders'!checkForReframe    | cp |    view isCollapsed ifTrue: [^ self].    cp _ sensor cursorPoint.    ((view closeBoxFrame expandBy: 2) containsPoint: cp)        | ((view growBoxFrame expandBy: 2) containsPoint: cp)        ifTrue: [^ self].  "Dont let reframe interfere with close/grow"    self adjustWindowCorners.    self cursorOnBorder ifFalse: [^ self].    ((view insetDisplayBox insetBy: 2@2) containsPoint: cp)        ifFalse: [^ self adjustWindowBorders].    (view subviewWithLongestSide: [:s | ] near: cp) == nil        ifFalse: [^ self adjustPaneBorders].! !!StandardSystemController methodsFor: 'borders'!cursorOnBorder     | cp i box |    view isCollapsed ifTrue: [^ false].    cp _ sensor cursorPoint.    ((view labelDisplayBox insetBy: (0@2 corner: 0@-2)) containsPoint: cp)        ifTrue: [^ false].    (i _ view subViews findFirst: [:v | v displayBox containsPoint: cp]) = 0        ifTrue: [box _ view windowBox]        ifFalse: [box _ (view subViews at: i) insetDisplayBox].    ^ ((box insetBy: 3) containsPoint: cp) not        and: [(box expandBy: 4) containsPoint: cp]! !!StandardSystemController class methodsFor: 'class initialization'!initialize   "StandardSystemController initialize"    "Set up the menus for standard windows.       6/6/96 sw: added fullScreen"    ScheduledBlueButtonMenu _ PopUpMenu labels: 'edit labelchoose color...two-tone/full colormoveframefull screencollapseclose'    lines: #(3 7).    ScheduledBlueButtonMessages _ #(label chooseColor toggleTwoTone move reframe fullScreen collapse close)."StandardSystemController initialize.ScheduledControllers scheduledWindowControllers        do: [:c | c initializeBlueButtonMenu]"    VBorderCursor _ Cursor extent: 16@16 fromArray: #(        2r1010000000000000        2r1010000000000000        2r1010000000000000        2r1010000000000000        2r1010000000000000        2r1010010000100000        2r1010110000110000        2r1011111111111000        2r1010110000110000        2r1010010000100000        2r1010000000000000        2r1010000000000000        2r1010000000000000        2r1010000000000000        2r1010000000000000        2r1010000000000000)            offset: 0@0.    HBorderCursor _ Cursor extent: 16@16 fromArray: #(        2r1111111111111111        2r0000000000000000        2r1111111111111111        2r0000000100000000        2r0000001110000000        2r0000011111000000        2r0000000100000000        2r0000000100000000        2r0000000100000000        2r0000000100000000        2r0000011111000000        2r0000001110000000        2r0000000100000000        2r0000000000000000        2r0000000000000000        2r0000000000000000)            offset: 0@0.! !!StandardSystemView methodsFor: 'initialize-release'!initialize     "Refer to the comment in View|initialize."    super initialize.    labelFrame _ Quadrangle new.    labelFrame region: (Rectangle origin: 0 @ 0 extent: 50 @ self labelHeight).    labelFrame borderWidthLeft: 2 right: 2 top: 2 bottom: 2.    self label: nil.    isLabelComplemented _ false.    minimumSize _ 50 @ 50.    maximumSize _ Display extent.    collapsedViewport _ nil.    expandedViewport _ nil.    bitsValid _ false.! !!StandardSystemView methodsFor: 'initialize-release' stamp: 'di 6/24/97 14:05'!release    self isCollapsed ifTrue: [savedSubViews do: [:v | v release]].    super release! !!StandardSystemView methodsFor: 'label access' stamp: 'di 6/16/97 12:30'!closeBoxFrame    ^ Rectangle origin: (self labelDisplayBox leftCenter + (10@-5)) extent: (11@11)! !!StandardSystemView methodsFor: 'label access' stamp: 'di 6/16/97 12:29'!growBoxFrame    ^ Rectangle origin: (self labelDisplayBox rightCenter + (-22@-5)) extent: (11@11)! !!StandardSystemView methodsFor: 'label access'!label    "Answer the string that appears in the receiver's label."    labelText isNil        ifTrue: [^ 'Untitled' copy]        ifFalse: [^ labelText asString]! !!StandardSystemView methodsFor: 'label access'!label: aString     "Set aString to be the receiver's label."    labelText _ Paragraph            withText: (Text string: ((aString == nil or: [aString isEmpty])                                ifTrue: ['Untitled' copy]                                ifFalse: [aString])                            attributes: (Array with: (TextFontChange fontNumber: 2)                                            with: TextEmphasis bold))            style: LabelStyle.    insetDisplayBox == nil ifTrue: [^ self].  "wait for further initialization"    self setLabelRegion! !!StandardSystemView methodsFor: 'label access'!labelDisplayBox    "Answer the rectangle that borders the visible parts of the receiver's label     on the display screen."    ^ labelFrame region        align: labelFrame topLeft        with: self windowOrigin! !!StandardSystemView methodsFor: 'label access'!labelFrame    ^labelFrame! !!StandardSystemView methodsFor: 'label access' stamp: 'di 6/16/97 08:44'!labelHeight    ^ (LabelStyle fontAt: 2) height + 4! !!StandardSystemView methodsFor: 'label access'!labelOffset    ^ 0 @ (self labelHeight-2)! !!StandardSystemView methodsFor: 'label access'!labelTextRegion    labelText == nil ifTrue: [^ self labelDisplayBox center extent: 0@0].    ^ (labelText boundingBox            align: labelText boundingBox center            with: self labelDisplayBox center)        intersect: (self labelDisplayBox insetBy: 35@0)! !!StandardSystemView methodsFor: 'label access'!setLabelRegion    "Always follows view width"    labelFrame region: (0 @ 0 extent: self displayBox width @ self labelHeight).! !!StandardSystemView methodsFor: 'framing'!chooseCollapsePoint    "Answer the point at which to place the collapsed window."    | pt labelForm beenDown offset |    labelForm _ Form fromDisplay: self labelDisplayBox.    self uncacheBits.    self erase.    beenDown _ Sensor anyButtonPressed.    self isCollapsed ifTrue:        [offset _ self labelDisplayBox topLeft - self growBoxFrame topLeft.        labelForm follow: [pt _ (Sensor cursorPoint + offset max: 0@0) truncateTo: 8]                while: [Sensor anyButtonPressed                            ifTrue: [beenDown _ true]                            ifFalse: [beenDown not]].        ^ pt].    collapsedViewport isNil ifTrue:        [^ RealEstateAgent assignCollapsePointFor: self].    labelForm slideFrom: self labelDisplayBox origin            to: (pt _ collapsedViewport topLeft) nSteps: 10.    ^ pt! !!StandardSystemView methodsFor: 'framing'!chooseFrame    "Answer a new frame, depending on whether the view is currently     collapsed or not."    | labelForm f |    self isCollapsed & expandedViewport notNil        ifTrue:            [labelForm _ bitsValid                ifTrue: [windowBits]                ifFalse: [Form fromDisplay: self labelDisplayBox].            bitsValid _ false.            self erase.            labelForm slideFrom: self labelDisplayBox origin                    to: expandedViewport origin-self labelOffset                    nSteps: 10.            ^ expandedViewport]        ifFalse:            [f _ self getFrame.            bitsValid _ false.            self erase.            ^ f topLeft + self labelOffset extent: f extent]! !!StandardSystemView methodsFor: 'framing'!collapse    "If the receiver is not already collapsed, change its view to be that of its     label only."    self isCollapsed ifFalse:            [expandedViewport _ self viewport.            savedSubViews _ subViews.            self resetSubViews.            labelText isNil ifTrue: [self label: nil.  bitsValid _ false.].            self window: (self inverseDisplayTransform:                    ((self labelDisplayBox topLeft extent: (labelText extent x + 70) @ self labelHeight)                         intersect: self labelDisplayBox))]! !!StandardSystemView methodsFor: 'framing'!collapsedFrame    "Answer the rectangle occupied by this window when collapsed."    ^ collapsedViewport  "NOTE may be nil"! !!StandardSystemView methodsFor: 'framing'!collapseToPoint: collapsePoint    self collapse.    self align: self displayBox topLeft with: collapsePoint.    collapsedViewport _ self viewport.    self displayEmphasized! !!StandardSystemView methodsFor: 'framing'!expand    "If the receiver is collapsed, change its view to be that of all of its     subviews, not its label alone. "    | newFrame |    self isCollapsed        ifTrue:            [newFrame _ self chooseFrame.            collapsedViewport _ self viewport.            subViews _ savedSubViews.            self window: self defaultWindow.            labelFrame borderWidthLeft: 2 right: 2 top: 2 bottom: 2.            savedSubViews _ nil.            self resizeTo: newFrame.            self displayDeEmphasized]! !!StandardSystemView methodsFor: 'framing'!expandedFrame    "Answer the rectangle occupied by this window when expanded."    ^ expandedViewport  "NOTE may be nil"! !!StandardSystemView methodsFor: 'framing' stamp: 'sw 1/22/96'!initialExtent    "Answer the desired extent for the receiver when it is first opened on the screen.  "    ^ model initialExtent min: maximumSize max: minimumSize! !!StandardSystemView methodsFor: 'framing'!newDisplayBoxFor: subView adjoining: newRect along: side     side = #left ifTrue: [^ subView displayBox withRight: newRect left].    side = #right ifTrue: [^ subView displayBox withLeft: newRect right].    side = #top ifTrue: [^ subView displayBox withBottom: newRect top].    side = #bottom ifTrue: [^ subView displayBox withTop: newRect bottom].! !!StandardSystemView methodsFor: 'framing'!reframePanesAdjoining: subView along: side to: aDisplayBox     | newBox delta newRect minDim |    newRect _ aDisplayBox.    "First check that this won't make any pane smaller than 8 screen dots"    minDim _ ((subViews select: [:sub | sub displayBox bordersOn: subView displayBox along: side])        collect: [:sub | self newDisplayBoxFor: sub adjoining: newRect along: side])            inject: 999 into: [:was :rect | (was min: rect width) min: rect height].    "If so, amend newRect as required"    minDim < 8 ifTrue:        [delta _ minDim - 8.        newRect _ newRect withSide: side setTo:                 ((newRect perform: side) > (subView displayBox perform: side)                    ifTrue: [(newRect perform: side) + delta]                    ifFalse: [(newRect perform: side) - delta])].    "Now adjust all adjoining panes for real"    subViews do:        [:sub | (sub displayBox bordersOn: subView displayBox along: side) ifTrue:            [newBox _ self newDisplayBoxFor: sub adjoining: newRect along: side.            sub window: sub window viewport:                (sub transform: (sub inverseDisplayTransform: newBox)) rounded]].    "And adjust the growing pane itself"    subView window: subView window viewport:            (subView transform: (subView inverseDisplayTransform: newRect)) rounded.    "Finally force a recomposition of the whole window"    self window: self window viewport: self viewport.    self uncacheBits; displayEmphasized! !!StandardSystemView methodsFor: 'framing' stamp: 'sw 1/26/96'!reframeTo: newFrame    "Reframe the receiver to the given screen rectangle.      Repaint difference after the change.  "    | oldBox newBox portRect |    self uncacheBits.    oldBox _ self windowBox.    portRect _ newFrame topLeft + self labelOffset                corner: newFrame corner.    self window: self window viewport: portRect.    self setLabelRegion.    newBox _ self windowBox.    (oldBox areasOutside: newBox) do:        [:rect | ScheduledControllers restore: rect].    self displayEmphasized! !!StandardSystemView methodsFor: 'framing'!resize    "Determine the rectangular area for the receiver, adjusted to the     minimum and maximum sizes."    | f |    f _ self getFrame.    self resizeTo: (f topLeft + self labelOffset extent: f extent)! !!StandardSystemView methodsFor: 'framing'!windowOrigin    ^ self isCollapsed        ifTrue: [self displayBox topLeft]        ifFalse: [self displayBox topLeft - self labelOffset]! !!StandardSystemView methodsFor: 'displaying'!cacheBitsAsIs    CacheBits ifFalse: [^ self uncacheBits].    windowBits _ (self cacheBitsAsTwoTone and: [Display depth > 1])        ifTrue: [ColorForm                    twoToneFromDisplay: self windowBox                    using: windowBits                    backgroundColor: self backgroundColor]        ifFalse: [Form fromDisplay: self windowBox using: windowBits].    bitsValid _ true.! !!StandardSystemView methodsFor: 'displaying'!deEmphasizeForDebugger    "Carefully de-emphasis this window because a debugger is being opened. Care must be taken to avoid invoking potentially buggy window display code that could cause a recursive chain of errors eventually resulting in a virtual machine crash. In particular, do not de-emphasize the subviews."    self deEmphasizeView.  "de-emphasize this top-level view"    self uncacheBits.    Smalltalk garbageCollectMost > 1000000 ifTrue: [        "if there is enough space, cache current window screen bits"        self cacheBitsAsIs].! !!StandardSystemView methodsFor: 'displaying'!deEmphasizeLabel    "Un-Highlight the label."    self displayLabelBackground: false.    self displayLabelText.! !!StandardSystemView methodsFor: 'displaying'!displayDeEmphasized    "Display this view with emphasis off.    If windowBits is not nil, then simply BLT"    bitsValid        ifTrue: [self lock.                windowBits displayAt: self windowOrigin]        ifFalse: [super display.                CacheBits ifTrue: [self cacheBitsAsIs]]! !!StandardSystemView methodsFor: 'displaying'!displayLabelBackground: emphasized    "Clear or emphasize the inner region of the label"    | r1 r2 r3 c3 c2 c1 |    emphasized ifFalse:        ["Just clear the label if not emphasized"        ^ Display fill: (self labelDisplayBox insetBy: 2) fillColor: self labelColor].    r1 _ self labelDisplayBox insetBy: 2.    r2 _ r1 insetBy: 0@2.    r3 _ r2 insetBy: 0@3.    c3 _ self labelColor.    c2 _ c3 darker.    c1 _ c2 darker darker.    Display fill: r1 fillColor: c1.    Display fill: r2 fillColor: c2.    Display fill: r3 fillColor: c3. "    Here is the Mac racing stripe code    stripes _ Bitmap with: (self labelColor pixelWordForDepth: Display depth)                    with: (Form black pixelWordForDepth: Display depth).    self windowOrigin y even ifTrue: [stripes swap: 1 with: 2].    Display fill: (self labelDisplayBox insetBy: 3) fillColor: stripes."! !!StandardSystemView methodsFor: 'displaying'!displayLabelText    "The label goes in the center of the window"    | labelRect |    labelText foregroundColor: self foregroundColor            backgroundColor: self labelColor.    labelRect _ self labelTextRegion.    Display fill: (labelRect expandBy: 3@0) fillColor: self labelColor.    labelText displayOn: Display at: labelRect topLeft clippingBox: labelRect            rule: labelText rule fillColor: labelText fillColor! !!StandardSystemView methodsFor: 'displaying' stamp: 'di 8/29/97 18:57'!displayOn: aPort    bitsValid ifFalse:        [^ Display clippingTo: aPort clipRect do: [super display]].    windowBits displayOnPort: aPort at: self windowOrigin! !!StandardSystemView methodsFor: 'displaying'!displayRacingStripes    "Display Racing Stripes in the label"    | labelDisplayBox stripes top bottom left box right |    labelDisplayBox _ self labelDisplayBox.    top _ labelDisplayBox top + 3.    bottom _ labelDisplayBox bottom - 3.    stripes _ Bitmap with: (self labelColor pixelWordForDepth: Display depth)            with: (Color black pixelWordForDepth: Display depth).    top even ifFalse: [stripes swap: 1 with: 2].    left _ labelDisplayBox left + 3.    box _ self closeBoxFrame.    right _ box left - 2.    Display fill: (Rectangle left: left right: right top: top bottom: bottom)            fillColor: stripes.    left _ box right + 2.    box _ self labelTextRegion.    right _ box left - 3.    Display fill: (Rectangle left: left right: right top: top bottom: bottom)            fillColor: stripes.    left _ box right + 2.    box _ self growBoxFrame.    right _ box left - 2.    Display fill: (Rectangle left: left right: right top: top bottom: bottom)            fillColor: stripes.    left _ box right + 2.    right _ labelDisplayBox right - 3.    Display fill: (Rectangle left: left right: right top: top bottom: bottom)            fillColor: stripes.! !!StandardSystemView methodsFor: 'displaying'!displayView    "Refer to the comment in View|displayView. "    self displayBox width = labelFrame width ifFalse:        ["recompute label width when window changes size"        self setLabelRegion].    (labelFrame align: labelFrame topLeft with: self windowOrigin)        insideColor: self labelColor;        displayOn: Display.    self displayLabelText! !!StandardSystemView methodsFor: 'displaying'!emphasizeLabel    "Highlight the label."    self displayLabelBackground: true.    self displayLabelBoxes.    self displayLabelText.! !!StandardSystemView methodsFor: 'displaying' stamp: 'di 8/30/97 11:07'!erase    "Clear the display box of the receiver to be gray, as the screen background."    | oldValid |    CacheBits        ifTrue:            [oldValid _ bitsValid.            bitsValid _ false.            ScheduledControllers restore: self windowBox without: self.            bitsValid _ oldValid]        ifFalse:            [ScheduledControllers restore: self windowBox without: self]! !!StandardSystemView methodsFor: 'displaying'!windowBits    ^ windowBits! !!StandardSystemView methodsFor: 'deEmphasizing'!deEmphasizeView     "Refer to the comment in View|deEmphasizeView."    isLabelComplemented ifTrue:        [self deEmphasizeLabel.        isLabelComplemented _ false]! !!StandardSystemView methodsFor: 'private'!subviewWithLongestSide: sideBlock near: aPoint     | region subs max rect side len theSub theSide |    region _ aPoint - (4@4) corner: aPoint + (4@4).    subs _ subViews select: [:sub | sub insetDisplayBox intersects: region].    subs isEmpty ifTrue: [sideBlock value: #none.  ^ nil].    max _ 0.    subs do:        [:sub | rect _ sub insetDisplayBox.        side _ rect sideNearestTo: aPoint.        len _ (side = #left) | (side = #right)            ifTrue: [rect height]            ifFalse: [rect width].        len > max ifTrue: [max _ len.  theSub _ sub.  theSide _ side]].    sideBlock value: theSide.    ^ theSub! !!StandardSystemView class methodsFor: 'class initialization'!cachingBits    ^ CacheBits! !!StandardSystemView class methodsFor: 'class initialization'!initialize        "StandardSystemView initialize"    self doCacheBits.    (LabelStyle _ TextStyle default copy)        gridForFont: 2 withLead: 0! !!StrikeFont methodsFor: 'accessing'!setGlyphs: newGlyphs    "Replace the glyphs form.  Used to make a synthetic bold or italic font quickly."    glyphs _ newGlyphs! !!StrikeFont methodsFor: 'accessing'!widthOf: aCharacter     "Answer the width of the argument as a character in the receiver."    | ascii |    ascii _ (aCharacter asciiValue min: maxAscii) max: minAscii.    ^(xTable at: ascii + 2) - (xTable at: ascii + 1)! !!StrikeFont methodsFor: 'emphasis'!bonk: glyphForm with: bonkForm    "Bonking means to run through the glyphs clearing out black pixels    between characters to prevent them from straying into an adjacent    character as a result of, eg, bolding or italicizing"    "Uses the bonkForm to erase at every character boundary in glyphs."    | bb offset |    offset _ bonkForm offset x.    bb _ BitBlt toForm: glyphForm.    bb sourceForm: bonkForm; sourceRect: bonkForm boundingBox;        combinationRule: Form erase; destY: 0.    1 to: xTable size-1 do: [:i | bb destX: (xTable at: i) + offset; copyBits].! !!StrikeFont methodsFor: 'emphasis'!emphasized: code     "Answer a copy of the receiver with emphasis set to include code."    | derivative addedEmphasis base g r safeCode |    code = 0 ifTrue: [^ self].    (derivativeFonts == nil or: [derivativeFonts size = 0]) ifTrue: [^ self].    derivative _ derivativeFonts at: (safeCode _ code min: derivativeFonts size).    derivative == nil ifFalse: [^ derivative].  "Already have this style"    "Dont have it -- derive from another with one with less emphasis"    addedEmphasis _ 1 bitShift: safeCode highBit - 1.    base _ self emphasized: safeCode - addedEmphasis.  "Order is Bold, Ital, Under, Narrow"    addedEmphasis = 1 ifTrue:   "Compute synthetic bold version of the font"        [derivative _ (base copy name: base name , 'B') makeBoldGlyphs].    addedEmphasis = 2 ifTrue:   "Compute synthetic italic version of the font"        [ derivative _ (base copy name: base name , 'I') makeItalicGlyphs].    addedEmphasis = 4 ifTrue:   "Compute underlined version of the font"        [derivative _ (base copy name: base name , 'U') makeUnderlinedGlyphs].    addedEmphasis = 8 ifTrue:   "Compute narrow version of the font"        [derivative _ (base copy name: base name , 'N') makeCondensedGlyphs].    addedEmphasis = 16 ifTrue:   "Compute struck-out version of the font"        [derivative _ (base copy name: base name , 'X') makeStruckOutGlyphs].    derivative emphasis: safeCode.    derivativeFonts at: safeCode put: derivative.    ^ derivative! !!StrikeFont methodsFor: 'emphasis'!makeBoldGlyphs    "Make a bold set of glyphs with same widths by ORing 1 bit to the right        (requires at least 1 pixel of intercharacter space)"    | g bonkForm |    g _ glyphs deepCopy.    bonkForm _ (Form extent: 1@16) fillBlack offset: -1@0.    self bonk: g with: bonkForm.    g copyBits: g boundingBox from: g at: (1@0)        clippingBox: g boundingBox rule: Form under fillColor: nil.    glyphs _ g! !!StrikeFont methodsFor: 'emphasis'!makeCondensedGlyphs    "Make an underlined set of glyphs with same widths"    | g newXTable x x1 w |    g _ glyphs deepCopy.    newXTable _ Array new: xTable size.    newXTable at: 1 put: (x _ xTable at: 1).    1 to: xTable size-1 do:        [:i | x1 _ xTable at: i.  w _ (xTable at: i+1) - x1.        w > 1 ifTrue: [w _ w-1].  "Shrink every character wider than 1"        g copy: (x@0 extent: w@g height) from: x1@0 in: glyphs rule: Form over.        newXTable at: i+1 put: (x _ x + w)].    xTable _ newXTable.    glyphs _ g"(TextStyle default fontAt: 1) copy makeCondensedGlyphs    displayLine: 'The quick brown fox jumps over the lazy dog'    at: Sensor cursorPoint"! !!StrikeFont methodsFor: 'emphasis'!makeItalicGlyphs    "Make an italic set of glyphs with same widths by skewing left and right        (may require more intercharacter space)"    | g r bonkForm bc |    g _ glyphs deepCopy.    "BonkForm will have bits where slanted characters overlap their neighbors."    bonkForm _ Form extent: (self height//4+2) @ self height.    bc _ self descent//4 + 1.  "Bonker x-coord corresponding to char boundary."    bonkForm fill: (0 @ 0 corner: (bc+1) @ self ascent) fillColor: Color black.    4 to: self ascent-1 by: 4 do:        [:y |         "Slide ascenders right..."        g copy: (1@0 extent: g width @ (self ascent - y))            from: 0@0 in: g rule: Form over.        bonkForm copy: (1@0 extent: bonkForm width @ (self ascent - y))            from: 0@0 in: bonkForm rule: Form over].    bonkForm fill: (0 @ 0 corner: (bc+1) @ self ascent) fillColor: Color white.    bonkForm fill: (bc @ self ascent corner: bonkForm extent) fillColor: Color black.    self ascent to: self height-1 by: 4 do:        [:y |         "Slide descenders left..."        g copy: (0@y extent: g width @ g height)            from: 1@y in: g rule: Form over.        bonkForm copy: (0@0 extent: bonkForm width @ bonkForm height)            from: 1@0 in: bonkForm rule: Form over].    bonkForm fill: (bc @ self ascent corner: bonkForm extent) fillColor: Color white.    "Now use bonkForm to erase at every character boundary in glyphs."    bonkForm offset: (0-bc) @ 0.    self bonk: g with: bonkForm.    glyphs _ g! !!StrikeFont methodsFor: 'emphasis'!makeStruckOutGlyphs    "Make a struck-out set of glyphs with same widths"    | g |    g _ glyphs deepCopy.    g fillBlack: (0 @ (self ascent - (self ascent//3)) extent: g width @ 1).    glyphs _ g! !!StrikeFont methodsFor: 'emphasis'!makeUnderlinedGlyphs    "Make an underlined set of glyphs with same widths"    | g |    g _ glyphs deepCopy.    g fillBlack: (0 @ (self ascent+1) extent: g width @ 1).    glyphs _ g! !!StrikeFont methodsFor: 'emphasis'!reset    "Reset the cache of derivative emphasized fonts"    derivativeFonts _ Array new: 32! !!StrikeFont methodsFor: 'file in/out'!displayChar: ascii form: charForm    "Convenience utility used during conversion of BitFont files"    | m bigForm |    Display fillBlack: (0@0 extent: 20@14).    ascii printString displayAt: 0@2.    charForm width > 0 ifTrue:        [m _ 5.        bigForm _ charForm magnify: charForm boundingBox by: m@m.        Display border: ((bigForm boundingBox expandBy: m) translateBy: 50@2) width: m.        bigForm displayAt: 50@2.        Display fillBlack: ((50@2)+((m*charForm width)@0) extent: 1@(m*self height))].! !!StrikeFont methodsFor: 'file in/out'!newFromStrike: fileName    "Build an instance from the strike font file name. The '.strike' extension    is optional."    | strike startName raster16 |    name _ fileName copyUpTo: $..    "assumes extension (if any) is '.strike'".    strike _ FileStream oldFileNamed: name, '.strike.'.    strike binary.    strike readOnly.        "strip off direcory name if any"    startName _ name size.    [startName > 0 and: [((name at: startName) ~= $>) & ((name at: startName) ~= $])]]        whileTrue: [startName _ startName - 1].    name _ name copyFrom: startName+1 to: name size.    type            _        strike nextWord16.        "type is ignored now -- simplest                                                assumed.  Kept here to make                                                writing and consistency more                                                straightforward."    minAscii        _        strike nextWord16.    maxAscii        _        strike nextWord16.    maxWidth        _        strike nextWord16.    strikeLength    _        strike nextWord16.    ascent            _        strike nextWord16.    descent            _        strike nextWord16.    "xOffset            _"        strike nextWord16.         raster16            _        strike nextWord16.        superscript        _        ascent - descent // 3.        subscript        _        descent - ascent // 3.        emphasis        _        0.    glyphs            _    Form extent: (raster16 * 16) @ (self height)                              offset: 0@0.        glyphs bits fromByteStream: strike.    xTable _ (Array new: maxAscii + 3) atAllPut: 0.    (minAscii + 1 to: maxAscii + 3) do:        [:index | xTable at: index put: strike nextWord16].    "Set up space character"    ((xTable at: (Space asciiValue + 2))  = 0 or:            [(xTable at: (Space asciiValue + 2)) = (xTable at: (Space asciiValue + 1))])        ifTrue:    [(Space asciiValue + 2) to: xTable size do:                    [:index | xTable at: index put: ((xTable at: index) + DefaultSpace)]].    strike close.    self setStopConditions ! !!StrikeFont methodsFor: 'file in/out' stamp: 'tk 6/26/97 14:16'!objectToStoreOnDataStream    "I am about to be written on an object file.  Write a reference to a known Font in the other system instead.  "    "A path to me"    | known eval |    thisContext sender receiver class == ReferenceStream ifTrue: [^ self].        "special case for saving the default fonts on the disk.  See collectionFromFileNamed:"    known _ TextStyle default fontArray detect: [:x | x name sameAs: self name] ifNone: [nil].     known == self ifTrue: ["not modified"        eval _ 'TextStyle default fontNamed: ', self name printString.        ^ DiskProxy global: #Compiler selector: #evaluate:             args: (Array with: eval)            "We are expecting it to be there"].    ^ self    "Special font.  Write me out"! !!StrikeFont methodsFor: 'file in/out'!printOn: aStream    super printOn: aStream.    aStream nextPutAll: '(' , self name , ')'! !!StrikeFont methodsFor: 'file in/out'!readBFHeaderFrom: f    name _ self restOfLine: 'Font name = ' from: f.    ascent _ (self restOfLine: 'Ascent = ' from: f) asNumber.    descent _ (self restOfLine: 'Descent = ' from: f) asNumber.    maxWidth _ (self restOfLine: 'Maximum width = ' from: f) asNumber.    pointSize _ (self restOfLine: 'Font size = ' from: f) asNumber.    name _ (name copyWithout: Character space) ,                (pointSize < 10                    ifTrue: ['0' , pointSize printString]                    ifFalse: [pointSize printString]).    minAscii _ 258.    maxAscii _ 0.    superscript _ ascent - descent // 3.        subscript _ descent - ascent // 3.        emphasis _ 0.    type _ 0.  "ignored for now"! !!StrikeFont methodsFor: 'file in/out' stamp: 'di 9/15/97 21:51'!readFromBitFont: fileName    "This builds a StrikeFont instance by reading the data file format    produced by BitFont, a widely available font conversion utility    written by Peter DiCamillo at Brown University"    "StrikeFont new readFromBitFont: 'Palatino10.BF' "    | f lastAscii charLine width ascii charForm line missingForm tempGlyphs iRect p rectLine left tokens right |    f _ FileStream readOnlyFileNamed: fileName.    self readBFHeaderFrom: f.    "NOTE: if font has been scaled (and in any case),    the REAL bitmap dimensions come after the header."    self restOfLine: 'Extent information for entire font' from: f.    "Parse the following line (including mispelling!!)"    "Image rectange: left = -2, right = 8, bottom = -2, top = 7"    tokens _ (f upTo: Character cr)  findTokens: ' '.    iRect _ Rectangle left: (tokens at: 5) asNumber right: (tokens at: 8) asNumber                top: (tokens at: 14) asNumber bottom: (tokens at: 11) asNumber.    ascent _ iRect top.    descent _ iRect bottom negated.        tempGlyphs _ Form extent: (maxWidth*257) @ self height.    xTable _ (Array new: 258) atAllPut: 0.    xTable at: 1 put: 0.    "Read character forms and blt into tempGlyphs"    lastAscii _ -1.    [charLine _ self restOfLine: 'Character: ' from: f.    charLine == nil ifFalse:        [p _ f position.        rectLine _ f upTo: Character cr.        (rectLine beginsWith: 'Image rectange: left = ')            ifTrue: [tokens _ rectLine findTokens: ' '.                    left _ (tokens at: 5) asNumber. right _ (tokens at: 8) asNumber]            ifFalse: [left _ right _ 0. f position: p].        width_ (self restOfLine: 'Width (final pen position) = ' from: f) asNumber - left                    max: (right-left+1).        (charLine beginsWith: 'Missing character') ifTrue: [ascii _ 256].        ('x''*' match: charLine) ifTrue:            [ascii _ Number readFrom: (charLine copyFrom: 3 to: 4) asUppercase base: 16].        charForm _ Form extent: width@self height.        ('*[all blank]' match: charLine) ifFalse:            [self restOfLine: '  +' from: f.            1 to: self height do:                [:y | line _ f upTo: Character cr.                4 to: (width + 3 min: line size + iRect left - left) do:                    [:x | (line at: x - iRect left + left) = $*                        ifTrue: [charForm pixelValueAt: (x-4)@(y-1) put: 1]]]]].    charLine == nil]        whileFalse:            [self displayChar: ascii form: charForm.            ascii = 256                ifTrue: [missingForm _ charForm deepCopy]                ifFalse:                [minAscii _ minAscii min: ascii.                maxAscii _ maxAscii max: ascii.                lastAscii+1 to: ascii-1 do: [:a | xTable at: a+2 put: (xTable at: a+1)].                tempGlyphs copy: ((xTable at: ascii+1)@0                                        extent: charForm extent)                            from: 0@0 in: charForm rule: Form over.                xTable at: ascii+2 put: (xTable at: ascii+1) + width.                lastAscii _ ascii]].    f close.    lastAscii+1 to: maxAscii+1 do: [:a | xTable at: a+2 put: (xTable at: a+1)].    missingForm == nil ifFalse:        [tempGlyphs copy: missingForm boundingBox from: missingForm                to: (xTable at: maxAscii+2)@0 rule: Form over.        xTable at: maxAscii+3 put: (xTable at: maxAscii+2) + missingForm width].    glyphs _ Form extent: (xTable at: maxAscii+3) @ self height.    glyphs copy: glyphs boundingBox from: 0@0 in: tempGlyphs rule: Form over.    xTable _ xTable copyFrom: 1 to: maxAscii+3.    self setStopConditions! !!StrikeFont methodsFor: 'file in/out'!readFromStrike2: fileName  "StrikeFont new readFromStrike2: 'Palatino14.sf2'"    "Build an instance from the strike font stored in strike2 format.    fileName is of the form: <family name><pointSize>.sf2"    | file |    ('*.sf2' match: fileName) ifFalse: [self halt.  "likely incompatible"].    name _ fileName copyUpTo: $. .  "Drop filename extension"    file _ FileStream readOnlyFileNamed: fileName.    file binary.    self readFromStrike2Stream: file! !!StrikeFont methodsFor: 'file in/out'!readFromStrike2Stream: file     "Build an instance from the supplied binary stream on data in strike2 format"    type _ file nextInt32.  type = 2 ifFalse: [file close. self halt "not strike2 format"].    minAscii _ file nextInt32.    maxAscii _ file nextInt32.    maxWidth _ file nextInt32.    ascent _ file nextInt32.    descent _ file nextInt32.    pointSize _ file nextInt32.    superscript _ ascent - descent // 3.        subscript _ descent - ascent // 3.        emphasis _ file nextInt32.    xTable _ (Array new: maxAscii + 3) atAllPut: 0.    (minAscii + 1 to: maxAscii + 3) do:        [:index | xTable at: index put: file nextInt32].    glyphs _ Form new readFrom: file.    file close.    "Set up space character"    ((xTable at: (Space asciiValue + 2))  = 0 or:            [(xTable at: (Space asciiValue + 2)) = (xTable at: (Space asciiValue + 1))])        ifTrue:    [(Space asciiValue + 2) to: xTable size do:                    [:index | xTable at: index put: ((xTable at: index) + DefaultSpace)]].    self setStopConditions! !!StrikeFont methodsFor: 'file in/out'!restOfLine: leadString from: file    "Utility method to assist reading of BitFont data files"    | line |    [line _ file upTo: Character cr.    line size < leadString size or: [leadString ~= (line copyFrom: 1 to: leadString size)]]    whileTrue: [file atEnd ifTrue: [^ nil]].    ^ line copyFrom: leadString size+1 to: line size! !!StrikeFont methodsFor: 'file in/out'!setStopConditions    "This has to do with scanning characters, not with the font"    stopConditions _ Array new: 258.    stopConditions atAllPut: nil.    1 to: (minAscii - 1) do:        [:index | stopConditions at: index put: #characterNotInFont].    (maxAscii + 3) to: stopConditions size do:        [:index | stopConditions at: index put: #characterNotInFont].    self reset! !!StrikeFont methodsFor: 'file in/out'!writeAsStrike2named: fileName    "Write me onto a file in strike2 format.    fileName should be of the form: <family name><pointSize>.sf2"    | file |    file _ FileStream fileNamed: fileName.    file binary.    file nextInt32Put: 2.    file nextInt32Put: minAscii.    file nextInt32Put: maxAscii.    file nextInt32Put: maxWidth.    file nextInt32Put: ascent.    file nextInt32Put: descent.    file nextInt32Put: pointSize.    superscript _ ascent - descent // 3.        subscript _ descent - ascent // 3.        file nextInt32Put: emphasis.    (minAscii + 1 to: maxAscii + 3) do:        [:index | file nextInt32Put: (xTable at: index)].    glyphs writeOn: file.    file close.! !!StrikeFont methodsFor: 'character shapes'!alter: char formBlock: formBlock    self characterFormAt: char         put: (formBlock value: (self characterFormAt: char))! !!StrikeFont methodsFor: 'character shapes'!characterForm: char pixelValueAt: pt put: val    | f |    f _ self characterFormAt: char.    f pixelAt: pt put: val.    self characterFormAt: char put: val! !!StrikeFont methodsFor: 'character shapes'!characterFormAt: character     "Answer a Form copied out of the glyphs for the argument, character."    | ascii leftX rightX |    ascii _ character asciiValue.    leftX _ xTable at: ascii + 1.    rightX _ xTable at: ascii + 2.    ^ glyphs copy: (leftX @ 0 corner: rightX @ self height)! !!StrikeFont methodsFor: 'character shapes'!characterFormAt: character put: characterForm    "Copy characterForm over the glyph for the argument, character."    | ascii leftX rightX widthDif newGlyphs |    ascii _ character asciiValue.    leftX _ xTable at: ascii + 1.    rightX _ xTable at: ascii + 2.    widthDif _ characterForm width - (rightX - leftX).    widthDif ~= 0 ifTrue:        ["Make new glyphs with more or less space for this char"        newGlyphs _ Form extent: (glyphs width + widthDif) @ glyphs height.        newGlyphs copy: (0@0 corner: leftX@glyphs height)            from: 0@0 in: glyphs rule: Form over.        newGlyphs copy: ((rightX+widthDif)@0 corner: newGlyphs width@glyphs height)            from: rightX@0 in: glyphs rule: Form over.        glyphs _ newGlyphs.        "adjust further entries on xTable"        ascii+2 to: xTable size            do: [:i | xTable at: i put: (xTable at: i) + widthDif]].    glyphs copy: (leftX @ 0 corner: rightX @ self height)        from: 0@0 in: characterForm rule: Form over"| f |  f _ TextStyle default fontAt: 1.f characterFormAt: $  put: (Form extent: (f widthOf: $ )+10@f height)"! !!StrikeFont methodsFor: 'character shapes'!edit: character        "(TextStyle default fontAt: 1) edit: $_"    "Open a Bit Editor on the given character.  Note that you must do an accept    (in the option menu of the bit editor) if you want this work.    Accepted edits will not take effect in the font until you leave or close the bit editor.    Also note that unaccepted edits will be lost when you leave or close."    | charForm smallRect editRect scaleFactor bitEditor savedForm r |    charForm _ self characterFormAt: character.    editRect _ BitEditor locateMagnifiedView: charForm                                            scale: (scaleFactor _ 8@8).    bitEditor _ BitEditor bitEdit: charForm at: editRect topLeft            scale: scaleFactor remoteView: nil.    bitEditor controller blueButtonMenu: nil blueButtonMessages: nil.    savedForm _ Form fromDisplay: (r _ bitEditor displayBox expandBy: (0@23 corner: 0@0)).    bitEditor controller startUp.    bitEditor release.    savedForm displayOn: Display at: r topLeft.    self characterFormAt: character put: charForm! !!StrikeFont methodsFor: 'character shapes'!widen: char by: delta    | newForm |    ^ self alter: char formBlock:  "Make a new form, wider or narrower..."        [:charForm | newForm _ Form extent: charForm extent + (delta@0).        charForm displayOn: newForm.  "Copy this image into it"        newForm]    "and substitute it in the font"! !!StrikeFont class methodsFor: 'instance creation'!fromStrike: fileName     "Read a font from disk in the old ST-80 'strike' format.    Note: this is an old format; use strike2 format instead"    ^self new newFromStrike: fileName! !!StrikeFont class methodsFor: 'examples'!convertFontsNamed: familyName  " StrikeFont convertFontsNamed: 'NewYork' "    "This utility is for use after you have used BitFont to produce data files     for the fonts you wish to use.  It will read the BitFont files and then     write them out in strike2 (*.sf2) format which is much more compact,    and which can be read in again very quickly."    "For this utility to work as is, the BitFont data files must be named    'familyNN.BF', and must reside in the same directory as the image."    | f |    (FileDirectory default fileNamesMatching: familyName , '*.BF') do:        [:fname | Transcript cr; show: fname.        f _ StrikeFont new readFromBitFont: fname.        f writeAsStrike2named: f name , '.sf2']! !!StrikeFont class methodsFor: 'examples'!example    "Displays a line of text on the display screen at the location of the cursor.    Example depends on the strike font file, 'TimesRoman10.strike'. existing."    (StrikeFont new readFromStrike2: 'NewYork12.sf2')        displayLine: 'A line of 12-pt text in New York style' at: Sensor cursorPoint         "StrikeFont example."! !!StrikeFont class methodsFor: 'examples'!size: pointSize fromLiteral: aString    "This method allows a font set to be captured as sourcecode in a subclass.    The string literals will presumably be created by printing, eg,        (FileStream readOnlyFileNamed: 'Palatino24.sf2') contentsOfEntireFile,        and then pasting into a browser after a heading like, eg,size24    ^ self size: 24 fromLiteral:    '--unreadable binary data--'    See the method hackDefaultStyle to see how this can be used"    ^ (StrikeFont new readFromStrike2Stream:        (ExternalStream on: aString asByteArray from: 1 to: aString size))        name: self name , (pointSize < 10 ifTrue: ['0' , pointSize printString]                                        ifFalse: [pointSize printString])! !!StrikeFont class methodsFor: 'derivative font caching'!shutDown  "StrikeFont shutDown"    "Deallocate synthetically derived copies of base fonts to save space"    self allInstancesDo: [:sf | sf reset]! !!String methodsFor: 'accessing' stamp: 'tk 6/18/96'!atWrap: index     "Return this element of an indexable object, letting the index wrap around from the end to the beginning.  See Object at:.  Needed here when index is not an integer and has to be coerced.  "    <primitive: 63>    ^(super atWrap: index) asCharacter! !!String methodsFor: 'accessing' stamp: 'tk 6/19/97 10:05'!findTokens: delimiters keep: keepers    "Answer the collection of tokens that result from parsing self.  The tokens are seperated by delimiters, any of a string of characters.  If a delimiter is also in keepers, make a token for it.  (Very useful for carriage return.  A sole return ends a line, but is also saved as a token so you can see where the line breaks were.)"    | tokens keyStart keyStop |    tokens _ OrderedCollection new.    keyStop _ 1.    [keyStop <= self size] whileTrue:        [keyStart _ self skipDelimiters: delimiters startingAt: keyStop.        keyStop to: keyStart-1 do: [:ii |             (keepers includes: (self at: ii)) ifTrue: [                tokens add: (self copyFrom: ii to: ii)]].    "Make this keeper be a token"        keyStop _ self findDelimiters: delimiters startingAt: keyStart.        keyStart < keyStop            ifTrue: [tokens add: (self copyFrom: keyStart to: (keyStop - 1))]].    ^tokens! !!String methodsFor: 'accessing'!skipDelimiters: delimiters startingAt: start     "Answer the index of the character within the receiver, starting at start, that does NOT match one of the delimiters. If the receiver does not contain any of the delimiters, answer size + 1.  Assumes the delimiters to be a non-empty string."    start to: self size do: [:i |        delimiters detect: [:delim | delim = (self at: i)]                ifNone: [^ i]].    ^ self size + 1! !!String methodsFor: 'comparing'!beginsWith: prefix | prefixSize |    "Answer whether the receiver begins with the given prefix string."    prefixSize _ prefix size.    self size < prefixSize ifTrue: [^false].    1 to: prefixSize do:        [:index | (self at: index) = (prefix at: index) ifFalse: [^false]].    ^true! !!String methodsFor: 'converting'!asByteArray    "Convert to a ByteArray with the ascii values of the string.    Fast code uses primitive that avoids character conversion"    ^ (ByteArray new: self size) replaceFrom: 1 to: self size with: self! !!String methodsFor: 'converting'!capitalized    "Return a copy with the first letter capitalized"    | cap |    cap _ self copy.    cap at: 1 put: (cap at: 1) asUppercase.    ^ cap! !!String methodsFor: 'converting' stamp: 'sw 11/25/96'!surroundedBySingleQuotes    "Answer the receiver with leading and trailing quotes.  "    ^ $' asString, self, $' asString! !!String methodsFor: 'displaying' stamp: 'jm 6/12/97 10:46'!displayProgressAt: aPoint from: minVal to: maxVal during: workBlock     "Display this string as a caption over a progress bar while workBlock is evaluated.EXAMPLE (Select next 6 lines and Do It)'Now here''s some Real Progress'    displayProgressAt: Sensor cursorPoint    from: 0 to: 10    during: [:bar |    1 to: 10 do: [:x | bar value: x.            (Delay forMilliseconds: 500) wait]].HOW IT WORKS (Try this in any other language :-)Since your code (the last 2 lines in the above example) is in a block,this method gets control to display its heading before, and clean up the screen after, its execution.The key, though, is that the block is supplied with an argument,named 'bar' in the example, which will update the bar image every it is sent the message value: x, where x is in the from:to: range."    | delta savedArea captionText textFrame barFrame outerFrame result range |    barFrame _ aPoint - (75@10) corner: aPoint + (75@10).    captionText _ DisplayText text: self asText allBold.    captionText        foregroundColor: Color black        backgroundColor: Color white.    textFrame _ captionText boundingBox insetBy: -4.    textFrame _ textFrame align: textFrame bottomCenter                    with: barFrame topCenter + (0@2).    outerFrame _ barFrame merge: textFrame.    delta _ outerFrame amountToTranslateWithin: Display boundingBox.    barFrame _ barFrame translateBy: delta.    textFrame _ textFrame translateBy: delta.    outerFrame _ outerFrame translateBy: delta.    savedArea _ Form fromDisplay: outerFrame.    Display fillBlack: barFrame; fillWhite: (barFrame insetBy: 2).    Display fillBlack: textFrame; fillWhite: (textFrame insetBy: 2).    captionText displayOn: Display at: textFrame topLeft + (4@4).    range _ maxVal = minVal ifTrue: [1] ifFalse: [maxVal - minVal].  "Avoid div by 0"    result _ workBlock value:  "Supply the bar-update block for evaluation in the work block"        [:barVal | Display fillGray: (barFrame topLeft + (2@2) extent:                    (((barFrame width-4) * (barVal-minVal) / range) asInteger@16))].    savedArea displayOn: Display at: outerFrame topLeft.    ^ result! !!String methodsFor: 'private'!correctAgainstEnumerator: wordBlock continuedFrom: oldCollection    "The guts of correction, instead of a wordList, there is a block that should take abnother block and enumerate over some list with it."    | choices scoreMin results score |    scoreMin _ self size // 2 min: 3.    oldCollection isNil        ifTrue: [ choices _ SortedCollection sortBlock: [ :x :y | x value > y value ] ]        ifFalse: [ choices _ oldCollection ].    wordBlock isNil        ifTrue:            [ results _ OrderedCollection new.            1 to: (5 min: choices size) do: [ :i | results add: (choices at: i) key ] ]        ifFalse:            [ wordBlock value: [ :word |                (score _ self alike: word) >= scoreMin ifTrue:                    [ choices add: (Association key: word value: score).                        (choices size >= 5) ifTrue: [ scoreMin _ (choices at: 5) value] ] ].            results _ choices ].    ^ results! !!String methodsFor: 'Celeste'!includesSubstring: aString caseSensitive: caseSensitive    "Note: Although less general than the 'match:' method, this method was a factor of 10 faster on both successful and unsucessful finds of a short string in a 1116 byte mail message."        | first index i |    self isEmpty ifTrue: [^false].    caseSensitive ifTrue: [        first _ aString first.        1 to: self size - aString size + 1 do: [ :start |            (self at: start) = first ifTrue: [                i _ 1.                [(self at: start + i - 1) = (aString at: i)] whileTrue: [                    i = aString size ifTrue: [^true].                    i _ i + 1.                ].            ].        ].    ] ifFalse: [        first _ aString first asLowercase.        1 to: self size - aString size + 1 do: [ :start |            (self at: start) asLowercase = first ifTrue: [                i _ 1.                [(self at: start + i - 1) asLowercase =                 (aString at: i) asLowercase] whileTrue: [                    i = aString size ifTrue: [^ true].                    i _ i + 1.                ].            ].        ].    ].    ^ false! !!String methodsFor: 'Celeste'!withCRs    "Return a copy of the receiver in which backslash (\) characters have been replaced with carriage returns."    ^ self collect: [ :c | c = $\ ifTrue: [ Character cr ] ifFalse: [ c ]].! !!StringButtonMorph methodsFor: 'initialization'!initialize    super initialize.    self color: Color black.    target _ nil.    actionSelector _ #flash.    arguments _ EmptyArray.    actWhen _ #buttonUp.    self contents: 'Flash'.! !!StringButtonMorph methodsFor: 'menu'!addCustomMenuItems: aCustomMenu hand: aHandMorph    super addCustomMenuItems: aCustomMenu hand: aHandMorph.    aCustomMenu add: 'change label' action: #setLabel.    aCustomMenu add: 'change action selector' action: #setActionSelector.    aCustomMenu add: 'change arguments' action: #setArguments.    aCustomMenu add: 'change when to act' action: #setActWhen.    ((self world rootMorphsAt: aHandMorph targetOffset) size > 1) ifTrue: [        aCustomMenu add: 'set target' action: #setTarget:].! !!StringButtonMorph methodsFor: 'menu'!setActionSelector    | newSel |    newSel _ FillInTheBlank        request:'Please type the selector to be sent tothe target when this button is pressed'        initialAnswer: actionSelector.    newSel isEmpty ifFalse: [self actionSelector: newSel].! !!StringButtonMorph methodsFor: 'menu'!setActWhen    actWhen _ (SelectionMenu selections: #(buttonDown buttonUp whilePressed))        startUpWithCaption: 'Choose one of the following conditions'! !!StringButtonMorph methodsFor: 'menu'!setArguments    | s newArgs newArgsArray |    s _ WriteStream on: ''.    arguments do: [:arg | arg printOn: s. s nextPutAll: '. '].    newArgs _ FillInTheBlank        request:'Please type the arguments to be sent to the targetwhen this button is pressed separated by periods'        initialAnswer: s contents.    newArgs isEmpty ifFalse: [        newArgsArray _ Compiler evaluate: '{', newArgs, '}' for: self logged: false.        self arguments: newArgsArray].! !!StringButtonMorph methodsFor: 'menu'!setLabel    | newLabel |    newLabel _ FillInTheBlank        request:'Please type a new label for this button'        initialAnswer: self contents.    newLabel isEmpty ifFalse: [self contents: newLabel].! !!StringButtonMorph methodsFor: 'menu'!setTarget: evt    | rootMorphs |    rootMorphs _ self world rootMorphsAt: evt hand targetOffset.    rootMorphs size > 1        ifTrue: [target _ rootMorphs at: 2]        ifFalse: [target _ nil. ^ self].! !!StringButtonMorph methodsFor: 'accessing'!actionSelector    ^ actionSelector! !!StringButtonMorph methodsFor: 'accessing'!actionSelector: aSymbolOrString    (nil = aSymbolOrString or:     ['nil' = aSymbolOrString or:     [aSymbolOrString isEmpty]])        ifTrue: [^ actionSelector _ nil].    actionSelector _ aSymbolOrString asSymbol.! !!StringButtonMorph methodsFor: 'accessing'!actWhen: aSymbol    "Set the condition under which to invoke my action to one of: #buttonDown, #buttonUp, and #whilePressed."    actWhen _ aSymbol.! !!StringButtonMorph methodsFor: 'accessing'!arguments    ^ arguments! !!StringButtonMorph methodsFor: 'accessing'!arguments: aCollection    arguments _ aCollection asArray copy.! !!StringButtonMorph methodsFor: 'accessing'!target    ^ target! !!StringButtonMorph methodsFor: 'accessing'!target: anObject    target _ anObject! !!StringButtonMorph methodsFor: 'events'!doButtonAction    "Perform the action of this button. Subclasses may override this method. The default behavior is to send the button's actionSelector to its target object with its arguments."    (target ~~ nil and: [actionSelector ~~ nil]) ifTrue: [        Cursor normal showWhile: [            target perform: actionSelector withArguments: arguments]].! !!StringButtonMorph methodsFor: 'events'!handlesMouseDown: evt    ^ true! !!StringButtonMorph methodsFor: 'events'!mouseDown: evt    oldColor _ color.    actWhen == #buttonDown        ifTrue: [self doButtonAction].! !!StringButtonMorph methodsFor: 'events'!mouseMove: evt    (self containsPoint: evt cursorPoint)        ifTrue: [            self color: (oldColor mixed: 1/2 with: Color white).            actWhen == #whilePressed ifTrue: [self doButtonAction]]        ifFalse: [self color: oldColor].! !!StringButtonMorph methodsFor: 'events'!mouseUp: evt    self color: oldColor.    (actWhen == #buttonUp and: [self containsPoint: evt cursorPoint])        ifTrue: [self doButtonAction].! !!StringHolderController methodsFor: 'menu messages' stamp: 'sw 9/27/96'!objectsReferencingIt    "Open a list inspector on all objects that reference the object that results when the current selection is evaluated.  "    | result |    self controlTerminate.    result _ self evaluateSelection.    ((result isKindOf: FakeClassPool) or:     [result == #failedDoit]) ifFalse: [        Smalltalk            browseAllObjectReferencesTo: result            except: #()            ifNone: [:obj | view topView flash. self controlInitialize]].! !!StringHolderController class methodsFor: 'class initialization' stamp: 'sw 1/26/96'!initialize    "Initialize the yellow button pop-up menu and corresponding messages.     1/12/96 sw: added senders of it, etc.  1/15/96 sw: explain     1/22/96 sw: cmd keys detailed     1/24/96 sw: added find; moved many items to shifted side etc.     : made compatible with paragraph editor's version; I'm not clear on when/how this guy gets used (seemingly eg in a workspace) vs when the paragraph editor's does (seemingly in browsers)     : correct cmd-key equivalent for do again, and add set-search-string"    CodeYellowButtonMenu _         PopUpMenu             labels: 'find...(f)find again (g)set search string (h)do again (j)undo (z)copy (c)cut (x)paste (v)do it (d)print it (p)inspect it (i)accept (s)cancel (l)show bytecodesmore...'         lines: #(3 5 8 11 13 14).    CodeYellowButtonMessages _         #(find findAgain setSearchString again undo copySelection cut paste doIt printIt inspectIt accept cancel showBytecodes shiftedYellowButtonActivity)    "StringHolderController initialize"! !!StringHolderView methodsFor: 'updating' stamp: 'di 9/21/97 22:36'!promptForCancel    "Ask if it is OK to cancel changes to text"    | okToCancel stripes |    self topView isCollapsed ifTrue:        [(self confirm: 'Changes have not been saved.Is it OK to cancel those changes?') ifTrue: [model unlock].        ^ self].    stripes _ Form extent: 16@16 fromStipple: 16r36C9.    Display border: self insetDisplayBox width: 4            rule: Form reverse fillColor: stripes.    okToCancel _ self confirm: 'Changes have not been saved.Is it OK to cancel those changes?'.    Display border: self insetDisplayBox width: 4            rule: Form reverse fillColor: stripes.    okToCancel ifTrue:        [self updateDisplayContents.        model unlock]! !!StringMorph methodsFor: 'initialization'!initialize    super initialize.    color _ Color black.    font _ nil.    hasFocus _ false.    self contents: 'StringMorph'.! !!StringMorph methodsFor: 'initialization' stamp: '6/11/97 09:01 di'!initWithContents: aString font: aFont    super initialize.    color _ Color black.    font _ aFont.    hasFocus _ false.    self contents: aString.! !!StringMorph methodsFor: 'accessing'!contents    ^ contents! !!StringMorph methodsFor: 'accessing'!contents: aString    contents = aString ifTrue: [^ self].  "no substantive change"    contents _ aString.    self fitContents.! !!StringMorph methodsFor: 'accessing'!contentsClipped: aString    "Change my text, but do not change my size as a result"    contents = aString ifTrue: [^ self].  "No substantive change"    contents _ aString.    self changed! !!StringMorph methodsFor: 'accessing'!fitContents    | scanner |    scanner _ QuickPrint newOn: Display box: Display boundingBox font: font.    self extent: (scanner stringWidth: contents) @ (scanner lineHeight)! !!StringMorph methodsFor: 'accessing' stamp: '6/7/97 09:57 di'!font: aFont    font _ aFont.    self fitContents."in inspector say,     self font: ((TextStyle default fontAt: 2) emphasized: 1)"! !!StringMorph methodsFor: 'accessing'!setWidth: width    | f |    f _ font ifNil: [TextStyle default fontAt: 1].    self extent: width @ f height.! !!StringMorph methodsFor: 'drawing'!drawOn: aCanvas    hasFocus ifTrue: [aCanvas fillRectangle: self bounds color: Color yellow].    aCanvas text: contents bounds: bounds font: font color: color.! !!StringMorph methodsFor: 'editing'!acceptContents    "The message is sent when the user hits enter or Cmd-S. Accept the current contents and end editing. This default implementation does nothing."! !!StringMorph methodsFor: 'editing'!handlesMouseDown: evt    evt shiftPressed        ifTrue: [^ self uncoveredAt: evt cursorPoint]        ifFalse: [^ super handlesMouseDown: evt].! !!StringMorph methodsFor: 'editing'!keyboardFocusChange: aBoolean    hasFocus _ aBoolean.    self changed.! !!StringMorph methodsFor: 'editing'!keyStroke: evt    "Handle a keystroke event."    | ch |    ch _ evt keyCharacter.    ch = Character backspace ifTrue: [  "backspace"        contents size > 0 ifTrue: [            self contents: (contents copyFrom: 1 to: contents size - 1)].        ^ self].    (ch = $x and: [evt commandKeyPressed]) ifTrue: [  "cut"        Smalltalk clipboardText: contents.        ^ self contents: ''].    (ch = $c and: [evt commandKeyPressed]) ifTrue: [  "copy"        Smalltalk clipboardText: contents.        ^ self].    (ch = $v and: [evt commandKeyPressed]) ifTrue: [  "paste"        ^ self contents: Smalltalk clipboardText].    ((evt keyCharacter = Character enter) or:     [(evt keyCharacter = Character cr) or:     [evt keyCharacter = $s and: [evt commandKeyPressed]]]) ifTrue: [  "accept"        self acceptContents.        evt hand newKeyboardFocus: evt hand world.        ^ self].    self contents: (contents copyWith: ch).  "append the character"! !!StringMorph methodsFor: 'editing'!mouseDown: evt    "If the shift key is pressed, make this string the keyboard input focus."    evt shiftPressed        ifTrue: [evt hand newKeyboardFocus: self]        ifFalse: [super mouseDown: evt].! !!StringMorph methodsFor: 'printing'!fullPrintOn: aStream    aStream nextPutAll: '('.    super fullPrintOn: aStream.    aStream nextPutAll: ') contents: '; print: contents! !!StringMorph methodsFor: 'printing'!printOn: aStream    super printOn: aStream.    aStream nextPutAll: ' contents: '; print: contents! !!StringMorph class methodsFor: 'instance creation' stamp: '6/11/97 09:01 di'!contents: aString    " 'StringMorph contents: str' is faster than 'StringMorph new contents: str' "    ^ self basicNew initWithContents: aString font: nil! !!StringMorph class methodsFor: 'testing'!test    "Return a morph with lots of strings for testing display speed."    | c |    c _ LayoutMorph newColumn.    SystemOrganization categories do:        [:cat | c addMorph: (StringMorph new contents: cat)].    ^ c! !!StringMorph class methodsFor: 'testing'!test2    "Return a morph with lots of strings for testing display speed."    | c r |    c _ LayoutMorph newColumn.    SystemOrganization categories reverseDo:        [:cat | c addMorph: (StringMorph new contents: cat)].    r _ RectangleMorph new extent: c fullBounds extent.    c submorphsDo: [:m | r addMorph: m].    ^ r! !!SwitchController methodsFor: 'basic control sequence' stamp: 'di 7/13/97 11:16'!sendMessage    "The receiver consists of a selector and possibly of arguments that should     be used to create a message to send to the receiver's model."    arguments size = 0        ifTrue: [model perform: selector]        ifFalse: [model perform: selector withArguments: arguments]! !!SwitchView methodsFor: 'label access'!centerLabel    "Align the center of the label with the center of the receiver's window."    label == nil  ifFalse:         [(label isKindOf: Paragraph)            ifTrue: ["Compensate for leading in default style"                    label align: label boundingBox center + (0@1)                            with: self getWindow center]            ifFalse: [label align: label boundingBox center                             with: self getWindow center]]! !!SwitchView methodsFor: 'selector' stamp: 'di 7/13/97 11:17'!interrogateModel    "Answer the result of sending the receiver's model the message created     from the receiver's selector and arguments."    arguments size = 0        ifTrue: [^ model perform: selector]        ifFalse: [^ model perform: selector withArguments: arguments]! !!Symbol methodsFor: 'comparing' stamp: 'pm 9/23/97 09:36'!hashMappedBy: map    "Answer what my hash would be if oops changed according to map."    ^map newHashFor: self! !!Symbol methodsFor: 'menus'!dispatchAsMenuActionTo: receiver with: argument    ^self numArgs = 0        ifTrue: [receiver perform: self]        ifFalse: [receiver perform: self with: argument]! !!SyntaxError methodsFor: 'menu messages'!autoProceed    | someView |    someView _ self dependents first.    self proceed: someView topView controller! !!SyntaxError methodsFor: 'menu messages'!proceed: aController     "The error has presumably been fixed and the file in that created the     syntax error can now be continued."    debugger proceed: aController! !!SyntaxError methodsFor: 'contents'!contents: aString notifying: aController     "Compile the code in aString and notify aController of any errors.    If there are no errors, then automatically proceed."    (class compile: aString classified: category notifying: aController)         == nil ifTrue: [^ false].    self autoProceed! !!SyntaxError class methodsFor: 'instance creation'!errorInClass: aClass withCode: aString     "Answer a standard system view whose model is an instance of me. The syntax error occurred in typing to add code, aString, to class, aClass. "    self open: (self new setClass: aClass                        code: aString                        debugger: (Debugger context: thisContext))! !!SyntaxError class methodsFor: 'instance creation'!open: aSyntaxError    "Answer a standard system view whose model is an instance of me.  TK 15 May 96"    |  topView aListView aCodeView |    topView _ StandardSystemView new.    topView model: aSyntaxError.    topView label: 'Syntax Error'.    topView minimumSize: 380 @ 220.    aListView _ SyntaxErrorListView new.    aListView model: aSyntaxError.    aListView window: (0 @ 0 extent: 380 @ 20).    aListView        borderWidthLeft: 2        right: 2        top: 2        bottom: 0.    topView addSubView: aListView.    aCodeView _ BrowserCodeView new.    aCodeView model: aSyntaxError.    aCodeView window: (0 @ 0 extent: 380 @ 200).    aCodeView        borderWidthLeft: 2        right: 2        top: 2        bottom: 2.    topView        addSubView: aCodeView        align: aCodeView viewport topLeft        with: aListView viewport bottomLeft.    topView controller openNoTerminateDisplayAt: Display extent // 2.    Processor activeProcess suspend! !!SystemBuilder class methodsFor: 'system building' stamp: 'sw 1/18/96'!finalSystemBuildingSteps    "The final steps after all the file-ins, before we can call the system built.  "    Symbol rehash.     " Reclaim unused symbols"    self showInTranscript: '** System Built **'.    BuildingSystem _ false.! !!SystemBuilder class methodsFor: 'system building' stamp: 'sw 1/27/96'!initializeAfterSystemBuild    "Reinitialize needs to be called manually after filing in the kernel because other support classes need to have been filed in before it can run successfully.  This method copied over from old macPal stuff, , to serve as a template, but the real work needs to be done still."    Text initTextConstants.        "Rebuild snapshot lists"    self showInTranscript: '** SystemBuilder reinitialize  **'.    "self initMenus"! !!SystemCategoryListController methodsFor: 'menu messages'!browseAllClasses    "Create and schedule a browser on all classes alphabetically."    self controlTerminate.    model browseAllClasses.    self controlInitialize! !!SystemCategoryListController methodsFor: 'menu messages' stamp: 'sw 4/29/96'!findClass    "modified  so that if only 1 class matches the user-supplied string, or if the user-supplied string exactly matches a class name, then the pop-up menu is bypassed"    | pattern foundClass classNames index reply |    self controlTerminate.    model okToChange ifFalse: [^ self classNotFound].    pattern _ (reply _ FillInTheBlank request: 'Class Name?') asLowercase.    pattern isEmpty ifTrue: [^ self classNotFound].    (Smalltalk hasClassNamed: reply)        ifTrue:            [foundClass _ Smalltalk at: reply asSymbol]        ifFalse:             [classNames _ Smalltalk classNames asArray select:                 [:n | (n asLowercase indexOfSubCollection: pattern startingAt: 1) > 0].            classNames isEmpty ifTrue: [^ self classNotFound].            index _ classNames size == 1                ifTrue:    [1]                ifFalse:    [(PopUpMenu labelArray: classNames lines: #()) startUp].            index = 0 ifTrue: [^ self classNotFound].            foundClass _ Smalltalk at: (classNames at: index)].     model systemCategoryListIndex: (model systemCategoryList indexOf: foundClass category).    model classListIndex: (model classList indexOf: foundClass name).     self controlInitialize! !!SystemCategoryListController methodsFor: 'menu messages'!findRecentClass        "Put up a list of recently visited classes and allow the user to select one."        self controlTerminate.        model recent.        self controlInitialize! !!SystemCategoryListController methodsFor: 'menu messages' stamp: 'di 6/28/97 19:03'!printOut    "Make a file with the description of the classes in the selected category.    Defaults to the same file as fileOut, but could be changed in any given    implementation to have a prettier format."    self controlTerminate.    Cursor write showWhile:        [model printOutSystemCategories].    self controlInitialize! !!SystemCategoryListController class methodsFor: 'class initialization'!initialize    "SystemCategoryListController initialize"    SystemCategoryListYellowButtonMenu _         PopUpMenu             labels:'find class...recent classes...browse allbrowseprintOutfileOutreorganizeupdateadd item...rename...remove'             lines: #(2 4 6 8).    SystemCategoryListYellowButtonMessages _        #(findClass findRecentClass browseAllClasses browse        printOut fileOut        edit update        add rename remove )    "    SystemCategoryListController initialize.    SystemCategoryListController allInstancesDo:        [:x | x initializeYellowButtonMenu]    "! !!SystemDictionary methodsFor: 'browsing' stamp: 'sw 9/27/96'!browseAllObjectReferencesTo: anObject except: objectsToExclude ifNone: aBlock    "Bring up a list inspector on the objects that point to anObject. If there are none, then evaluate aBlock on anObject.  "    | aList shortName |    aList _ Smalltalk pointersTo: anObject except: objectsToExclude.    aList size > 0 ifFalse: [^ aBlock value: anObject].    shortName _ anObject name.    shortName size > 12 ifTrue: [        shortName _ (shortName truncateTo: 12), '...'.    ].    InspectorView        open: (InspectorView inspector: (OrderedCollectionInspector inspect: aList))        withLabel: 'Objects pointing to ', shortName.! !!SystemDictionary methodsFor: 'browsing'!browseChangedMessages    "Create and schedule a message browser on each method that has been     changed."    ChangedMessageSet openFor: SystemChanges! !!SystemDictionary methodsFor: 'browsing'!browseMethodsWithSourceString: aString    "Smalltalk browseMethodsWithSourceString: 'SourceString' "    "Launch a browser on all methods whose source code contains aString as a substring.  The search is case-sensitive. This takes a long time right now.  7/23/96 di     1/16/97 sw: set up the autoSelect: string"    ^ self browseMessageList: (self allMethodsWithSourceString: aString)        name: 'Methods containing ' , aString printString autoSelect: aString! !!SystemDictionary methodsFor: 'browsing' stamp: 'sw 1/6/97'!browseMethodsWithString: aString    "Launch a browser on all methods which contain string literals that have aString as a substring.  The search is case-sensitive. This takes a long time right now.      : get the auto-select string correct"    | aList |    aList _ self allMethodsWithString: aString.    aList size > 0 ifTrue:         [Cursor normal show.        self browseMessageList: aList  name: 'Methods with string ''', aString, '''' autoSelect: aString]! !!SystemDictionary methodsFor: 'retrieving' stamp: 'di 9/20/97 23:00'!allSentMessages    "Answer the set of selectors which are sent somewhere in the system."    | sent |    sent _ Set new.    Cursor execute showWhile:         [self allBehaviorsDo:             [:cl | cl selectorsDo:                 [:sel | "Include all sels, but not if sent by self"            (cl compiledMethodAt: sel) literals do:                 [:m |                 (m isMemberOf: Symbol) ifTrue:  "might be sent"                    [m == sel ifFalse: [sent add: m]].                (m isMemberOf: Array) ifTrue:  "might be performed"                    [m do: [:x | (x isMemberOf: Symbol) ifTrue:                        [x == sel ifFalse: [sent add: x]]]]]]].        "The following may be sent without being in any literal frame"        1 to: self specialSelectorSize do:             [:index |             sent add: (self specialSelectorAt: index)]].    ^ sent! !!SystemDictionary methodsFor: 'retrieving'!allUnSentMessages   "Smalltalk allUnSentMessages"    "Answer the set of selectors that are implemented by some object    in the system but not sent by any."    | sent unsent |    sent _ self allSentMessages.    unsent _ Set new.    self allImplementedMessages do:        [:sel | (sent includes: sel) ifFalse: [unsent add: sel]].    ^ unsent" | f cl lastClass |f _ FileStream newFileNamed: 'UnsentMessages.txt'.lastClass _ 'xx'.methods _ SortedCollection new.Smalltalk allUnSentMessages do:    [:sel | methods addAll: (Smalltalk allImplementorsOf: sel)].methods do:    [:m | cl _ m copyUpTo: $ .     cl = lastClass        ifTrue: [f nextPutAll: (m copyFrom: lastClass size+1 to: m size)]        ifFalse: [f cr; cr; nextPutAll: m.  lastClass _ cl]].f close."! !!SystemDictionary methodsFor: 'retrieving' stamp: 'sw 5/8/96'!allUnSentMessagesIn: selectorSet    "Answer the subset of selectorSet which are not sent anywhere in the system.    Factored out from#allUnSentMessages "    |  all |    all _ selectorSet copy.    Cursor execute showWhile:         [self allBehaviorsDo:             [:cl | cl selectorsDo:                 [:sel |                 (cl compiledMethodAt: sel) literals do:                     [:m |                    (m isMemberOf: Symbol)  "might be sent"                        ifTrue: [all remove: m ifAbsent: []].                    (m isMemberOf: Array)  "might be performed"                        ifTrue: [m do: [:x | all remove: x ifAbsent: []]].                    ]]].        "The following may be sent without being in any literal frame"        1 to: self specialSelectorSize do:             [:index |             all remove: (self specialSelectorAt: index) ifAbsent: []]].    ^ all! !!SystemDictionary methodsFor: 'retrieving'!pointersTo: anObject    "Find all occurrences in the system of pointers to the argument anObject."    "(Smalltalk pointersTo: Browser) inspect."    ^ self pointersTo: anObject except: #()! !!SystemDictionary methodsFor: 'retrieving'!pointersTo: anObject except: objectsToExclude    "Find all occurrences in the system of pointers to the argument anObject. Remove objects in the exclusion list from the results."    | results anObj |    Smalltalk garbageCollect.    "big collection shouldn't grow, so it's contents array is always the same"    results _ OrderedCollection new: 1000.    "allObjectsDo: is expanded inline to keep spurious     method and block contexts out of the results"    anObj _ self someObject.    [0 == anObj] whileFalse: [        (anObj pointsTo: anObject) ifTrue: [            "exclude the results collector and contexts in call chain"            ((anObj ~~ results collector) and:             [(anObj ~~ objectsToExclude) and:             [(anObj ~~ thisContext) and:             [(anObj ~~ thisContext sender) and:             [anObj ~~ thisContext sender sender]]]])                 ifTrue: [ results add: anObj ].        ].        anObj _ anObj nextObject.    ].    objectsToExclude do: [ :obj | results removeAllSuchThat: [ :el | el == obj]].    ^ results asArray! !!SystemDictionary methodsFor: 'retrieving'!pointersToItem: index of: anArray    "Find all occurrences in the system of pointers to the given element of the given array. This is useful for tracing up a pointer chain from an inspector on the results of a previous call of pointersTo:. To find out who points to the second element of the results, one would evaluate:    Smalltalk pointersToItem: 2 of: selfin the inspector."    ^ self pointersTo: (anArray at: index) except: (Array with: anArray)! !!SystemDictionary methodsFor: 'class names' stamp: 'sw 10/28/96'!renameClassNamed: oldName as: newName    "Invoked from fileouts:  if there is currently a class in the system named oldName, then rename it to newName.  If anything untoward happens, report it in the Transcript.  "    | oldClass |    (oldClass _ self at: oldName asSymbol ifAbsent: [nil]) == nil        ifTrue:            [Transcript cr; show: 'Class-rename for ', oldName, ' ignored because ', oldName, ' does not exist.'.            ^ self].    oldClass rename: newName! !!SystemDictionary methodsFor: 'shrinking' stamp: 'di 9/21/97 21:52'!abandonSources    "Smalltalk abandonSources"    "Replaces every method by a copy with the 4-byte source pointer     replaced by a string of all arg and temp names, followed by its length.    These names can then be used to inform the decompiler.  See stats below"     | oldCodeString argsAndTemps bTotal bCount oldMethods newMethods m |    (self confirm:  '-- CAUTION --If you have backed up your system andare prepared to face the consequences ofabandoning source code files, hit Yes.If you have any doubts, hit No,to back out with no harm done.')        ==  true ifFalse: [^ self inform: 'Okay - no harm done'].    Smalltalk forgetDoIts.    oldMethods _ OrderedCollection new: CompiledMethod instanceCount.    newMethods _ OrderedCollection new: CompiledMethod instanceCount.    bTotal _ 0.  bCount _ 0.    Smalltalk allBehaviorsDo: [: b | bTotal _ bTotal + 1].'Saving temp names for better decompilation...'    displayProgressAt: Sensor cursorPoint    from: 0 to: bTotal    during: [:bar |    Smalltalk allBehaviorsDo:    "for test:  (Array with: Arc with: Arc class) do: "        [:cl |  bar value: (bCount _ bCount + 1).        cl selectors do:            [:selector |            m _ cl compiledMethodAt: selector.            m fileIndex > 0 ifTrue:            [oldCodeString _ cl sourceCodeAt: selector.            argsAndTemps _ (cl compilerClass new                parse: oldCodeString in: cl notifying: nil)                tempNames.            oldMethods addLast: m.            newMethods addLast: (m copyWithTempNames: argsAndTemps)]]]].    oldMethods asArray elementsExchangeIdentityWith: newMethods asArray.    Smalltalk condenseChanges.    Smalltalk allBehaviorsDo: [: b | b zapOrganization]."In a system with 7780 methods, we got 83k of temp names, or around 100k with spaces between.  The order of letter frequency was eatrnoislcmdgpSub, with about 60k falling in the first 11.  This suggests that we could encode in 4 bits, with 0-11 beng most common chars, and 12-15 contributing 2 bits to the next nibble for 6 bits, enough to cover all alphaNumeric with upper and lower case.  If we get 3/4 in 4 bits and 1/4 in 8, then we get 5 bits per char, or about 38% savings (=38k in this case).Summary: about 13 bytes of temp names per method, or 8 with simple compression, plus 1 for the size.  This would be 5 bytes more than the current 4-byte trailer."! !!SystemDictionary methodsFor: 'shrinking' stamp: 'di 6/24/97 11:42'!lastRemoval  "Smalltalk lastRemoval"    #(abandonSources printSpaceAnalysis cleanOutUndeclared browseObsoleteReferences obsoleteClasses lastRemoval) do:        [:sel | SystemDictionary removeSelector: sel].    [self removeAllUnSentMessages > 0] whileTrue! !!SystemDictionary methodsFor: 'shrinking' stamp: 'di 9/21/97 00:37'!majorShrink    "Smalltalk majorShrink; abandonSources; lastRemoval"    "This method throws out lots of the system that is not needed for, eg, operation in a hand-held PC.  The shrink process is being improved and, in conjunction with removeAllUnSentMessages, yields an image around 600k in size."    "Remove references to a few classes to be deleted, so that they won't leave obsolete versions around."    FormView compile: 'defaultControllerClass     ^  NoController' classified: 'controller access'.    FileModel removeSelector: #fileIntoNewChangeSet.    Form removeSelector: #edit.    ChangeSet class compile: 'defaultName        ^ ''Changes'' ' classified: 'initialization'.    ScreenController removeSelector: #openChangeManager.    ScreenController removeSelector: #exitProject.    ScreenController removeSelector: #openProject.    ScreenController removeSelector: #viewGIFImports.    "Now delete lots of classes.."    (Smalltalk includesKey: #CCodeGenerator) ifTrue:        [(Smalltalk at: #CCodeGenerator) removeCompilerMethods].    SystemOrganization removeSystemCategory: 'Squeak Interpreter'.    SystemOrganization removeSystemCategory: 'Translation to C'.    (SystemOrganization categories select: [:c | 'Morphic*' match: c]) reverseDo:        [:c | SystemOrganization removeSystemCategory: c].    SystemOrganization removeSystemCategory: 'System-Network'.    SystemOrganization removeSystemCategory: 'System-Monitoring'.    SystemOrganization removeSystemCategory: 'Graphics-Symbols'.    SystemOrganization removeSystemCategory: 'Graphics-Files'.    SystemOrganization removeSystemCategory: 'Interface-Pluggable'.    SystemOrganization removeSystemCategory: 'Interface-Projects'.    SystemOrganization removeSystemCategory: 'Object Storage'.    SystemOrganization removeSystemCategory: 'System-Sound'.    FormEditor removeFromSystem.    FormEditorView removeFromSystem.    FormMenuView removeFromSystem.    FormMenuController removeFromSystem.    FormButtonCache removeFromSystem.    CurveFitter removeFromSystem.    LinearFit removeFromSystem.    Spline removeFromSystem.    Circle removeFromSystem.    Arc removeFromSystem.    FormSetFont removeFromSystem.    FontSet removeFromSystem.    InstructionPrinter removeFromSystem.    SharedQueue removeFromSystem.    TextLinkToImplementors removeFromSystem.    ParagraphEditor removeSelector: #recognizeCharacters.    ParagraphEditor removeSelector: #recognizer:.    ParagraphEditor removeSelector: #recognizeCharactersWhileMouseIn:.    CharRecog removeFromSystem.    Array2D removeFromSystem.    FFT removeFromSystem.    ChangeSorter removeFromSystem.    DualChangeSorter removeFromSystem.    CngsClassList removeFromSystem.    CngsMsgList removeFromSystem.    TriggerController removeFromSystem.    MessageTally removeFromSystem.    BitEditor removeFromSystem.    StringHolder class removeSelector: #originalWorkspaceContents.    CompiledMethod removeSelector: #symbolic.    StringHolder systemWorkspaceContents: ''.    TextConstants removeKey: #ClairVaux.  "Gets rid of a couple of fonts"    FormHolderView removeFromSystem.    FormInspectView removeFromSystem.    GeneralListView removeFromSystem.    GeneralListController removeFromSystem.    HierarchicalMenu removeFromSystem.    EmphasizedMenu removeFromSystem.    ObjectViewer removeFromSystem.    ObjectTracer removeFromSystem.    SystemBuilder removeFromSystem.    HtmlFileStream removeFromSystem.    ConciseInspector removeFromSystem.    TextStyle allInstancesDo:        [:ts | (ts instVarAt: 1) size > 2 ifTrue:  "Only need two fonts"            [ts instVarAt: 1 put: ((ts instVarAt: 1) copyFrom: 1 to: 2)]].    ListParagraph initialize.    PopUpMenu initialize.    StandardSystemView initialize.    Smalltalk noChanges.    ChangeSorter classPool at: #AllChangeSets put: (OrderedCollection with: Smalltalk changes).    [self removeAllUnSentMessages > 0] whileTrue.    Smalltalk allClassesDo: [:c | c zapOrganization].    Symbol rehash.! !!SystemDictionary methodsFor: 'shrinking' stamp: 'jm 9/21/97 18:09'!minorShrink    "This method throws out lots of the system that is not needed, although not quite as much as majorShrink. In particular, it retains Morphic, Sound, graphics file readers, and the networking classes."    "Smalltalk minorShrink"    (Smalltalk includesKey: #CCodeGenerator) ifTrue:        [(Smalltalk at: #CCodeGenerator) removeCompilerMethods].    SystemOrganization removeSystemCategory: 'Squeak Interpreter'.    SystemOrganization removeSystemCategory: 'Translation to C'.    SystemOrganization removeSystemCategory: 'Graphics-Symbols'.    SystemOrganization removeSystemCategory: 'Interface-Pluggable'.    Form removeSelector: #edit.    Form removeSelector: #bitEdit.    Form removeSelector: #bitEditAt:scale:.    StrikeFont removeSelector: #edit:.    Dictionary removeSelector: #inspectFormsWithLabel:.    InspectorView class removeSelector: #buildFormView:.    InspectorView class removeSelector: #formDictionaryInspector:.    Object removeSelector: #evaluate:wheneverChangeIn:.    SystemDictionary removeSelector: #viewGIFImports.    ScreenController removeSelector: #viewGIFImports.    FormEditor removeSelector: #curve.    CurveFitter removeFromSystem.    LinearFit removeFromSystem.    Spline removeFromSystem.    FormView compile: 'defaultControllerClass     ^  NoController' classified: 'controller access'.    Form removeSelector: #edit.    FormEditor removeFromSystem.    FormEditorView removeFromSystem.    FormMenuView removeFromSystem.    FormMenuController removeFromSystem.    FormButtonCache removeFromSystem.    BitEditor removeFromSystem.    FormHolderView removeFromSystem.    FormInspectView removeFromSystem.    ParagraphEditor removeSelector: #recognizeCharacters.    ParagraphEditor removeSelector: #recognizer:.    ParagraphEditor removeSelector: #recognizeCharactersWhileMouseIn:.    CharRecog removeFromSystem.    Array2D removeFromSystem.    FFT removeFromSystem.    TextConstants removeKey: #ClairVaux.  "Gets rid of a couple of fonts"    HierarchicalMenu removeFromSystem.    EmphasizedMenu removeFromSystem.    ObjectViewer removeFromSystem.    ObjectTracer removeFromSystem.    SystemBuilder removeFromSystem.    StandardFileStream removeSelector: #asHtml.    HtmlFileStream removeFromSystem.    ConciseInspector removeFromSystem.    Smalltalk noChanges.    ChangeSorter classPool at: #AllChangeSets put: (OrderedCollection with: Smalltalk changes).    Symbol rehash.! !!SystemDictionary methodsFor: 'shrinking'!printSpaceAnalysis    "Smalltalk garbageCollect; printSpaceAnalysis"    "Note: this all needs to be updated for 32-bit direct pointers"    | f name space scale count instSpace |    f _ FileStream newFileNamed: 'STspace.text'.    f timeStamp.    f nextPutAll: 'class'; tab;            nextPutAll: 'space'; tab;            nextPutAll: '#insts'; tab;            nextPutAll: 'inst space'; tab.    self allClassesDo:        [:cl | name _ cl name forceTo: 30 paddingWith: Character space.        space _ cl space.        count _ cl instanceCount.        instSpace _ (cl instSize+4)*count.        cl isVariable ifTrue:                [scale _ cl isBytes ifTrue: [4] ifFalse: [1].                cl allInstancesDo: [:x | instSpace _ instSpace + (x size//scale)]].        f nextPutAll: name; tab;            print: space; tab;            print: count; tab;            print: instSpace; cr].    f close! !!SystemDictionary methodsFor: 'shrinking' stamp: 'di 10/3/97 11:13'!removeAllUnSentMessages   "Smalltalk removeAllUnSentMessages"     "Remove all implementations of unsent messages."    | sels n |    sels _ self allUnSentMessages.    "The following should be preserved for doIts, etc"    #(dragon: hilberts: mandala: web test3 factorial benchmark benchFib        newDepth: restoreAfter: forgetDoIts        removeAllUnSentMessages abandonSources removeUnreferencedKeys        reclaimDependents zapOrganization condenseChanges browseObsoleteReferences        methodsFor:stamp: methodsFor:stamp:prior: instanceVariableNames:        startTimerInterruptWatcher) do:        [:sel | sels remove: sel ifAbsent: []].    "The following may be sent by perform: in dispatchOnChar..."    (ParagraphEditor classPool at: #CmdActions) asSet do:        [:sel | sels remove: sel ifAbsent: []].    (ParagraphEditor classPool at: #ShiftCmdActions) asSet do:        [:sel | sels remove: sel ifAbsent: []].    sels size = 0 ifTrue: [^ 0].    n _ 0. Smalltalk allBehaviorsDo: [:x | n _ n+1].    'Removing ', sels size printString , ' messages . . .'        displayProgressAt: Sensor cursorPoint        from: 0 to: n        during:        [:bar |        n _ 0.        self allBehaviorsDo:            [:class | bar value: (n _ n+1).            sels do:                [:sel | class removeSelectorSimply: sel]]].    MethodDictionary allInstancesDo: [:d | d rehash].    ^ sels size! !!SystemDictionary methodsFor: 'memory space'!lowSpaceThreshold    "Return the low space threshold. When the amount of free memory (after garbage collection) falls below this limit, the system is in serious danger of completely exhausting memory and crashing. This limit should be made high enough to allow the user open a debugger to diagnose a problem or to save the image."    ^ 80000! !!SystemDictionary methodsFor: 'memory space'!lowSpaceWatcher    "Wait until the low space semaphore is signalled, then take appropriate actions."    self garbageCollectMost <= self lowSpaceThreshold ifTrue: [        self garbageCollect <= self lowSpaceThreshold ifTrue: [            "free space must be above threshold before starting low space watcher"            ^ self beep]].    LowSpaceSemaphore _ Semaphore new.    self primLowSpaceSemaphore: LowSpaceSemaphore.    self primSignalAtBytesLeft: self lowSpaceThreshold.  "enable low space interrupts"    LowSpaceSemaphore wait.  "wait for a low space condition..."    self primSignalAtBytesLeft: 0.  "disable low space interrupts"    self primLowSpaceSemaphore: nil.    LowSpaceProcess _ nil.    "Note: user now unprotected until the low space watcher is re-installed"    ScheduledControllers interruptName: 'Space is low'.! !!SystemDictionary methodsFor: 'memory space'!okayToProceedEvenIfSpaceIsLow    "Return true if either there is enough memory to do so safely or if the user gives permission after being given fair warning."    self garbageCollectMost > self lowSpaceThreshold ifTrue: [^ true].  "quick"    self garbageCollect > self lowSpaceThreshold ifTrue: [^ true].  "work harder"    ^ self confirm:'WARNING: There is not enough space to start the low space watcher.If you proceed, you will not be warned again, and the system mayrun out of memory and crash. If you do proceed, you can start thelow space notifier when more space becomes available simply byopening and then closing a debugger (e.g., by hitting Cmd-period.)Do you want to proceed?'! !!SystemDictionary methodsFor: 'memory space'!signalLowSpace    "Signal the low-space semaphore to alert the user that space is running low."    LowSpaceSemaphore signal.! !!SystemDictionary methodsFor: 'memory space'!useUpMemory    "For testing the low space handler..."    "Smalltalk installLowSpaceWatcher; useUpMemory"    | lst |    lst _ nil.    [true] whileTrue: [        lst _ Link new nextLink: lst; yourself.    ].! !!SystemDictionary methodsFor: 'special objects' stamp: 'jm 9/11/97 11:36'!clearExternalObjects    "Clear the array of objects that have been registered for use in non-Smalltalk code."    "Smalltalk clearExternalObjects"    Smalltalk specialObjectsArray at: 39 put: Array new.! !!SystemDictionary methodsFor: 'special objects' stamp: 'jm 9/15/97 16:09'!externalObjects    "Return an array of objects that have been registered for use in non-Smalltalk code. Smalltalk objects should be referrenced by external code only via indirection through this array, thus allowing the objects to move during compaction. This array can be cleared when the VM re-starts, since variables in external code do not survive snapshots. Note that external code should not attempt to access a Smalltalk object, even via this mechanism, while garbage collection is in progress."    "Smalltalk externalObjects"    ^ Smalltalk specialObjectsArray at: 39! !!SystemDictionary methodsFor: 'special objects' stamp: 'jm 8/22/97 13:05'!recreateSpecialObjectsArray    "Smalltalk recreateSpecialObjectsArray"    "The Special Objects Array is an array of object pointers used by the    Smalltalk virtual machine.  Its contents are critical and unchecked,    so don't even think of playing here unless you know what you are doing."    | newArray smallFrameSize largeFrameSize |    newArray _ Array new: 39.    "Nil false and true get used throughout the interpreter"    newArray at: 1 put: nil.    newArray at: 2 put: false.    newArray at: 3 put: true.    "This association holds the active process (a ProcessScheduler)"    newArray at: 4 put: (Smalltalk associationAt: #Processor).    "Numerous classes below used for type checking and instantiation"    newArray at: 5 put: Bitmap.    newArray at: 6 put: SmallInteger.    newArray at: 7 put: String.    newArray at: 8 put: Array.    newArray at: 9 put: Smalltalk.     newArray at: 10 put: Float.    newArray at: 11 put: MethodContext.    newArray at: 12 put: BlockContext.    newArray at: 13 put: Point.    newArray at: 14 put: LargePositiveInteger.    newArray at: 15 put: Display.    newArray at: 16 put: Message.    newArray at: 17 put: CompiledMethod.    newArray at: 18 put: (self specialObjectsArray at: 18)  "(low space Semaphore)".    newArray at: 19 put: Semaphore.    newArray at: 20 put: Character.    newArray at: 21 put: #doesNotUnderstand:.    newArray at: 22 put: #cannotReturn:.    newArray at: 23 put: nil.  "*unused*"    "An array of the 32 selectors that are compiled as special bytecodes,    paired alternately with the number of arguments each takes."    newArray at: 24 put: #(+ 1 - 1 < 1 > 1 <= 1 >= 1 = 1 ~= 1 * 1 / 1 \\ 1 @ 1 bitShift: 1 // 1 bitAnd: 1 bitOr: 1 at: 1 at:put: 2 size 0 next 0 nextPut: 1 atEnd 0 == 1 class 0 blockCopy: 1 value 0 value: 1 do: 1 new 0 new: 1 x 0 y 0 ).    "An array of the 255 Characters in ascii order."    newArray at: 25 put: ((0 to: 255) collect: [:ascii | Character value: ascii]).    newArray at: 26 put: #mustBeBoolean.    newArray at: 27 put: ByteArray.    newArray at: 28 put: Process.    "An array of up to 31 classes whose instances will have compact headers"    newArray at: 29 put: self compactClassesArray.    newArray at: 30 put: (self specialObjectsArray at: 30)   "(delay Semaphore)".    newArray at: 31 put: (self specialObjectsArray at: 31)   "(user input Semaphore)".    "Prototype instances that can be copied for fast initialization"    newArray at: 32 put: (Float new: 2).    newArray at: 33 put: (LargePositiveInteger new: 4).    newArray at: 34 put: Point new.    smallFrameSize _ (CompiledMethod newBytes: 0 nArgs: 0 nTemps: 0                        nStack: 0 nLits: 0 primitive: 0) frameSize.    largeFrameSize _ (CompiledMethod newBytes: 0 nArgs: 0 nTemps: 0                        nStack: smallFrameSize+1 nLits: 0 primitive: 0) frameSize.    newArray at: 35 put: (MethodContext new: smallFrameSize).    newArray at: 36 put: (MethodContext new: largeFrameSize).    newArray at: 37 put: (BlockContext new: smallFrameSize).    newArray at: 38 put: (BlockContext new: largeFrameSize).    newArray at: 39 put: Array new.  "array of objects referred to by external code"    "Now replace the interpreter's reference in one atomic operation"    self specialObjectsArray become: newArray! !!SystemDictionary methodsFor: 'special objects' stamp: 'jm 8/22/97 12:09'!registerExternalObject: anObject    "Register the given object in the external objects array and return its index. If it is already there, just return its index."    | objects firstEmptyIndex obj sz newObjects |    objects _ self specialObjectsArray at: 39.    "find the first empty slot"    firstEmptyIndex _ 0.    1 to: objects size do: [:i |        obj _ objects at: i.        obj == anObject ifTrue: [^ i].  "object already there, just return its index"        (obj == nil and: [firstEmptyIndex = 0]) ifTrue: [firstEmptyIndex _ i]].    "if no empty slots, expand the array"    firstEmptyIndex = 0 ifTrue: [        sz _ objects size.        newObjects _ objects species new: sz + 20.  "grow linearly"        newObjects replaceFrom: 1 to: sz with: objects startingAt: 1.        firstEmptyIndex _ sz + 1.        Smalltalk specialObjectsArray at: 39 put: newObjects.        objects _ newObjects].    objects at: firstEmptyIndex put: anObject.    ^ firstEmptyIndex! !!SystemDictionary methodsFor: 'special objects'!specialNargsAt: anInteger     "Answer the number of arguments for the special selector at: anInteger."    ^ (self specialObjectsArray at: 24) at: anInteger * 2! !!SystemDictionary methodsFor: 'special objects'!specialSelectorAt: anInteger     "Answer the special message selector from the interleaved specialSelectors array."    ^ (self specialObjectsArray at: 24) at: anInteger * 2 - 1! !!SystemDictionary methodsFor: 'special objects'!specialSelectorSize    "Answer the number of special selectors in the system."    ^ (self specialObjectsArray at: 24) size // 2! !!SystemDictionary methodsFor: 'special objects' stamp: 'jm 8/24/97 01:16'!unregisterExternalObject: anObject    "Unregister the given object in the external objects array. Do nothing if it isn't registered."    | objects |    anObject ifNil: [^ self].    objects _ self specialObjectsArray at: 39.    1 to: objects size do: [:i |        (objects at: i) == anObject ifTrue: [objects at: i put: nil]].! !!SystemDictionary methodsFor: 'image, changes name'!changesName  "Smalltalk changesName"    "Answer the current name for the changes file that matches the image file name"    | imName |    FileDirectory splitName: self imageName        to: [:volName :fileName | imName _ fileName].    #(('.image' '.changes') ('.image.IMA' '.changes.CHA') ('.IMA' '.CHA')) do:        [:ends | (imName endsWith: ends first) ifTrue:                [^ (imName copyFrom: 1 to: imName size - ends first size) , ends last]].    ^imName, '.changes'! !!SystemDictionary methodsFor: 'image, changes name'!sourcesName    "Answer the sources file name used in this Smalltalk release."    ^ self vmPath, 'SqueakV1.sources'! !!SystemDictionary methodsFor: 'sources, change log'!logChange: aStringOrText    "Write the argument, aString, onto the changes file."    | aString |    (SourceFiles isNil or: [(SourceFiles at: 2) == nil]) ifTrue: [^self].    aStringOrText isText        ifTrue: [aString _ aStringOrText string]        ifFalse: [aString _ aStringOrText].    (aString isMemberOf: String)        ifFalse: [self error: 'cant log this change'].    (aString findFirst: [:char | char isSeparator not]) = 0        ifTrue: [^self].  "null doits confuse replay"    (SourceFiles at: 2) setToEnd;            cr; cr; nextChunkPut: aString.    self forceChangesToDisk.! !!SystemDictionary methodsFor: 'sources, change log' stamp: 'di 10/4/97 10:58'!version    "Answer the version of this release."    ^ 'Squeak 1.23 of October 4, 1997'! !!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'jm 9/11/97 11:35'!processShutDownList    "Call the shutDown method on each object that needs to gracefully shut itself down before a snapshot."    Delay shutDown.    Smalltalk shutDownSound.    Smalltalk shutDown.    Color shutDown.    ControlManager shutDown.    StrikeFont shutDown.    DisplayScreen shutDown.! !!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'jm 9/11/97 10:49'!processStartUpList    "Call the startUp method on each object that needs to gracefully restart itself after a snapshot."    DisplayScreen startUp.    Cursor startUp.    Smalltalk installLowSpaceWatcher.    InputSensor startUp.    ProcessorScheduler startUp.    Delay startUp.    Smalltalk startUp.    ControlManager startUp.! !!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'jm 9/18/97 21:16'!readDocumentFile    "Read a document file, if one was provided."    | fileName object |    fileName _ Smalltalk getSystemAttribute: 1.    ((fileName == nil) or: [fileName size = 0]) ifTrue: [^ self].    (fileName endsWith: '.html') ifTrue: [        HTTPSocket httpFileIn: fileName.        ^ self].    object _ (FileStream oldFileNamed: fileName) fileInObjectAndCode.    "If launching a .sqo document, send open to the final object"    (fileName endsWith: '.sqo') ifTrue: [object open].! !!SystemDictionary methodsFor: 'snapshot and quit'!shutDownSound    (self at: #SoundPlayer ifAbsent: [^ self]) shutDown! !!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'jm 9/11/97 11:42'!snapshot: save andQuit: quit    "Mark the changes file and close all files. If save is true, save the current state of this Smalltalk in the image file. If quit is true, then exit to the outer shell. The latter part of this method runs when resuming a previously saved image. The resume logic checks for a document file to process when starting up."    | resuming msg sourceLink |    save & (SourceFiles at: 2) notNil ifTrue:        [msg _  (quit            ifTrue: ['----QUIT----']            ifFalse: ['----SNAPSHOT----'])            , Date dateAndTimeNow printString.        sourceLink _ ' priorSource: ' , LastQuitLogPosition printString.        LastQuitLogPosition _ (SourceFiles at: 2) setToEnd; position.        self logChange: msg , sourceLink.        Transcript cr; show: msg].    self processShutDownList.    Cursor write show.    save        ifTrue: [resuming _ self snapshotPrimitive]  "<-- PC frozen here on image file"        ifFalse: [resuming _ false].    quit & resuming not ifTrue: [self quitPrimitive].    Cursor normal show.    self processStartUpList.    resuming ifTrue: [        self clearExternalObjects.        self readDocumentFile].! !!SystemDictionary methodsFor: 'snapshot and quit'!startUp    "Open the files for sources and changes."    self openSourceFiles.! !!SystemDictionary methodsFor: 'housekeeping'!cleanOutUndeclared     Undeclared removeUnreferencedKeys! !!SystemDictionary methodsFor: 'housekeeping' stamp: 'di 9/21/97 21:55'!condenseChanges        "Smalltalk condenseChanges"    "Move all the changes onto a compacted sources file."    | f oldChanges classCount |    f _ FileStream fileNamed: 'ST80.temp'.    f header; timeStamp.'Condensing Changes File...'    displayProgressAt: Sensor cursorPoint    from: 0 to: Smalltalk classNames size    during:        [:bar | classCount _ 0.        Smalltalk allClassesDo:            [:class | bar value: (classCount _ classCount + 1).            class moveChangesTo: f.            class class moveChangesTo: f]].    LastQuitLogPosition _ f position.    f trailer; close.    oldChanges _ SourceFiles at: 2.    oldChanges close.    FileDirectory default deleteFileNamed: oldChanges name , '.old'.    FileDirectory default rename: oldChanges name                        toBe: oldChanges name , '.old'.    FileDirectory default rename: f name                        toBe: oldChanges name.    SourceFiles at: 2            put: (StandardFileStream oldFileNamed: oldChanges name).! !!SystemDictionary methodsFor: 'housekeeping'!condenseSources        "Smalltalk condenseSources"    "Move all the changes onto a compacted sources file."    | f name oldChanges classCount dir |    dir _ FileDirectory default.    "Write all sources with fileIndex 1"    f _ FileStream newFileNamed: self sourcesName , '.temp'.    f header; timeStamp.'Condensing Sources File...'    displayProgressAt: Sensor cursorPoint    from: 0 to: Smalltalk classNames size    during:        [:bar | classCount _ 0.        Smalltalk allClassesDo:            [:class | bar value: (classCount _ classCount + 1).            class fileOutOn: f moveSource: true toFile: 1]].    f trailer; close.    "Make a new empty changes file"    self closeSourceFiles.    dir rename: self changesName        toBe: self changesName , '.old'.    (FileStream newFileNamed: self changesName)        header; timeStamp; close.    LastQuitLogPosition _ 0.    dir rename: self sourcesName        toBe: self sourcesName , '.old'.    dir rename: self sourcesName , '.temp'        toBe: self sourcesName.    self openSourceFiles.    SelectionMenu notify: 'Source files have been rewritten!!Check that all is well,and then save/quit.'! !!SystemDictionary methodsFor: 'housekeeping' stamp: 'di 9/21/97 00:37'!forgetDoIts    "Smalltalk forgetDoIts"    Smalltalk allBehaviorsDo: "get rid of old DoIt methods"        [:cl | cl removeSelectorSimply: #DoIt; removeSelectorSimply: #DoItIn:]! !!SystemDictionary methodsFor: 'housekeeping'!makeInternalRelease        "Smalltalk makeInternalRelease"    (self confirm: self version , 'Is this the correct version designation?If not, choose no, and fix it.') ifFalse: [^ self].    (Object classPool at: #DependentsFields) size > 1 ifTrue: [self halt].    Browser initialize.    Undeclared isEmpty ifFalse: [self halt].    Smalltalk garbageCollect.    self obsoleteClasses isEmpty ifFalse: [self halt].    Symbol rehash.    self halt: 'Ready to condense changes'.    Smalltalk condenseChanges! !!SystemDictionary methodsFor: 'housekeeping' stamp: 'di 6/20/97 10:51'!reclaimDependents        "Smalltalk reclaimDependents"    "Reclaim unused entries in DependentsFields (DF)..."    "NOTE:  if <object>addDependent: is ever used to add something        other than a view, this process will fail to reinstate that        thing after clearing out DependentsFields.  DF was only        intended to be used as part of the MVC architecture."    Object classPool at: #DependentsFields  "Remove all entries from DF"                put: IdentityDictionary new.    Smalltalk garbageCollect.  "If that was the only reference, they will go away"    "Now if any views of non-models remain,        they should be reinstated as dependent views..."    View allSubInstancesDo:        [:v | (v model==nil or: [v model isKindOf: Model])                ifFalse: [v model addDependent: v]]    ! !!SystemDictionary methodsFor: 'housekeeping'!recompileAllFrom: firstName     "Recompile all classes, starting with given name."    Smalltalk forgetDoIts.    self allClassesDo:         [:class | class name >= firstName            ifTrue:                 [Transcript show: class name; cr.                class compileAll]]    "Smalltalk recompileAllFrom: 'Aardvark'."! !!SystemDictionary methodsFor: 'housekeeping' stamp: 'di 10/4/97 09:11'!removeEmptyMessageCategories    "Smalltalk removeEmptyMessageCategories"    Smalltalk garbageCollect.    ClassOrganizer allInstances , (Array with: SystemOrganization) do:        [:org | org categories do:             [:cat | (org listAtCategoryNamed: cat) isEmpty                ifTrue: [org removeCategory: cat]]]! !!SystemDictionary methodsFor: 'housekeeping' stamp: 'di 9/22/97 11:40'!testDecompiler    "Smalltalk testDecompiler"    "Decompiles the source for every method in the system, and then compiles that source and verifies that it generates (and decompiles to) identical code.  This currently fails in a number of places because some different patterns (esp involving conditionals where the first branch returns) decompile the same."     | methodNode oldMethod newMethod badOnes oldCodeString |    badOnes _ OrderedCollection new.    Smalltalk forgetDoIts.    Smalltalk allBehaviorsDo:        [:cls |  Transcript cr; show: cls name.        cls selectors do:            [:selector |            oldMethod _ cls compiledMethodAt: selector.            oldCodeString _ (cls decompilerClass new                                decompile: selector in: cls method: oldMethod)                            decompileString.            methodNode _ cls compilerClass new                        compile: oldCodeString                        in: cls notifying: nil ifFail: [].            newMethod _ methodNode generate: #(0 0 0 0).            oldCodeString = (cls decompilerClass new                                decompile: selector in: cls method: newMethod)                            decompileString ifFalse: [Transcript cr; show: '***' , cls name , ' ' , selector.                                            badOnes add: cls name , ' ' , selector]]].    ^ badOnes! !!SystemDictionary methodsFor: 'housekeeping'!testFormatter    "Smalltalk testFormatter"    "Reformats the source for every method in the system, and then    compiles that source and verifies that it generates identical code"     | newCodeString methodNode oldMethod newMethod badOnes |    badOnes _ OrderedCollection new.    Smalltalk forgetDoIts.    Smalltalk allBehaviorsDo:        [:cls |  Transcript cr; show: cls name.        cls selectors do:            [:selector |            newCodeString _ (cls compilerClass new)                format: (cls sourceCodeAt: selector)                in: cls notifying: nil.            methodNode _ cls compilerClass new                        compile: newCodeString                        in: cls notifying: nil ifFail: [].            newMethod _ methodNode generate: #(0 0 0 0).            oldMethod _ cls compiledMethodAt: selector.            oldMethod = newMethod ifFalse: [Transcript cr; show: '***' , cls name , ' ' , selector.                                            badOnes add: cls name , ' ' , selector]]].    ^ badOnes! !!SystemDictionary methodsFor: 'miscellaneous'!clipboardText    "Get the current clipboard text. Return the empty string if the primitive fails."    <primitive: 141>    ^ ''! !!SystemDictionary methodsFor: 'miscellaneous' stamp: 'jm 6/17/97 07:09'!getSystemAttribute: attributeID    "Return the string for the system attribute with the given integer ID."    <primitive: 149>    self primitiveFailed! !!SystemDictionary methodsFor: 'miscellaneous' stamp: 'jm 9/14/97 10:54'!getVMParameters    "Smalltalk getVMParameters"    <primitive: 254>    self primitiveFailed! !!SystemMonitor methodsFor: 'initialize-release' stamp: 'jm 9/17/97 16:06'!labels: labelArray selectors: selectorArray    | labelHeight labelWidth topLeft bottomRight |    self readVMParameters.    minValues _ selectorArray collect: [:str | self perform: (str , 'Min') asSymbol].    maxValues _ selectorArray collect: [:str | self perform: (str , 'Max') asSymbol].    valSelectors _ selectorArray collect: [:str | (str , 'Val') asSymbol].    labels _ labelArray collect: [:str |        (DisplayText text: str asText)            foregroundColor: ForegroundColor            backgroundColor: BackgroundColor].    baselineSkip _ (labels at: 1) height.    baselineSkip = 0        ifTrue:    "empty lables: use a completely undecorated display, flush-bottom/left"            [baselineSkip _ DefaultBarHeight.            labelHeight _ baselineSkip * labels size.            topLeft _ 0@(Display height - labelHeight + BarBorderWidth).            bottomRight _ BarWidth@(Display height).            window _ topLeft corner: bottomRight]        ifFalse:            [labelHeight _ baselineSkip * labels size.            labelWidth _ (labels inject: 0 into: [:max :lbl | max max: lbl width]) + (Inset * 2) + BarBorderWidth.            topLeft _ 0@(Display height - labelHeight - (Inset * 2)).            bottomRight _ (labelWidth + (2*Inset) + BarWidth)@(Display height).            window _ (topLeft corner: bottomRight) insetBy: Inset.            "window _ window translateBy: (BorderWidth negated)@BorderWidth."            self displayBordersAndLabels]! !!SystemMonitor methodsFor: 'displaying' stamp: 'jm 9/17/97 16:06'!display    | barOrigin delta curVal minVal maxVal |    self readVMParameters.    barOrigin _ window topRight translateBy: (BarWidth negated - BarBorderWidth)@BarBorderWidth.    delta _ 0@baselineSkip.    1 to: valSelectors size do: [:index |        curVal _ self perform: (valSelectors at: index).        minVal _ minValues at: index.        maxVal _ maxValues at: index.        curVal class == Array            ifTrue:                ["implicitly trust the system to return sensible values"                self displayBars: curVal from: minVal to: maxVal                    in: (barOrigin extent: BarWidth@(baselineSkip - (BarBorderWidth * 2)))]            ifFalse:                ["adjust the bounds if necessary"                minVal > curVal ifTrue: [minValues at: index put: (minVal _ curVal)].                maxVal < curVal ifTrue: [maxValues at: index put: (maxVal _ curVal)].                self displayBar: curVal from: minVal to: maxVal                    in: (barOrigin extent: BarWidth@(baselineSkip - (BarBorderWidth * 2)))].        barOrigin _ barOrigin translateBy: delta].! !!SystemMonitor methodsFor: 'displaying' stamp: 'jm 9/17/97 16:06'!displayBar: val from: min to: max in: barRect    | break |    break _ barRect left + (((val - min) / (max - min)) * barRect width) asInteger.    Display fill: (barRect withRight: break) fillColor: (BarColors at: 1).    Display fill: (barRect withLeft: break) fillColor: BarBackgroundColor.! !!SystemMonitor methodsFor: 'displaying' stamp: 'jm 9/17/97 16:06'!displayBars: vals from: min to: max in: barRect    | break prevBreak |    prevBreak _ barRect left.    vals doWithIndex: [:val :index |        break _ barRect left + (((val - min) / (max - min)) * barRect width) asInteger.        Display fill: ((barRect withLeft: prevBreak) withRight: break) fillColor: (BarColors at: index).        prevBreak _ break].    Display fill: (barRect withLeft: prevBreak) fillColor: BarBackgroundColor.! !!SystemMonitor methodsFor: 'displaying' stamp: 'jm 9/17/97 16:06'!displayBordersAndLabels    | labelOrigin barOrigin delta |    Display fill: (window insetBy: Inset negated) fillColor: BorderColor.    Display fill: (window insetBy: BorderWidth - Inset) fillColor: BackgroundColor.    barOrigin _ window topRight translateBy: (BarWidth negated - (2 * BarBorderWidth))@0.    labelOrigin _ barOrigin translateBy: (Inset negated)@"0"(BorderWidth - Inset).    delta _ 0@baselineSkip.    1 to: labels size do: [:index |        (labels at: index) displayOn: Display at: (labelOrigin translateBy: ((labels at: index) width negated)@0).        Display fill: (barOrigin extent: (BarWidth + (2 * BarBorderWidth))@baselineSkip)            fillColor: BarBorderColor.        labelOrigin _ labelOrigin translateBy: delta.        barOrigin _ barOrigin translateBy: delta].! !!SystemMonitor methodsFor: 'system parameters' stamp: 'jm 9/17/97 16:06'!allocationRateMax    ^1! !!SystemMonitor methodsFor: 'system parameters' stamp: 'jm 9/17/97 16:06'!allocationRateMin    prevAllocCount _ 0.    prevAllocRate _ 0.    ^0! !!SystemMonitor methodsFor: 'system parameters' stamp: 'jm 9/17/97 16:06'!allocationRateVal    | rate allocCount |    allocCount _ vmParameters at: 4.    rate _ allocCount < prevAllocCount        ifTrue: [prevAllocRate]        ifFalse: [allocCount - prevAllocCount].    prevAllocCount _ allocCount.    prevAllocRate _ (prevAllocRate // 2) + (rate // 2).    ^prevAllocRate! !!SystemMonitor methodsFor: 'system parameters' stamp: 'jm 9/17/97 16:06'!memoryMax    ^vmParameters at: 3! !!SystemMonitor methodsFor: 'system parameters' stamp: 'jm 9/17/97 16:06'!memoryMin    "Setup the gc low/high water marks at the same time"    gcLowWaterMark _ vmParameters at: 1.    gcHighWaterMark _ vmParameters at: 1.    ^0! !!SystemMonitor methodsFor: 'system parameters' stamp: 'jm 9/17/97 16:06'!memoryVal    "If youngStart is below the highWaterMark then a full collection has happened."    | youngStart |    youngStart _ vmParameters at: 1.    youngStart < gcHighWaterMark ifTrue: [gcLowWaterMark _ gcHighWaterMark _ youngStart].    youngStart > gcHighWaterMark ifTrue: [gcHighWaterMark _ youngStart].    ^Array        with: gcLowWaterMark        with: gcHighWaterMark        with: (vmParameters at: 2)! !!SystemMonitor methodsFor: 'private' stamp: 'jm 9/17/97 16:06'!readVMParameters    vmParameters _ Smalltalk getVMParameters.! !!SystemMonitor class methodsFor: 'class initialization' stamp: 'jm 9/17/97 16:06'!initialize    "SystemMonitor initialize"    MonitorDelay _ 200.                                "milliseconds between updates"    Inset _ 2.                                        "inset from monitor border (outside) to bars and labels"    BorderWidth _ 1.                                    "width of border around entire monitor"    BorderColor _ Color black.                        "colour of border around entire monitor"    BackgroundColor _ Preferences desktopColor.        "background colour for monitor area"    ForegroundColor _ Color black.                    "foreground colour for bar labels"    DefaultBarHeight _ 8.                            "height of bar for undecorated display (no labels)"    BarWidth _ 200.                                    "horizontal (long-axis) size of each bar"    BarBorderWidth _ 1.                                "width of border around each bar"    BarBorderColor _ Color black.                    "colour of border around each bar"    BarBackgroundColor _ Color veryLightGray.        "background colour (inactive region) of bar"    BarColors _ Array        with: Color darkGray                        "colour of first bar segment"        with: Color lightRed                        "colour of second bar segment"        with: Color lightBlue                            "colour of third bar segment"        with: Color lightGreen.                        "colour of fourth bar segment"! !!SystemMonitor class methodsFor: 'instance creation' stamp: 'jm 9/17/97 16:06'!default    ^super new        labels: #(memory)        selectors: #(memory).! !!SystemMonitor class methodsFor: 'instance creation' stamp: 'jm 9/17/97 16:06'!defaultUndecorated    ^super new labels: #('') selectors: #(memory).! !!SystemMonitor class methodsFor: 'instance creation' stamp: 'jm 9/17/97 16:06'!full    ^super new        labels: #('alloc' mem)        selectors: #(allocationRate memory).! !!SystemMonitor class methodsFor: 'instance creation' stamp: 'jm 9/17/97 16:06'!fullUndecorated    ^super new        labels: #('' '')        selectors: #(allocationRate memory).! !!SystemMonitor class methodsFor: 'instance creation' stamp: 'jm 9/17/97 16:06'!new    ^self default! !!SystemMonitor class methodsFor: 'public access' stamp: 'jm 9/17/97 16:06'!restore        "SystemMonitor restore"    ActiveMonitor = nil ifFalse: [ActiveMonitor displayBordersAndLabels; display]! !!SystemMonitor class methodsFor: 'public access' stamp: 'jm 9/17/97 16:06'!start        "SystemMonitor start"    self startDefault! !!SystemMonitor class methodsFor: 'public access' stamp: 'jm 9/17/97 16:06'!startDefault        "SystemMonitor startDefault"    self start: self default! !!SystemMonitor class methodsFor: 'public access' stamp: 'jm 9/17/97 16:06'!startDefaultUndecorated        "SystemMonitor startDefaultUndecorated"    self start: self defaultUndecorated! !!SystemMonitor class methodsFor: 'public access' stamp: 'jm 9/17/97 16:06'!startFull        "SystemMonitor startFull"    self start: self full! !!SystemMonitor class methodsFor: 'public access' stamp: 'jm 9/17/97 16:06'!startFullUndecorated        "SystemMonitor startFullUndecorated"    self start: self fullUndecorated! !!SystemMonitor class methodsFor: 'public access' stamp: 'jm 9/17/97 16:06'!startUndecorated        "SystemMonitor startUndecorated"    self startDefaultUndecorated! !!SystemMonitor class methodsFor: 'public access' stamp: 'jm 9/17/97 16:06'!stop        "SystemMonitor stop"    ActiveClock = nil        ifFalse:            [ActiveClock terminate.            ActiveClock _ nil].    ActiveMonitor = nil ifFalse: [ActiveMonitor _ nil].! !!SystemMonitor class methodsFor: 'scheduling' stamp: 'jm 9/17/97 16:06'!start: aMonitor    self stop.    ActiveMonitor _ aMonitor.    ActiveClock _        [[true] whileTrue:            [ActiveMonitor display.            (Delay forMilliseconds: MonitorDelay) wait]] newProcess.    ActiveClock priority: Processor userInterruptPriority.    ActiveClock resume! !!SystemOrganizer methodsFor: 'fileIn/Out' stamp: 'di 6/28/97 19:01'!fileOutCategory: category     "Store on the file named category (a string) concatenated with '.st' all the     classes associated with the category."    ^ self fileOutCategory: category asHtml: false! !!SystemOrganizer methodsFor: 'fileIn/Out' stamp: 'di 6/28/97 19:00'!fileOutCategory: category asHtml: useHtml    "FileOut all the classes in the named system category."    | fileStream |    fileStream _ useHtml        ifTrue: [(FileStream newFileNamed: category , '.html') asHtml]        ifFalse: [FileStream newFileNamed: category , '.st'].    self fileOutCategory: category on: fileStream.    fileStream close! !SystemTracer comment:'NOTE:  The SystemTracer was invented by Ted Kaehler.  It has gone through many variations.  I have simplified it and adapted it to work with Squeak''s limited Object hashing.  It has written runnable Mac images on a Mac.  Some changes may be needed for it to produce runnables image on a bigEndian machine.  -- Dan I. 9/29/97The SystemTracer runs through the system tracing every accessible object, and writing a copy of each object onto a disk image. It does this carefully enough that the resulting clone can be started up and run, just like a snapshot.  Great care must also be taken that the tracer never sees (due to clamping) any of the structures created dynamically while writing the clone.  If this happens an infinite recursion can result.    The tracer has built-in support for clamping unwanted (or unneeded) objects out of the system. It also allows fundamental changes to, eg, object header format, compiledMethod format, number formats, etc.  The current version is fairly simple, as it just copies what is already in the system. This version does, however, reassign object hashes in order to illustrate how one must remap all the hashed structures accordingly.Squeak currently only has 12 bits of object hash.  A normal dictionary, used to map from old oop to new oop, would bog down in a system of, say, 50k objects.  This tracer has a special structure that is optimized for this purpose.  See the comment in initOopMap.  If we ever extend the object hash, this structure could be replaced by a simple IdentityDictionary.When you first start up the cloned image, you will probably get a "cannotReturn" error, a vestige of the old tracing process.  This can simply be closed (or maybe you can figure out how to fix the tracers so it doens''t happen ;-).  '!!SystemTracer methodsFor: 'initialization' stamp: 'di 9/28/97 16:13'!doit  "SystemTracer writeClone"    "(StandardFileStream allInstances select:        [:f | f name endsWith: 'clone.image']) do: [:f | f close]."    | time1 time2 ctxt n |    ctxt _ thisContext sender.    ctxt push: nil.    self init: ctxt.    cleaningUp _ false.    "true means rewriting special objects in writeSpecial2"    Transcript show: 'Tracing . . . '.    time1 _ Time millisecondClockValue.    file _ FileStream fileNamed: 'clone.image'.    file binary.    n _ self writeImage: (Array with: Smalltalk).    time2 _ Time millisecondClockValue.    Transcript cr; show: n printString , ' bytes written in '            , (time2 - time1 //1000) printString , ' seconds.'.    "ctxt pop" "So we can resume"! !!SystemTracer methodsFor: 'initialization' stamp: 'di 9/27/97 22:27'!init: aContext    initialProcess _ Process forContext: aContext priority: Processor activePriority.    self initOopMap.    hashGenerator _ Random new.    self clamp: self.    self clamp: aContext sender.    self initDict! !!SystemTracer methodsFor: 'initialization' stamp: 'di 9/27/97 11:29'!initCompactClasses    | c |    c _ Array new: 31.        "These classes have a short name (their index in this table.  It is not their oop.)    Thus their instances can use just a single word as their header in memory."    c at: 1 put: CompiledMethod.  c at: 2 put: Symbol. c at: 3 put: Array.    c at: 4 put: Float.  c at: 5 put: LargePositiveInteger.  c at: 6 put: String.    c at: 7 put: MethodDictionary.  c at: 8 put: Association.  c at: 9 put: Point.    c at: 10 put: Rectangle.  c at: 11 put: ClassOrganizer.  c at: 12 put: TextLineInterval.    c at: 13 put: BlockContext.  c at: 14 put: MethodContext.  c at: 15 put: nil.    compactClasses _ c.    "Leave 16 to 31 for user defined compact classes."! !!SystemTracer methodsFor: 'initialization' stamp: 'di 9/28/97 00:22'!initDict    writeDict _ Dictionary new: 256.    Smalltalk allClassesDo:         [:class |         class isBits             ifTrue:             [writeDict at: class put: (class isBytes ifTrue: [#writeBytes:]                                                ifFalse: [#writeWords:])]            ifFalse:            [writeDict at: class put: #writePointers:.            (class inheritsFrom: Set) | (class == Set) ifTrue:                [writeDict at: class put: #writeSet:].            (class inheritsFrom: IdentitySet) | (class == IdentitySet) ifTrue:                [writeDict at: class put: #writeIdentitySet:].            (class inheritsFrom: IdentityDictionary) | (class == IdentityDictionary) ifTrue:                [writeDict at: class put: #writeIdentitySet:].            (class inheritsFrom: MethodDictionary) | (class == MethodDictionary) ifTrue:                [writeDict at: class put: #writeMethodDictionary:]].                ].    Smalltalk allBehaviorsDo:         [:class | writeDict at: class class put: #writeBehavior:].    writeDict at: SmallInteger put: #writeClamped:.    writeDict at: CompiledMethod put: #writeMethod:.    writeDict at: Process put: #writeProcess:.    writeDict at: MethodContext put: #writeContext:.    writeDict at: BlockContext put: #writeContext:.! !!SystemTracer methodsFor: 'initialization' stamp: 'di 10/3/97 16:13'!writeFileHeader     file position: 0.  "info in header page"    self write4Bytes: ($A asciiValue *100) + 2.  "version number:  6500+2"    self write4Bytes: imageHeaderSize.  "File offset (bytes) of start of data"                            "same as base address (byte) of first object"    self write4Bytes: maxOop.  "Length of data segment in words"    self write4Bytes: 0.        "what you have to add to an oop to get"                            "an offset in the data portion of this file"    self write4Bytes: (self mapAt: specialObjects).    self write4Bytes: (hashGenerator next * 16rFFF asFloat) asInteger.  "next hash"    self write4Bytes: Display width * 16r10000 + Display height.  "display size"    file position > imageHeaderSize ifTrue: [self error: 'Header ran over allotted length'].    file padTo: imageHeaderSize put: 0.  "Pad header page"    file close! !!SystemTracer methodsFor: 'initialization' stamp: 'di 10/3/97 16:13'!writeImage: roots     imageHeaderSize _ 64.    "16 longs"    file position: imageHeaderSize.  "Skip header section"    maxOop _ 0.  "Starting oop"    self initCompactClasses.    specialObjects _ Smalltalk specialObjectsArray copy.    specialObjects at: 29 put: compactClasses.    "New oop of nil is needed before we find out from the trace."    NewNil _ maxOop + ((self headersFor: nil withHash: 0) size-1*4).    self trace: nil.  "In fact, this traverses the system by the time it's done!!"    self trace: specialObjects.    roots do: [:root | self trace: root].    self writeFileHeader.    ^ Array with: maxOop! !!SystemTracer methodsFor: 'mapping oops' stamp: 'di 9/29/97 08:21'!clamp: obj    self mapAt: obj put: Clamped with: nil! !!SystemTracer methodsFor: 'mapping oops'!hasClamped: obj    "See if obj will be a SmallInteger in the new system."    obj class == SmallInteger ifTrue: [^ true].    ^ (self mapAt: obj) = Clamped! !!SystemTracer methodsFor: 'mapping oops'!initOopMap    "oopMap is an array 4096 long indexed by basicHash.    Each element a subarray of object/newOop/hash triplets.    The subarrrays must be linearly searched.    Access to an object causes it to be promoted in the subarray,        so that frequently accessed objects can be found quickly."    oopMap _ (1 to: 4096) collect: [:i | Array new].! !!SystemTracer methodsFor: 'mapping oops' stamp: 'di 9/27/97 20:26'!mapAt: obj    "Return the new oop for this object"    | bucket |    bucket _ oopMap at: obj identityHash+1.    1 to: bucket size by: 3 do:         [:i | obj == (bucket at: i)            ifTrue: ["Promote this entry for rapid access"                    i > 1 ifTrue: [1 to: 3 do: [:j | bucket swap: j with: i-1+j]].                    ^ bucket at: 2]].    ^ UnassignedOop! !!SystemTracer methodsFor: 'mapping oops' stamp: 'di 9/27/97 20:26'!mapAt: obj put: oop with: hash    "Assign the new oop for this object"    | bucket |    bucket _ oopMap at: obj identityHash+1.    "Check for multiple writes (debug only)""    1 to: bucket size by: 3 do:         [:i | obj == (bucket at: i) ifTrue: [self halt]]."    oopMap at: obj identityHash+1 put: (Array with: obj with: oop with: hash) , bucket! !!SystemTracer methodsFor: 'mapping oops' stamp: 'di 9/27/97 20:27'!mapHashAt: obj    "Return the new hash for this object"    | bucket |    bucket _ oopMap at: obj identityHash+1.    1 to: bucket size by: 3 do:         [:i | obj == (bucket at: i) ifTrue: [^ bucket at: 3]].    self halt! !!SystemTracer methodsFor: 'tracing and writing' stamp: 'di 9/29/97 09:05'!new: obj class: class length: length trace: traceBlock write: writeBlock    | oop objpos headers type hash |    "We assign file space for an object.    Only does something when object has not been assigned a new oop yet.      Length is the instance vars and variable portion in longs.    Class is not included in length.    Special objects come here for an oop, and do no tracing or writing.    To trace and write their fields later, do NOT use this method."      oop_ self mapAt: obj.    oop = UnassignedOop ifFalse:        ["Has already been assigned a new oop or clamped."        ^ self].    "Write header and remember new oop in map"    hash _ (hashGenerator next * 16rFFF asFloat) asInteger.    headers _ self headersFor: obj withHash: hash.    file position: maxOop + imageHeaderSize.    headers do: [:h | self write4Bytes: h].    maxOop _ maxOop + (headers size-1*4).        "New oop points at header word"    self mapAt: obj put: maxOop with: hash.    objpos _ maxOop + imageHeaderSize.        "file position"length > 20 ifTrue: [maxOop printString, ' ' displayAt: 0@0].    "Write blank data, advancing to next object position"    maxOop _ maxOop + (length+1*4).    "ready for next object"    file nextPutAll: (ByteArray new: length*4 withAll: 0).    traceBlock notNil ifTrue: [self trace: class.  traceBlock value].    (headers size > 1 and: [(headers at: headers size-1) < 0])        ifTrue: ["rewrite class word if not known before"                file position: objpos-4.                type _ (headers at: headers size-1) bitAnd: 3.                self write4Bytes: (self mapAt: class) + type.                self write4Bytes: (headers at: headers size) "faster to write than skip"]        ifFalse: ["Had no class header, or was already valid"                file position: objpos+4].    "Now positioned after header, before data..."    writeBlock value.    "No allocation of new oops is allowed in here!!"    "Consistency check"    file position = (objpos + (length+1*4)) ifFalse:        ["writeBlock did not leave us at end of object"        self halt.        "Maybe copied an object without putting it in holder,        so it got freed and became something else of a different size"]! !!SystemTracer methodsFor: 'tracing and writing'!trace: obj    (self hasClamped: obj) ifTrue: [^ self].    self perform: (writeDict at: obj class ifAbsent: [#writeClamped:])            "May be some classes not in Smalltalk dict, let them through"        with: obj.! !!SystemTracer methodsFor: 'tracing and writing' stamp: 'di 9/28/97 14:40'!writeBehavior: obj    | length |    self new: obj        class: obj class        length: (length _ self sizeInWordsOf: obj)        trace: [1 to: length do: [:i | self trace: (obj instVarAt: i)]]        write: [1 to: 2 do: [:i | self writePointerField: (obj instVarAt: i)].            self writePointerField: (self formatOfCls: obj).            4 to: length do: [:i | self writePointerField: (obj instVarAt: i)]]! !!SystemTracer methodsFor: 'tracing and writing'!writeBytes: obj    self new: obj        class: obj class        length: (self sizeInWordsOf: obj)        trace: []        write:             [1 to: obj size do: [:i | file nextPut: (obj at: i) asInteger].            file padToNextLongPut: 0]! !!SystemTracer methodsFor: 'tracing and writing'!writeClamped: obj    ^false! !!SystemTracer methodsFor: 'tracing and writing' stamp: 'di 9/28/97 01:33'!writeContext: obj    "Nil out any garbage above the stack pointer to avoid a crash."    obj stackPtr == nil ifFalse:        [obj stackPtr+1 to: obj size do: [:ind | obj at: ind put: nil]].    ^ self writePointers: obj    "Normal Case"! !!SystemTracer methodsFor: 'tracing and writing' stamp: 'di 9/28/97 00:20'!writeHashArray: obj permutedBy: perm    "Elements of a Set's hashed array need to be reordered according to perm."    | length |    self new: obj class: obj class length: (length _ self sizeInWordsOf: obj)        trace:    [1 to: length do:                    [:i | self trace: (obj basicAt: i)]]        write:    [1 to: length do:                    [:i | self writePointerField: ((perm at: i) == nil                                        ifTrue: [nil]                                        ifFalse: [obj basicAt: (perm at: i)])]]! !!SystemTracer methodsFor: 'tracing and writing' stamp: 'di 9/28/97 00:15'!writeHashArrayPermuted: obj useIdentity: useIdentity    "Elements of a Set's hashed array need to be reordered according to new oops."    | length perm |    self new: obj class: obj class length: (length _ self sizeInWordsOf: obj)        trace:    [1 to: length do: [:i | self trace: (obj basicAt: i)].                "Now get permutation based on new oops"                perm _ self permutationFor: obj useIdentity: useIdentity]        write:    [1 to: length do:                    [:i | self writePointerField: ((perm at: i) == nil                                        ifTrue: [nil]                                        ifFalse: [obj basicAt: (perm at: i)])]]! !!SystemTracer methodsFor: 'tracing and writing' stamp: 'di 9/27/97 20:44'!writeIdentitySet: obj     "Elements of a Set need to be reordered owing to new oops."    ^ self writeSet: obj useIdentity: true! !!SystemTracer methodsFor: 'tracing and writing'!writeMethod: obj    | nptrs |    nptrs _ obj numLiterals + 1.    self new: obj        class: obj class        length: (self sizeInWordsOf: obj)        trace: [2 to: nptrs do: [:i | self trace: (obj objectAt: i)]]        write:             [self writePointerField: (self methodHeader: obj).            2 to: nptrs do: [:i | self writePointerField: (obj objectAt: i)].            nptrs * 4 + 1 to: obj size do: [:i | file nextPut: (obj at: i)].            file padToNextLongPut: 0]! !!SystemTracer methodsFor: 'tracing and writing' stamp: 'di 9/28/97 00:22'!writeMethodDictionary: obj    "Elements of a Set need to be reordered according to new oops."    | perm |    self new: obj class: obj class length: (self sizeInWordsOf: obj)        trace:    ["First need to map the indexable fields (selectors)"                1 to: obj basicSize do: [:i | self trace: (obj basicAt: i)].                "Now get permutation based on new oops"                perm _ self permutationFor: obj useIdentity: true.                "Map named inst vars *assuming* 2nd is the hash array"                1 to: obj class instSize do:                    [:i | i=2 ifTrue: ["Permute the hash array and note its permutation"                                    self writeHashArray: (obj instVarAt: i) permutedBy: perm]                            ifFalse: ["Other fields get traced normally"                                    self trace: (obj instVarAt: i)]]]        write:    [1 to: obj class instSize do:                    [:i | self writePointerField: (obj instVarAt: i)].                1 to: obj basicSize do:                    [:i | self writePointerField: ((perm at: i) == nil                                            ifTrue: [nil]                                            ifFalse: [obj basicAt: (perm at: i)])]]! !!SystemTracer methodsFor: 'tracing and writing'!writePointers: obj    | length |    self new: obj        class: obj class        length: (length _ self sizeInWordsOf: obj)        trace: [1 to: length do: [:i | self trace: (obj instVarAt: i)]]        write: [1 to: length do: [:i | self writePointerField: (obj instVarAt: i)]]! !!SystemTracer methodsFor: 'tracing and writing'!writeProcess: obj     "Substitute new initialProcess for current."    | newObj instSize |    newObj _ obj == Processor activeProcess            ifTrue: [initialProcess]            ifFalse: [obj].    self new: obj        class: newObj class        length: (instSize _ newObj class instSize)        trace: [1 to: instSize do:                [:i | self trace: (newObj instVarAt: i)]]        write: [1 to: instSize do:                [:i | self writePointerField: (newObj instVarAt: i)]]! !!SystemTracer methodsFor: 'tracing and writing' stamp: 'di 9/27/97 20:43'!writeSet: obj     "Elements of a Set need to be reordered owing to new oops."    ^ self writeSet: obj useIdentity: false! !!SystemTracer methodsFor: 'tracing and writing' stamp: 'di 9/28/97 00:01'!writeSet: obj useIdentity: useIdentity    "Elements of a Set need to be reordered according to new oops."    | |    self basicSize > 0 ifTrue: [self halt. "Not clear how to permute this kind of set"].    self new: obj class: obj class length: (self sizeInWordsOf: obj)        trace:             ["Map named inst vars *assuming* 2nd is the hash array"            1 to: obj class instSize do:                [:i | i=2 ifTrue: ["Permute the hash array and note its permutation"                                self writeHashArrayPermuted: (obj instVarAt: i)                                            useIdentity: useIdentity]                        ifFalse: ["Other fields get traced normally"                                self trace: (obj instVarAt: i)]]]        write:             [1 to: obj class instSize do:                [:i | self writePointerField: (obj instVarAt: i)]]! !!SystemTracer methodsFor: 'tracing and writing'!writeWords: obj    self new: obj        class: obj class        length: (self sizeInWordsOf: obj)        trace: []        write: [1 to: obj basicSize do: [:i | self write4Bytes: (obj instVarAt: i)]]! !!SystemTracer methodsFor: 'private' stamp: 'di 9/28/97 14:46'!formatOf: obj    "Make the code that tells the format of this object.    It is like the class's instSpec, but with added low bits for byte size""       0=      No pointer fields        1=      Fixed pointer fields only        2=      Var pointer fields only        3=      Fixed and var pointer fields         4=      unused        5=      unused        6=      var long (bit) fields only        7=      unused         8-11=   var byte fields only                low 2 bits are low 2 bits of size **        12-15   methods -- ie #literals in header, followed by var bytes                same interpretation of low 2 bits"    | class spec |    class _ obj class.    spec _ class instSpec.    "just use what's there"    spec < 8 ifTrue: [^ spec]            ifFalse: ["For byte objects, size = wordSize - spec.lowBits"                    ^ spec + (3 - (obj size+3 bitAnd: 3))]! !!SystemTracer methodsFor: 'private' stamp: 'di 9/28/97 14:46'!formatOfCls: class    "Return the full word value that encodes instSize, bits, bytes, and variable."    "See the comment in Behavior format:variable:words:pointers:"    ^ class format    "just use what's there"! !!SystemTracer methodsFor: 'private' stamp: 'di 9/29/97 08:48'!headersFor: obj withHash: hash    "Create three header words for this object.  Length, class, header bits."    "Three possibilities:        Length, class, header bits        0, class, header bits        0,0, header bits"    | header3 header2 header1 cix sizeFld |    "3 gc bits"    header1 _ 0.  "Mark, old, dirty"    header1 _ header1 bitShift: 12.    "next fld is 12 bits"    header1 _ header1 + (hash bitAnd: 16rFFF).    header1 _ header1 bitShift: 5.    sizeFld _ (self sizeInWordsOf: obj) + 1.    "size in long words, incl hdr0"    cix _ compactClasses indexOf: obj class.    "0 means need full word"    header2 _ self mapAt: obj class.    header1 _ header1 + (cix bitAnd: 16r1F).    header1 _ header1 bitShift: 4.    header1 _ header1 + (self formatOf: obj).    "Class characteristics"    header1 _ header1 bitShift: 6.    sizeFld > 16r3F        ifTrue: [header3 _ sizeFld bitShift: 2.                sizeFld _ 0]        ifFalse: [header3 _ 0].    header1 _ header1 + sizeFld.    header1 _ header1 bitShift: 2.    header3 > 0 ifTrue:        ["3-word: type=0"        ^ Array with: header3+0 with: header2+0 with: header1+0].    cix = 0 ifTrue:        [ "2-word: type=1"        ^ Array with: header2+1 with: header1+1].    "1-word: type=3"    ^ Array with: header1+3! !!SystemTracer methodsFor: 'private' stamp: 'di 9/28/97 14:45'!methodHeader: obj    "Return the integer encoding the attributes of this method"    "See the comment in CompiledMethod newBytes:nArgs:nTemps:nStack:nLits:primitive:"    ^ obj header  "just use what's there"! !!SystemTracer methodsFor: 'private' stamp: 'di 9/28/97 14:47'!newHashFor: obj    "If an object has a hash derived from its value, it will override on the way here.    This object can use anything as a hash.  Derive one from its oop."    (self mapAt: obj) = UnassignedOop        ifTrue: [self halt]        ifFalse: [^ self mapHashAt: obj]  ! !!SystemTracer methodsFor: 'private' stamp: 'di 9/27/97 20:40'!permutationFor: array useIdentity: useIdentity    "Return an inverse permutation for an array to permute it according to    the mapped oop values. The keys in array MUST have been mapped."    | len perm key hash |    len _ array basicSize.      perm _ Array new: len.    1 to: len do:        [:i | key _ array basicAt: i.        (key == nil or: [self hasClamped: key])          ifFalse:            [hash _ useIdentity                    ifTrue: [key identityHashMappedBy: self]                    ifFalse: [key hashMappedBy: self].            hash _ hash \\ len + 1.            [(perm at: hash) == nil]                 whileFalse:                [hash _ (hash = len ifTrue: [1] ifFalse: [hash + 1])].            perm at: hash put: i]].    ^ perm! !!SystemTracer methodsFor: 'private'!sizeInWordsOf: anObject"NOTE: This is the new length of the object in LONG WORDS.        Does not include the class (header) word."    | class |    class _ anObject class.    class isBytes ifTrue: [^ anObject basicSize+3 // 4].    class isBits ifTrue: [^ anObject basicSize].    "in two byte chunks"    class isVariable ifTrue: [^ class instSize + anObject basicSize].    ^ class instSize! !!SystemTracer methodsFor: 'private' stamp: 'di 9/28/97 14:20'!write4Bytes: bits     "Avoid overhead of large integers and nextWord:put:."    | posBits bytes |    bits positive        ifTrue: [posBits _ bits]        ifFalse: ["Change rep to twos complement."                posBits _ 16rFFFFFFFF+(bits+1)].    bytes _ ByteArray new: 4.    bytes at: 1 put: (posBits digitAt: 4).    bytes at: 2 put: (posBits digitAt: 3).    bytes at: 3 put: (posBits digitAt: 2).    bytes at: 4 put: (posBits digitAt: 1).    file nextPutAll: bytes! !!SystemTracer methodsFor: 'private' stamp: 'di 9/28/97 12:03'!writePointerField: obj     | newOop |    obj class == SmallInteger ifTrue:         [obj >= 0 ifTrue: [newOop _ obj * 2 + 1]                ifFalse: [newOop _ (16r80000000 + obj) * 2 + 1].        self write4Bytes: newOop.        ^ obj].            "normal pointers"    (newOop _ self mapAt: obj) = Clamped        ifTrue: ["If object in this field is not being traced, put out nil."                self write4Bytes: NewNil]        ifFalse: [self write4Bytes: newOop]! !!SystemTracer class methodsFor: 'instance creation' stamp: 'di 9/27/97 14:01'!initialize    "SystemTracer initialize"    "These consts are negative, so they will not match any oop.    It is important, though, that UnassignedOop, at least, have    zero in its low-order 2 bits, (like all oops) so that the use of +    to merge the header type bits (happens in new:class:...) will    not do weird things."    Clamped _ -4.  "Flag clamped objects in oopMap"        UnassignedOop _ -8.  "Flag unassigned oops in oopMap"! !!SystemTracer class methodsFor: 'instance creation' stamp: 'di 9/27/97 12:30'!writeClone  "SystemTracer writeClone"    | tracer |    tracer _ self new.    "Delay shutDown."  "part of Smalltalk processShutDownList."    tracer doit.   " <-- execution in clone resumes after this send"    tracer == nil "will be nil in clone, since it is clamped"        ifTrue: [Smalltalk processStartUpList].    ^ tracer! !!SystemWindow methodsFor: 'initialization' stamp: 'di 6/16/97 15:02'!defaultExtent    ^ 400@300! !!SystemWindow methodsFor: 'initialization' stamp: 'di 6/16/97 15:03'!extent: newExtent    | inner |    super extent: newExtent.    inner _ self innerBounds.    closeBox position: (inner topLeft + 2).    collapseBox position: (inner topRight - (collapseBox width@0) + (-2@2)).    label bounds: (label bounds align: label bounds topCenter with: inner topCenter).! !!SystemWindow methodsFor: 'initialization' stamp: 'di 6/18/97 05:32'!initialize    super initialize.    borderColor _ #raised.    borderWidth _ 2.    color _ Color r: 0.6 g: 0.2 b: 0.2.    paneColor _ Color r: 0.8 g: 1.0 b: 0.599.    self addMorph: (label _ StringMorph new contents: labelString;                        font: ((TextStyle default fontAt: 2) emphasized: 1)).    self addMorph: (closeBox _ SimpleButtonMorph new borderWidth: 2; color: paneColor;                            label: 'X'; actionSelector: #delete; target: self).    self addMorph: (collapseBox _ SimpleButtonMorph new borderWidth: 2; color: paneColor;                            label: 'O'; actionSelector: #collapse; target: self).    self initPanes.    self allMorphsDo: [:m | m paneColor: paneColor].    self extent: self defaultExtent! !!SystemWindow methodsFor: 'initialization' stamp: 'di 6/16/97 15:06'!initPanes    "To be overridden by subclasses"! !!SystemWindow methodsFor: 'initialization' stamp: 'di 6/16/97 14:46'!labelHeight    ^ label height + 1! !!SystemWindow methodsFor: 'initialization' stamp: 'di 6/18/97 05:31'!setLabel: aString    labelString _ aString! !!SystemWindow class methodsFor: 'instance creation' stamp: 'di 6/23/97 00:12'!includeInNewMorphMenu    "Not to be instantiated from the menu"    ^ self ~~ SystemWindow! !!SystemWindow class methodsFor: 'instance creation' stamp: 'di 6/18/97 05:31'!labelled: labelString    ^ (self basicNew setLabel: labelString) initialize! !!TAssignmentNode methodsFor: 'all'!bindVariablesIn: aDictionary    variable _ variable bindVariablesIn: aDictionary.    expression _ expression bindVariablesIn: aDictionary.! !!TAssignmentNode methodsFor: 'all'!copyTree    ^self class new        setVariable: variable copyTree        expression: expression copyTree! !!TAssignmentNode methodsFor: 'all'!emitCCodeOn: aStream level: level generator: aCodeGen    | sel |    self isVariableUpdatingAssignment ifTrue: [        variable emitCCodeOn: aStream level: level generator: aCodeGen.        sel _ expression selector.        sel = #+            ifTrue: [aStream nextPutAll: ' += ']            ifFalse: [aStream nextPutAll: ' -= '].            expression args first emitCCodeOn: aStream level: level generator: aCodeGen.    ] ifFalse: [        variable emitCCodeOn: aStream level: level generator: aCodeGen.        aStream nextPutAll: ' = '.        expression emitCCodeOn: aStream level: level generator: aCodeGen.    ].! !!TAssignmentNode methodsFor: 'all'!expression    ^expression! !!TAssignmentNode methodsFor: 'all'!inlineMethodsUsing: aDictionary    variable inlineMethodsUsing: aDictionary.    expression inlineMethodsUsing: aDictionary.! !!TAssignmentNode methodsFor: 'all'!isAssignment    ^true! !!TAssignmentNode methodsFor: 'all'!isVariableUpdatingAssignment    "Return true if this assignment statement is of one of the forms:        var = var + ...        var = var - ...    Such assignments statements can exploit the C updating assignment operators. For example, 'x += 4' can be generated instead of 'x = x + 4'. This produces better code under some C compilers, most notably the CodeWarrior 68K compiler."    | sel |    (expression isSend and: [expression receiver isVariable]) ifFalse: [^ false].    sel _ expression selector.    ^ (expression receiver name = variable name) and: [(sel = #+) or: [sel = #-]]! !!TAssignmentNode methodsFor: 'all'!nodesDo: aBlock    variable nodesDo: aBlock.    expression nodesDo: aBlock.    aBlock value: self.! !!TAssignmentNode methodsFor: 'all'!printOn: aStream level: level    variable printOn: aStream level: level.    aStream nextPutAll: ' _ '.    expression printOn: aStream level: level + 2.! !!TAssignmentNode methodsFor: 'all'!replaceNodesIn: aDictionary    ^aDictionary at: self ifAbsent: [        variable _ variable replaceNodesIn: aDictionary.        expression _ expression replaceNodesIn: aDictionary.        self]! !!TAssignmentNode methodsFor: 'all'!setVariable: varNode expression: expressionNode    variable _ varNode.    expression _ expressionNode.! !!TAssignmentNode methodsFor: 'all'!variable    ^variable! !!TCaseStmtNode methodsFor: 'all'!bindVariablesIn: aDictionary    expression _ expression bindVariablesIn: aDictionary.    cases _ cases collect: [ :c | c bindVariablesIn: aDictionary ].! !!TCaseStmtNode methodsFor: 'all'!cases    ^cases! !!TCaseStmtNode methodsFor: 'all'!copyTree    ^self class new        setExpression: expression copyTree        firsts: firsts copy        lasts: lasts copy        cases: (cases collect: [ :case | case copyTree ])! !!TCaseStmtNode methodsFor: 'all'!customizeCase: caseParseTree forVar: varName from: firstIndex to: lastIndex    "Return a collection of copies of the given parse tree, each of which has the value of the case index substituted for the given variable."    | newCases dict newCase |    newCases _ OrderedCollection new.    firstIndex to: lastIndex do: [ :caseIndex |        dict _ Dictionary new.        dict at: varName put: (TConstantNode new setValue: caseIndex).        newCase _ caseParseTree copyTree bindVariablesIn: dict.        self fixSharedCodeBlocksForCase: caseIndex in: newCase.        newCases addLast: newCase.    ].    ^ newCases! !!TCaseStmtNode methodsFor: 'all'!customizeShortCasesForDispatchVar: varName    "Make customized versions of a short bytecode methods, substituting a constant having the case index value for the given variable. This produces better code for short bytecodes such as instance variable pushes that encode the index of the instance variable in the bytecode."    | newFirsts newLasts newCases l f case expanded |    newFirsts _ OrderedCollection new.    newLasts _ OrderedCollection new.    newCases _ OrderedCollection new.    1 to: cases size do: [ :i |        l _ lasts at: i.        f _ firsts at: i.        case _ cases at: i.        expanded _ false.        (l - f) > 1 ifTrue: [  "case code covers multiple cases"            case nodeCount < 45 ifTrue: [                newFirsts addAll: (f to: l) asArray.                newLasts addAll: (f to: l) asArray.                newCases addAll: (self customizeCase: case forVar: varName from: f to: l).                expanded _ true.            ].        ].        expanded ifFalse: [            self fixSharedCodeBlocksForCase: f in: case.            newFirsts addLast: f.            newLasts addLast: l.            newCases addLast: case.        ].    ].    firsts _ newFirsts asArray.    lasts _ newLasts asArray.    cases _ newCases asArray.! !!TCaseStmtNode methodsFor: 'all'!emitCCodeOn: aStream level: level generator: aCodeGen    | indent |    indent _ (String new: level) collect: [ :ch | Character tab ].    aStream nextPutAll: 'switch ('.    expression emitCCodeOn: aStream level: level generator: aCodeGen.    aStream nextPutAll: ') {'; cr.    1 to: cases size do: [ :i |        (firsts at: i) to: (lasts at: i) do: [ :caseIndex |            aStream nextPutAll: indent, 'case ', caseIndex printString, ':'; cr.        ].        (cases at: i) emitCCodeOn: aStream level: level + 1 generator: aCodeGen.        aStream nextPutAll: indent; tab; nextPutAll: 'break;'.        aStream cr.    ].    level timesRepeat: [ aStream tab ].    aStream nextPutAll: '}'.! !!TCaseStmtNode methodsFor: 'all'!expression    ^expression! !!TCaseStmtNode methodsFor: 'all'!fixSharedCodeBlocksForCase: caseIndex in: caseParseTree    "Process 'sharedCode' directives in the given parse tree. The sharedCode directive allows code replicated in different arms of a case statement to be shared. The replicated code must be the final code of the case so that it ends with a break out of the case statement. The replicated code will be generated in exactly one arm of the case statement; other instances of the shared code will be replaced by brances to that single instance of the code."    | copying oldStmts newStmts stmt codeBlockName |    caseParseTree  nodesDo: [ :node |        node isStmtList ifTrue: [            copying _ true.            oldStmts _ node statements asArray.            newStmts _ nil.  "becomes an OrderedCollection if sharedCode block is found"            1 to: oldStmts size do: [ :i |                copying ifTrue: [                    stmt _ oldStmts at: i.                    (stmt isSend and: [stmt selector = #sharedCodeNamed:inCase:]) ifTrue: [                        newStmts _ (oldStmts copyFrom: 1 to: i - 1) asOrderedCollection.                        codeBlockName _ stmt args first value.                        (stmt args last value = caseIndex) ifTrue: [                            newStmts add:                                 (TLabeledCommentNode new setLabel: codeBlockName comment: '').                        ] ifFalse: [                            newStmts add: (TGoToNode new setLabel: codeBlockName).                            copying _ false.  "don't copy remaining statements"                        ].                    ] ifFalse: [                        newStmts = nil ifFalse: [newStmts add: stmt].                    ].                ].            ].            newStmts = nil ifFalse: [node setStatements: newStmts].        ].    ].! !!TCaseStmtNode methodsFor: 'all'!inlineMethodsUsing: aDictionary    expression inlineMethodsUsing: aDictionary.    cases do: [ :c | c inlineMethodsUsing: aDictionary ].! !!TCaseStmtNode methodsFor: 'all'!isCaseStmt    ^true! !!TCaseStmtNode methodsFor: 'all'!nodesDo: aBlock    expression nodesDo: aBlock.    cases do: [ :c | c nodesDo: aBlock ].    aBlock value: self.! !!TCaseStmtNode methodsFor: 'all'!printOn: aStream level: level    aStream crtab: level.    aStream nextPutAll: 'select '.    expression printOn: aStream level: level.    aStream nextPutAll: ' in'.    1 to: cases size do: [ :i |        (firsts at: i) to: (lasts at: i) do: [ :caseIndex |            aStream crtab: level.            aStream nextPutAll: 'case ', caseIndex printString, ':'.        ].        aStream crtab: level + 1.        (cases at: i) printOn: aStream level: level + 1.    ].    aStream crtab: level.    aStream nextPutAll: 'end select'.! !!TCaseStmtNode methodsFor: 'all'!replaceNodesIn: aDictionary    ^aDictionary at: self ifAbsent: [        expression _ expression replaceNodesIn: aDictionary.        cases _ cases collect: [ :c | c replaceNodesIn: aDictionary ].        self]! !!TCaseStmtNode methodsFor: 'all'!setExpression: aNode firsts: firstsList lasts: lastsList cases: caseList    expression _ aNode.    firsts _ firstsList.    lasts _ lastsList.    cases _ caseList.! !!TCaseStmtNode methodsFor: 'all'!setExpression: aNode selectors: selectorList    "Initialize the node from the given set of selectors."    "Note: Each case is a statement list with containing one statement, a send to self of a selector from the given selector list. Having statement list nodes makes inlining easier later."    | selfNode stmt lastSel firstInRun sel |    expression _ aNode.    selfNode _ TVariableNode new setName: 'self'.    firsts _ OrderedCollection new: 400.    lasts _ OrderedCollection new: 400.    cases _ OrderedCollection new: 400.    lastSel _ selectorList first.    firstInRun _ 0.    1 to: selectorList size do: [ :i |        sel _ selectorList at: i.        sel ~= lastSel ifTrue: [            firsts add: firstInRun.            lasts add: i - 2.            stmt _ TSendNode new setSelector: lastSel receiver: selfNode arguments: #().            cases add: (TStmtListNode new setArguments: #() statements: (Array with: stmt)).            lastSel _ sel.            firstInRun _ i - 1.        ].    ].    firsts add: firstInRun.    lasts add: selectorList size - 1.    stmt _ TSendNode new setSelector: lastSel receiver: selfNode arguments: #().    cases add: (TStmtListNode new setArguments: #() statements: (Array with: stmt)).! !!TConstantNode methodsFor: 'all'!copyTree    ^self class new        setValue: value! !!TConstantNode methodsFor: 'all'!emitCCodeOn: aStream level: level generator: aCodeGen    "Emit a C literal."    aStream nextPutAll: (aCodeGen cLiteralFor: value).! !!TConstantNode methodsFor: 'all'!isConstant    ^true! !!TConstantNode methodsFor: 'all'!isLeaf    ^true! !!TConstantNode methodsFor: 'all'!printOn: aStream level: level    value storeOn: aStream.! !!TConstantNode methodsFor: 'all'!setValue: anObject    value _ anObject.! !!TConstantNode methodsFor: 'all'!value    ^value! !TempVariableNode comment:'I am a parse tree leaf representing a temporary variable'!!TempVariableNode methodsFor: 'initialize-release'!isArg: aBoolean    isAnArg _ aBoolean.    isAnArg ifTrue: [hasDefs _ true]! !!TempVariableNode methodsFor: 'initialize-release'!name: varName index: i type: type scope: level    "Only used for initting temporary variables"    name _ varName.    self key: varName        index: i        type: type.    isAnArg _ hasDefs _ hasRefs _ false.    scope _ level! !!TempVariableNode methodsFor: 'initialize-release'!nowHasDef    hasDefs _ true! !!TempVariableNode methodsFor: 'initialize-release'!nowHasRef    hasRefs _ true! !!TempVariableNode methodsFor: 'initialize-release'!scope: level    "Note scope of temporary variables.    Currently only the following distinctions are made:        0    outer level: args and user-declared temps        1    block args and doLimiT temps        -1    a block temp that is no longer active        -2    a block temp that held limit of to:do:"    scope _ level! !!TempVariableNode methodsFor: 'testing'!assignmentCheck: encoder at: location    isAnArg ifTrue: [^ location]            ifFalse: [^ -1]! !!TempVariableNode methodsFor: 'testing'!isArg    ^ isAnArg! !!TempVariableNode methodsFor: 'testing'!isTemp    ^ true! !!TempVariableNode methodsFor: 'testing'!isUndefTemp    ^ hasDefs not! !!TempVariableNode methodsFor: 'testing'!isUnusedTemp    ^ hasRefs not! !!TempVariableNode methodsFor: 'testing'!scope    ^ scope! !!TempVariableNode methodsFor: 'printing'!printOn: aStream indent: level     aStream withAttribute: (TextColor color: Color blue)            do: [aStream nextPutAll: name]! !!TestCClass1 methodsFor: 'all'!arg1: a arg2: b    "CCodeGenerator new initialize addClass: TestCClass1"    | i j k |    self var: #i declareC: 'char *i'.    i _ 'abc'.    j _ 2.    k _ 3.! !!TestCClass1 methodsFor: 'all'!ifTests    true ifTrue: [        self print: 'true case'    ].    true ifFalse: [        self print: 'false case'    ].    true ifTrue: [        self print: 'true case'    ] ifFalse: [        self print: 'false case'    ].    true ifFalse: [        self print: 'false case'    ] ifTrue: [        self print: 'true case'    ].! !!TestCClass1 methodsFor: 'all'!isIntegerValue: intValue    "Copied from ObjectMemory."    ^ (intValue bitXor: (intValue << 1)) >= 0! !!TestCClass1 methodsFor: 'all'!loopTests    | v |    v _ 0.    [v < 10] whileTrue: [ self printNum: v.  v _ v + 1 ].    self print: ''.    [v < 1] whileFalse: [ self printNum: v.  v _ v - 1 ].    self print: ''.    1 to: 10 do: [ :i | self printNum: i ].    self print: ''.    1 to: 10 by: 2 do: [ :i | self printNum: i ].    self print: ''.! !!TestCClass1 methodsFor: 'all'!method1    "(CCodeGenerator new initialize addClass: TestCClass1) codeString"    x & y ifTrue: [        x _ 10.        y _ 20.    ].    y _ nil + 3.    x = nil ifTrue: [ x _ 18 ].    ^nil! !!TestCClass1 methodsFor: 'all'!method2    self method1; method8: 0; setX: 10 Y: 20.! !!TestCClass1 methodsFor: 'all'!method3    x > 0 ifTrue: [ ^x ] ifFalse: [ ^y ].! !!TestCClass1 methodsFor: 'all'!method4    x _ 0.    y _ 0.    [x < 100] whileTrue: [        y _ y + x.        x _ x + 1.    ].    ^y! !!TestCClass1 methodsFor: 'all'!method5    self inline: true.    x & y.    x | y.    x and: [y].    x or: [y].    x not.    x + y.    x - y.    x * y.    x // y.    x \\ y.    x min: y.    x max: y.    x bitAnd: y.    x bitOr: y.    x bitXor: y.    x bitInvert32.    x bitShift: y.    x >> y.    x << y.    x < y.    x <= y.    x = y.    x >= y.    x > y.    x ~= y.    x == y.    x isNil.    x notNil.    [x > y] whileTrue: [ x _ x + 1 ].    [x > y] whileFalse: [ x _ x + 1 ].    x > y ifTrue: [ x _ x - 1 ].    x > y ifFalse: [ x _ x + 1 ].    x > y ifTrue: [ x _ x - 1 ] ifFalse: [ x _ x + 1 ].    x > y ifFalse: [ x _ x + 1 ] ifTrue: [ x _ x - 1 ].    x at: 3.    x at: 3 put: y.    self integerValueOf: x.    self integerObjectOf: x.    (self isIntegerObject: x) ifTrue: [ x _ x - 1 ].    (self isIntegerValue: x) ifTrue: [ x _ x - 1 ].    self cCoerce: x * (y - 1) to: 'int'.    x _ x + 1.    x _ x - 1.    x preDecrement.    y preIncrement > 0 ifTrue: [ x _ x + 1 ].! !!TestCClass1 methodsFor: 'all'!method6    self dispatchOn: x in: #(f1 f2 f3 f4 f5).! !!TestCClass1 methodsFor: 'all'!method7    | t1 |    self method1.    self method2.    t1 _ self method3.    self method4.    self method5.! !!TestCClass1 methodsFor: 'all'!method8: arg    | a |    self returnTypeC: 'float'.    self var: #a    declareC: 'float a = 0'.    self var: #arg declareC: 'float arg'.    self cCode: 'a = arg * 3.14159'.    ^a! !!TestCClass1 methodsFor: 'all'!print: val    self cCode: 'printf("%d\n", val)'.! !!TestCClass1 methodsFor: 'all'!printNum: i    self cCode: 'printf("%d ", i)'.! !!TestCClass1 methodsFor: 'all'!setX: newX Y: newY    x _ newX min: newY.    y _ newY.! !!TestCClass2 methodsFor: 'all'!atAllPut    | i |    i _ VectSize.    [i > 0] whileTrue: [        vect at: i put: 5.        i _ i - 1.    ].    (vect at: 1) ~= 5 ifTrue: [ self error: 'AtAllPutBenchmark' ].! !!TestCClass2 methodsFor: 'all'!error: s    "Print an error message and exit."    self print: 'Error in %s\n' f: s.    self exit: -1.! !!TestCClass2 methodsFor: 'all'!incrementAll    | oldVal i |    oldVal _ vect at: 1.    i _ VectSize.    [i > 0] whileTrue: [        vect at: i put: ((vect at: i) + 1).        i _ i - 1.    ].    (vect at: 1) ~= (oldVal + 1) ifTrue: [ self error: 'IncrementAllBenchmark' ].! !!TestCClass2 methodsFor: 'all'!initialize    VectSize _ 10000.    vect _ Array new: VectSize.! !!TestCClass2 methodsFor: 'all'!main    | startTicks ticks |    self printf: 'atAllPut: '.    startTicks _ self clock.    self atAllPut.    ticks _ self clock - startTicks.    self print: '%ld\n' f: ticks.    self printf: 'incrementAll: '.    self incrementAll.    ticks _ self clock - startTicks.    self print: '%ld\n' f: ticks.    self printf: 'nestedWhileLoop: '.    self nestedWhileLoop.    ticks _ self clock - startTicks.    self print: '%ld\n' f: ticks.    self printf: 'sieve: '.    self sieve.    ticks _ self clock - startTicks.    self print: '%ld\n' f: ticks.    self printf: 'sumAll: '.    self sumAll.    ticks _ self clock - startTicks.    self print: '%ld\n' f: ticks.    self printf: 'sumFromTo: '.    self sumFromTo.    ticks _ self clock - startTicks.    self print: '%ld\n' f: ticks.! !!TestCClass2 methodsFor: 'all'!nestedWhileLoop    | sum i j |    sum _ 0.    i _ 1000.    [i > 0] whileTrue: [        j _ 100.        [j > 0] whileTrue: [            sum _ sum + 1.            j _ j - 1.        ].        i _ i - 1.    ].    sum ~= 100000 ifTrue: [ self error: 'NestedWhileBenchmark' ].! !!TestCClass2 methodsFor: 'all'!sieve    | flagsSize flags primeCount i k |    flagsSize _ 8190.    flags _ Array new: flagsSize.    i _ flagsSize.    [i > 0] whileTrue: [        flags at: i put: true.        i _ i - 1.    ].    primeCount _ 0.    i _ 2.    [i <= flagsSize] whileTrue: [        (flags at: i) ifTrue: [            primeCount _ primeCount + 1. "i is a prime"            k _ i + i.            [k <= flagsSize] whileTrue: [                flags at: k put: false. "k is not a prime; it is a multiple of i"                k _ k + i.            ].        ].        i _ i + 1.    ].    primeCount ~= 1027 ifTrue: [ self error: 'SieveBenchmark' ].! !!TestCClass2 methodsFor: 'all'!sumAll    | elementVal sum i |    elementVal _ vect at: 1.    sum _ 0.    i _ VectSize.    [i > 0] whileTrue: [        sum _ sum + (vect at: i).        i _ i - 1.    ].    sum ~= (VectSize * elementVal) ifTrue: [ self error: 'SumAllBenchmark' ].! !!TestCClass2 methodsFor: 'all'!sumFromTo    | sum i j |    i _ 10.    [i > 0] whileTrue: [        sum _ 0.        j _ 10000.        [j > 0] whileTrue: [            sum _ sum + j.            j _ j - 1.        ].        i _ i - 1.    ].    sum ~= 50005000 ifTrue: [ self error: 'SumFromToBenchmark' ].! !!TestCClass2 class methodsFor: 'testing'!test    "TestCClass2 test"    "(CCodeGenerator new initialize addClass: TestCClass2) codeString"    | bm |    bm _ self new initialize.    Transcript show: 'atAllPut: '.    Transcript show: (Time millisecondsToRun: [bm atAllPut]) printString; cr.    Transcript show: 'incrementAll: '.    Transcript show: (Time millisecondsToRun: [bm incrementAll]) printString; cr.    Transcript show: 'nestedWhileLoop: '.    Transcript show: (Time millisecondsToRun: [bm nestedWhileLoop]) printString; cr.    Transcript show: 'sieve: '.    Transcript show: (Time millisecondsToRun: [bm sieve]) printString; cr.    Transcript show: 'sumAll: '.    Transcript show: (Time millisecondsToRun: [bm sumAll]) printString; cr.    Transcript show: 'sumFromTo: '.    Transcript show: (Time millisecondsToRun: [bm sumFromTo]) printString; cr.! !!TestCClass3 methodsFor: 'all'!dispatchOn: currentBytecode in: selectorArray    "Simulate a case statement via selector table lookup. The given integer must be between 0 and (selectorArray size - 1), inclusive. Send the selector at (currentBytecode + 1) in selectorArray to the receiver. For speed, no extra range test is done, since it is done by the at: operation."    "Note: Delete this method from the generated code."    "assert: (currentBytecode >= 0) | (currentBytecode < selectorArray size)"    self perform: (selectorArray at: (currentBytecode + 1)).! !!TestCClass3 methodsFor: 'all'!f1    | local r |    local _ self functionWithLabel: 1.    r _ 7.    self print: 'f1'.! !!TestCClass3 methodsFor: 'all'!f2    | local i |    local _ 2.    i _ self functionWithLabel: -2.    i > 0 ifTrue: [ ^ -1 ].    self print: 'f2'.! !!TestCClass3 methodsFor: 'all'!f3    self sharedCodeNamed: 'sharedCode' inCase: 5.    self print: 'f3'.! !!TestCClass3 methodsFor: 'all'!f4    self sharedCodeNamed: 'sharedCode' inCase: 5.    self print: 'f4'.! !!TestCClass3 methodsFor: 'all'!f5    self sharedCodeNamed: 'sharedCode' inCase: 5.    self print: 'f5'.! !!TestCClass3 methodsFor: 'all'!functionWithLabel: arg    arg > 0 ifTrue: [ ^1 ] ifFalse: [ ^-1 ].! !!TestCClass3 methodsFor: 'all'!interpret    "TestCClass3 new main"    "(CCodeGenerator new initialize addClass: TestCClass3) codeString"    0 to: 9 do: [ :currentBytecode |        self dispatchOn: currentBytecode in: #(f1 f2 f2 f3 f3 f3 f4 f4 f5 f2).    ].! !!TestCClass3 methodsFor: 'all'!print: s    self var: #s declareC: 'char *s'.    self cCode: 'printf("%s", s)'.! !Text comment:'I represent a String that has been marked with abstract changes in character appearance. Actual display is performed in the presence of a TextStyle which indicates, for each abstract code, an actual font to be used.  A Text associates a set (Array actually) of TextAttributes with each character in its character string.  These attributes include mainly a font number and possibly some other emphasis.  Font numbers are interpreted relative to a TextStyle, which may be a copy of the default, or some other textStyle stored, along with the text, in a Paragraph.  Since most characters have the same attributes as their neighbors, the attributes are stored in a RunArray for efficiency.'!!Text methodsFor: 'accessing'!rangeOf: attribute startingAt: index    "This is stupid, slow code, but it works"    | start stop |    start _ index.    [start > 1 and: [(self attributesAt: start-1) includes: attribute]]        whileTrue: [start _ start - 1].    stop _ index-1.    [stop < self size and: [(self attributesAt: stop+1) includes: attribute]]        whileTrue: [stop _ stop + 1].    ^ start to: stop! !!Text methodsFor: 'comparing'!= other    ^ other isText        ifTrue:    [string = other string and: [runs = other asText runs]]        ifFalse: [false]! !!Text methodsFor: 'comparing'!isText    ^ true! !!Text methodsFor: 'copying'!copy    ^ self class new setString: string copy setRuns: runs copy! !!Text methodsFor: 'emphasis'!addAttribute: att     ^ self addAttribute: att from: 1 to: self size! !!Text methodsFor: 'emphasis'!addAttribute: att from: start to: stop     "Set the attribute for characters in the interval start to stop."    runs _  runs copyReplaceFrom: start to: stop            with: ((runs copyFrom: start to: stop)                mapValues:                [:attributes | Text addAttribute: att toArray: attributes])! !!Text methodsFor: 'emphasis'!allBold     "Force this whole text to be bold."    string size = 0 ifTrue: [^self].    self makeBoldFrom: 1 to: string size! !!Text methodsFor: 'emphasis'!attributesAt: characterIndex     "Answer the code for characters in the run beginning at characterIndex."    | attributes |    self size = 0        ifTrue: [^ Array with: (TextFontChange new fontNumber: 1)].  "null text tolerates access"    attributes _ runs at: characterIndex.    ^ attributes    ! !!Text methodsFor: 'emphasis'!findAttribute: att    "Return a collection of intervals being those over which the given attribute has been asserted"    | ranges |    ranges _ OrderedCollection new.    self runsDoStartStopAndAttributes:        [:start :stop :attributes |        (attributes includes: att) ifTrue: [ranges add: (start to: stop)]].    ^ ranges! !!Text methodsFor: 'emphasis'!fontNumberAt: characterIndex     "Answer the fontNumber for characters in the run beginning at characterIndex."    | attributes fontNumber |    self size = 0 ifTrue: [^1].    "null text tolerates access"    attributes _ runs at: characterIndex.    fontNumber _ 1.    attributes do: [:att | (att isMemberOf: TextFontChange) ifTrue: [fontNumber _ att fontNumber]].    ^ fontNumber    ! !!Text methodsFor: 'emphasis'!makeBoldFrom: start to: stop    ^ self addAttribute: TextEmphasis bold from: start to: stop! !!Text methodsFor: 'emphasis'!removeAttribute: att from: start to: stop     "Remove the attribute over the interval start to stop."    runs _  runs copyReplaceFrom: start to: stop            with: ((runs copyFrom: start to: stop)                mapValues:                [:attributes | attributes copyWithout: att])! !!Text methodsFor: 'private'!runsDoStartStopAndAttributes: doBlock    "Go through all runs, supplying start and stop indices as well as the array of attributes for each run"    | start len stop |    start _ 1.    [start <= self size]        whileTrue:        [len _ self runLengthFor: start.        stop _ start + len - 1.        doBlock value: start value: stop value: (self attributesAt: start).        start _ stop + 1]! !!Text class methodsFor: 'class initialization'!initialize    "Text initialize"    "Initialize constants shared by classes associated with text display."    TextConstants at: #CaretForm put:                (Form extent: 16@5                    fromArray: #(2r001100e26 2r001100e26 2r011110e26 2r111111e26 2r110011e26)                    offset: -3@0).    self initTextConstants! !!Text class methodsFor: 'class initialization'!initTextConstants     "Initialize constants shared by classes associated with text display, e.g.,     Space, Tab, Cr, Bs, ESC."        "1/24/96 sw: in exasperation and confusion, changed cmd-g mapping from 231 to 232 to see if I could gain any relief?!!"    | letter varAndValue tempArray width |    "CtrlA..CtrlZ, Ctrla..Ctrlz"    letter _ $A.     #(        212 230 228 196 194 226 241 243 214 229 200 217 246             245 216 202 210 239 211 240 197 198 209 215 242 231             1 166 228 132 130 12 232 179 150 165 136 153 182             14 15 138 17 18 19 11 21 134 145 151 178 167 ) do:        [:kbd |        TextConstants at: ('Ctrl', letter asSymbol) asSymbol put: kbd asCharacter.        letter _ letter == $Z ifTrue: [$a] ifFalse: [(letter asciiValue + 1) asCharacter]].    varAndValue _ #(        Space    32        Tab        9        CR        13        Enter    3        BS        8        BS2        158        ESC        160        Clear     173    ).    varAndValue size odd ifTrue: [self notify: 'unpaired text constant'].    (2 to: varAndValue size by: 2) do:        [:i | TextConstants at: (varAndValue at: i - 1) put: (varAndValue at: i) asCharacter].    varAndValue _ #(        CtrlDigits             (159 144 143 128 127 129 131 180 149 135)        CtrlOpenBrackets    (201 7 218 249 219 15)            "lparen gottn by ctrl-_ = 201; should be 213 but can't type that on Mac"            "location of non-character stop conditions"        EndOfRun    257        CrossedX    258            "values for alignment"        LeftFlush    0        RightFlush    1        Centered    2        Justified    3            "subscripts for a marginTabsArray tuple"        LeftMarginTab    1        RightMarginTab    2            "font faces"        Basal    0        Bold    1        Italic    2            "in case font doesn't have a width for space character"            "some plausible numbers-- are they the right ones?"        DefaultSpace            4        DefaultTab                24        DefaultLineGrid            16        DefaultBaseline            12        DefaultFontFamilySize    3    "basal, bold, italic"    ).    varAndValue size odd ifTrue: [self notify: 'unpaired text constant'].    (2 to: varAndValue size by: 2) do:        [:i | TextConstants at: (varAndValue at: i - 1) put: (varAndValue at: i)].    TextConstants at: #DefaultRule    put: Form over.    TextConstants at: #DefaultMask    put: Color black.    width _ Display width max: 720.    tempArray _ Array new: width // DefaultTab.    1 to: tempArray size do:        [:i | tempArray at: i put: DefaultTab * i].    TextConstants at: #DefaultTabsArray put: tempArray.    tempArray _ Array new: (width // DefaultTab) // 2.    1 to: tempArray size do:        [:i | tempArray at: i put: (Array with: (DefaultTab*i) with: (DefaultTab*i))].    TextConstants at: #DefaultMarginTabsArray put: tempArray."Text initTextConstants "! !!Text class methodsFor: 'instance creation'!fromString: aString     "Answer an instance of me whose characters are those of the argument,     aString."    ^self string: aString attribute: (TextFontChange fontNumber: 1)! !!Text class methodsFor: 'instance creation'!fromUser    "Answer an instance of me obtained by requesting the user to type some     characters into a prompter (a FillInTheBlank object)."    FillInTheBlank        request: 'Type text followed by carriage return'        displayAt: (50@ Display boundingBox height//2)        centered: false        action: [:result]        initialAnswer: ''.    ^self fromString: result! !!Text class methodsFor: 'instance creation'!streamContents: blockWithArg     | stream |    stream _ TextStream on: (self new: 400).    blockWithArg value: stream.    ^ stream contents! !!Text class methodsFor: 'instance creation'!string: aString attribute: att    "Answer an instance of me whose characters are aString.    att is a TextAttribute."    ^self string: aString attributes: (Array with: att)! !!Text class methodsFor: 'instance creation'!string: aString attributes: atts    "Answer an instance of me whose characters are those of aString.    atts is an array of TextAttributes."    ^self string: aString runs: (RunArray new: aString size withAll: atts)! !!Text class methodsFor: 'instance creation'!string: aString emphasis: emphasis    "This is an old method that is mainly used by old applications"    emphasis isNumber ifTrue:        [self halt: 'Numeric emphasis is not supported in Squeak'.        "But if you proceed, we will do our best to give you what you want..."        ^ self string: aString runs: (RunArray new: aString size withAll:             (Array with: (TextFontChange new fontNumber: emphasis)))].    ^ self string: aString attributes: emphasis! !!Text class methodsFor: 'private'!addAttribute: att toArray: others     "Add a new text attribute to an existing set"    ^ Array streamContents:        [:strm | others do:            [:other | (att dominates: other) ifFalse: [strm nextPut: other]].        att set ifTrue: [strm nextPut: att]]! !!TextAction methodsFor: 'as yet unclassified'!actOnClickFor: anObject    "Note: evalString gets evaluated IN THE CONTEXT OF anObject     -- meaning that self and all instVars are accessible"    Compiler evaluate: evalString for: anObject logged: false.    ^ true! !!TextAction methodsFor: 'as yet unclassified'!emphasizeScanner: scanner    "Set the emphasis for text display"    scanner textColor: Color cyan! !!TextAction methodsFor: 'as yet unclassified'!evalString: str    evalString _ str! !!TextAction methodsFor: 'as yet unclassified'!mayActOnClick    ^ true! !!TextAction class methodsFor: 'as yet unclassified'!evalString: str    ^ self new evalString: str! !!TextAttribute methodsFor: 'as yet unclassified'!actOnClickFor: model    "Subclasses may override to provide, eg, hot-spot actions"    ^ false! !!TextAttribute methodsFor: 'as yet unclassified'!dominates: another    "Subclasses may override condense multiple attributes"    ^ false! !!TextAttribute methodsFor: 'as yet unclassified'!emphasizeScanner: scanner    "Subclasses may override to set, eg, font, color, etc"! !!TextAttribute methodsFor: 'as yet unclassified'!mayActOnClick    "Subclasses may override to provide, eg, hot-spot actions"    ^ false! !!TextAttribute methodsFor: 'as yet unclassified'!oldEmphasisCode: default    "Allows running thorugh possibly multiple attributes    and getting the emphasis out of any that has an emphasis (font number)"    ^ default! !!TextAttribute methodsFor: 'as yet unclassified'!set    "Respond true to include this attribute (as opposed to, eg, a bold    emphasizer that is clearing the property"    ^ true! !!TextCollector methodsFor: 'character writing' stamp: 'sw 1/31/96'!bs    "Backspace the Transcript.  Put in at Alan's request "    "Transcript bs"    contents _ contents allButLast.    self changed: #update! !!TextCollectorController methodsFor: 'entry control' stamp: 'di 8/29/97 19:20'!appendEntry    "Append the text in the model's writeStream to the editable text. "        view topView isCollapsed        ifTrue: [paragraph text                replaceFrom: 1                to: paragraph text size                with: model contents asText]        ifFalse:             [self deselect.            paragraph text size > model characterLimit ifTrue:                 [paragraph removeFirstChars: paragraph text size - (model characterLimit // 2)].            self selectWithoutComp: paragraph text size + 1.            self replaceSelectionWith: model nextEntry asText.            self selectWithoutComp: paragraph text size + 1.            model contents: paragraph text]! !!TextCollectorController methodsFor: 'private' stamp: 'di 8/30/97 11:21'!doOccluded: actionBlock    | paneRect rectSet bottomStrip |    view topView isCollapsed ifTrue: [^ actionBlock value].    paneRect _ paragraph clippingRectangle.    rectSet _ self visibleAreas.    paragraph withClippingRectangle: (paneRect withHeight: 0)        do: [actionBlock value.            self scrollIn: paneRect].    bottomStrip _ paneRect withTop: paragraph compositionRectangle bottom + 1.    rectSet do:        [:rect |        (bottomStrip intersects: rect) ifTrue:            ["The subsequent displayOn should clear this strip but it doesnt"            Display fill: (bottomStrip intersect: rect)                    fillColor: paragraph backgroundColor].        paragraph withClippingRectangle: rect                do: [paragraph displayOn: Display]]! !!TextCollectorController methodsFor: 'private' stamp: 'di 8/30/97 11:34'!scrollIn: scrollRect    "Altered from selectAndScroll so can use with null clipRect"    "Scroll until the selection is in the view and then highlight it."    | deltaY |    deltaY _ stopBlock top - scrollRect top.    deltaY >= 0         ifTrue: [deltaY _ stopBlock bottom - scrollRect bottom max: 0].                        "check if stopIndex below bottom of scrollRect"    deltaY ~= 0         ifTrue: [self scrollBy: (deltaY abs + paragraph lineGrid - 1) * deltaY sign]! !!TextCollectorController methodsFor: 'private' stamp: 'di 9/28/97 15:08'!visibleAreas    "Transcript dependents last controller visibleAreas"    | visibleAreas rect remnants myTopController |    myTopController _ self view topView controller.    visibleAreas _ Array with: view insetDisplayBox.    myTopController view uncacheBits.    ScheduledControllers scheduledWindowControllers do:        [:c | c == myTopController ifTrue: [^ visibleAreas].        rect _ c view windowBox.        remnants _ OrderedCollection new.        visibleAreas do: [:a | remnants addAll: (a areasOutside: rect)].        visibleAreas _ remnants].    ^ visibleAreas! !!TextCollectorView methodsFor: 'updating' stamp: 'di 8/29/97 18:26'!update: aParameter    "Transcript cr; show: 'qwre'.    Transcript clear."    aParameter == #appendEntry ifTrue:        [^ controller doOccluded: [controller appendEntry]].    aParameter == #update ifTrue:        [^ controller doOccluded:                [controller changeText: model contents asText]].    ^ super update: aParameter! !!TextColor methodsFor: 'as yet unclassified'!= other     ^ (other isMemberOf: self class)         and: [other color = color]! !!TextColor methodsFor: 'as yet unclassified'!color    ^ color! !!TextColor methodsFor: 'as yet unclassified'!color: aColor    color _ aColor! !!TextColor methodsFor: 'as yet unclassified'!dominates: other    ^ other isMemberOf: self class! !!TextColor methodsFor: 'as yet unclassified'!emphasizeScanner: scanner    "Set the emphasis for text display"    scanner textColor: color! !!TextColor methodsFor: 'as yet unclassified'!printOn: strm    super printOn: strm.    strm nextPutAll: ' code: '; print: color! !!TextColor class methodsFor: 'as yet unclassified'!black    ^ self new color: Color black! !!TextColor class methodsFor: 'as yet unclassified'!blue    ^ self new color: Color blue! !!TextColor class methodsFor: 'as yet unclassified'!color: aColor    ^ self new color: aColor! !!TextColor class methodsFor: 'as yet unclassified'!cyan    ^ self new color: Color cyan! !!TextColor class methodsFor: 'as yet unclassified'!green    ^ self new color: Color green! !!TextColor class methodsFor: 'as yet unclassified'!magenta    ^ self new color: Color magenta! !!TextColor class methodsFor: 'as yet unclassified'!red    ^ self new color: Color red! !!TextColor class methodsFor: 'as yet unclassified'!yellow    ^ self new color: Color yellow! !!TextEmphasis methodsFor: 'as yet unclassified'!= other     ^ (other isMemberOf: self class)         and: [other emphasisCode = emphasisCode]! !!TextEmphasis methodsFor: 'as yet unclassified'!dominates: other    (emphasisCode = 0 and: [other isKindOf: TextAction]) ifTrue: [^ true].    ^ (other isMemberOf: self class)        and: [emphasisCode = 0            or: [emphasisCode = other emphasisCode]]! !!TextEmphasis methodsFor: 'as yet unclassified'!emphasisCode    ^ emphasisCode! !!TextEmphasis methodsFor: 'as yet unclassified'!emphasisCode: int    emphasisCode _ int.    setMode _ true! !!TextEmphasis methodsFor: 'as yet unclassified'!emphasizeScanner: scanner    "Set the emphasist for text display"    scanner addEmphasis: emphasisCode! !!TextEmphasis methodsFor: 'as yet unclassified'!printOn: strm    super printOn: strm.    strm nextPutAll: ' code: '; print: emphasisCode! !!TextEmphasis methodsFor: 'as yet unclassified'!set    ^ setMode and: [emphasisCode ~= 0]! !!TextEmphasis methodsFor: 'as yet unclassified'!turnOff    setMode _ false! !!TextEmphasis class methodsFor: 'as yet unclassified'!bold    ^ self new emphasisCode: 1! !!TextEmphasis class methodsFor: 'as yet unclassified'!italic    ^ self new emphasisCode: 2! !!TextEmphasis class methodsFor: 'as yet unclassified'!narrow    ^ self new emphasisCode: 8! !!TextEmphasis class methodsFor: 'as yet unclassified'!normal    ^ self new emphasisCode: 0! !!TextEmphasis class methodsFor: 'as yet unclassified'!struckOut    ^ self new emphasisCode: 16! !!TextEmphasis class methodsFor: 'as yet unclassified'!underlined    ^ self new emphasisCode: 4! !!TextFontChange methodsFor: 'as yet unclassified'!= other     ^ (other isMemberOf: self class)         and: [other fontNumber = fontNumber]! !!TextFontChange methodsFor: 'as yet unclassified'!dominates: other    ^ other isMemberOf: self class! !!TextFontChange methodsFor: 'as yet unclassified'!emphasizeScanner: scanner    "Set the font for text display"    scanner setFont: fontNumber! !!TextFontChange methodsFor: 'as yet unclassified'!fontNumber    ^ fontNumber! !!TextFontChange methodsFor: 'as yet unclassified'!fontNumber: int    fontNumber _ int! !!TextFontChange methodsFor: 'as yet unclassified'!printOn: strm    super printOn: strm.    strm nextPutAll: ' font: '; print: fontNumber! !!TextFontChange class methodsFor: 'as yet unclassified'!font1    ^ self new fontNumber: 1! !!TextFontChange class methodsFor: 'as yet unclassified'!font2    ^ self new fontNumber: 2! !!TextFontChange class methodsFor: 'as yet unclassified'!font3    ^ self new fontNumber: 3! !!TextFontChange class methodsFor: 'as yet unclassified'!font4    ^ self new fontNumber: 4! !!TextFontChange class methodsFor: 'as yet unclassified'!fontNumber: n    ^ self new fontNumber: n! !!TextFontReference methodsFor: 'as yet unclassified'!emphasizeScanner: scanner    "Set the actual font for text display"    scanner setActualFont: font! !!TextFontReference methodsFor: 'as yet unclassified'!toFont: aFont    font _ aFont! !!TextFontReference class methodsFor: 'as yet unclassified'!toFont: aFont    ^ self new toFont: aFont! !!TextLineInterval methodsFor: 'accessing'!baseline    ^ baseline! !!TextLineInterval methodsFor: 'accessing'!lineHeight    ^ lineHeight! !!TextLineInterval methodsFor: 'private'!lineHeight: height baseline: ascent    lineHeight _ height.    baseline _ ascent! !!TextLineInterval class methodsFor: 'instance creation'!start: startInteger stop: stopInteger internalSpaces: spacesInteger paddingWidth: padWidthInteger    "Answer an instance of me with the arguments as the start, stop points,     number of spaces in the line, and width of the padding."    | newSelf |    newSelf _ super from: startInteger to: stopInteger by: 1.    ^newSelf internalSpaces: spacesInteger paddingWidth: padWidthInteger! !!TextLinkToImplementors methodsFor: 'as yet unclassified'!actOnClickFor: modelIgnored    Smalltalk browseAllImplementorsOf: selector.    ^ true! !!TextLinkToImplementors methodsFor: 'as yet unclassified'!emphasizeScanner: scanner    "Set the emphasis for text display"    scanner textColor: Color red! !!TextLinkToImplementors methodsFor: 'as yet unclassified'!selector: sel    selector _ sel! !!TextLinkToImplementors class methodsFor: 'as yet unclassified'!of: selector    ^ self new selector: selector! !TextMorph comment:'TextMorphs support display of text with emphasis.  They also support reasonable text-editing capabilities, as well as imbedded hot links, and the ability to anchor submorphs to a given character in the text.  The latter is accomplished by first imbedding a morph, then making a selection, and finally asserting /set anchor/ to the imbedded morph.  Note that if you anchor to a carriage return, the morph will only move up and down.  Anchoring to other characters may cause horizontal tracking as well.'!!TextMorph methodsFor: 'initialization' stamp: 'di 9/30/97 09:25'!initialize    super initialize.    color _ Color black.    textStyle _ TextStyle default copy.    wrapFlag _ true.! !!TextMorph methodsFor: 'accessing'!contents    ^ text! !!TextMorph methodsFor: 'accessing' stamp: 'di 9/30/97 15:48'!contents: stringOrText    ^ self contentsAsIs: stringOrText! !!TextMorph methodsFor: 'accessing' stamp: 'di 9/30/97 15:48'!contentsAsIs: stringOrText    "Accept new text contents with line breaks only as in the text.    Fit my width and height to the result."    wrapFlag _ false.    self newContents: stringOrText! !!TextMorph methodsFor: 'accessing' stamp: 'di 9/30/97 09:51'!contentsWrapped: stringOrText    "Accept new text contents.  Lay it out, wrapping within my current width.    Then fit my height to the result."    wrapFlag _ true.    self newContents: stringOrText! !!TextMorph methodsFor: 'accessing' stamp: 'di 9/29/97 11:47'!copyRecordingIn: dict    "Overridden to copy deeper text structure."    ^ (super copyRecordingIn: dict)        text: text copy textStyle: textStyle copy! !!TextMorph methodsFor: 'accessing' stamp: 'di 9/30/97 15:37'!newContents: stringOrText    "Accept new text contents."    | newText |    newText _ stringOrText asText.    text = newText ifTrue: [^ self].  "No substantive change"    text _ newText.    self releaseParagraph.  "update the paragraph cache"    self paragraph.  "re-instantiate to set bounds"! !!TextMorph methodsFor: 'alignment' stamp: 'di 9/29/97 13:21'!centered     textStyle centered.    self changed! !!TextMorph methodsFor: 'alignment' stamp: 'di 9/29/97 13:22'!justified     textStyle justified.    self changed! !!TextMorph methodsFor: 'alignment' stamp: 'di 9/29/97 13:21'!leftFlush     textStyle leftFlush.    self changed! !!TextMorph methodsFor: 'alignment' stamp: 'di 9/29/97 13:22'!rightFlush     textStyle rightFlush.    self changed! !!TextMorph methodsFor: 'drawing' stamp: 'di 10/2/97 10:30'!drawOn: aCanvas    | selectionRects |    self hasFocus ifTrue:        [aCanvas fillRectangle: bounds color: Color white.        selectionRects _ editor selectionRects.        (selectionRects size = 1 and: [selectionRects first width = 1])            ifTrue: [aCanvas image: CaretForm                            at: (selectionRects first bottomLeft + CaretForm offset)]            ifFalse: [selectionRects do:                        [:rect | aCanvas fillRectangle: rect color: SelectionColor]]].    aCanvas paragraph: self paragraph bounds: bounds color: color.! !!TextMorph methodsFor: 'drawing' stamp: 'di 10/2/97 09:13'!selectionColor    ^ (Color r: 0.4 g: 1.0 b: 0)! !!TextMorph methodsFor: 'editing' stamp: 'di 9/30/97 10:26'!acceptContents    "The message is sent when the user hits enter or Cmd-S. Accept the current contents and end editing. This default implementation does nothing."    self updateFromParagraph! !!TextMorph methodsFor: 'editing' stamp: 'di 9/30/97 10:27'!chooseAlignment    self installEditor changeAlignment.    self updateFromParagraph! !!TextMorph methodsFor: 'editing' stamp: 'di 9/30/97 10:27'!chooseEmphasis    self installEditor changeEmphasis.    self updateFromParagraph! !!TextMorph methodsFor: 'editing' stamp: 'di 9/30/97 10:28'!chooseFont    self installEditor offerFontMenu.    self updateFromParagraph! !!TextMorph methodsFor: 'editing' stamp: 'di 9/30/97 10:28'!chooseStyle    self installEditor changeStyle.    self updateFromParagraph! !!TextMorph methodsFor: 'editing' stamp: 'di 9/29/97 12:34'!handlesMouseDown: evt    ^ self uncoveredAt: evt cursorPoint! !!TextMorph methodsFor: 'editing' stamp: 'di 9/29/97 11:46'!hasFocus    ^ editor ~~ nil! !!TextMorph methodsFor: 'editing' stamp: 'di 9/29/97 11:58'!keyboardFocusChange: aBoolean    aBoolean        ifTrue: ["A hand is wanting to send us characters..."                self hasFocus ifFalse: [self installEditor.                                        self changed]]        ifFalse: ["A hand has clicked elsewhere...".                ((self world hands collect: [:h | h keyboardFocus]) includes: self)                    ifFalse: [self releaseEditor.                            self changed]].! !!TextMorph methodsFor: 'editing'!keyStroke: evt    "Handle a keystroke event."    self installEditor.    editor sensor: (KeyboardBuffer new startingEvent: evt).  "Make a version that takes an event"    editor readKeyboard.    self updateFromParagraph! !!TextMorph methodsFor: 'editing' stamp: 'di 10/2/97 10:32'!mouseDown: evt    "Make this TextMorph be the keyboard input focus, if it isn't already, and repond to the text selection gesture."    evt hand newKeyboardFocus: self.  "This will install editor if nil"    evt hand showTemporaryCursor: Cursor blank.    editor mouseDown: evt.    self changed! !!TextMorph methodsFor: 'editing' stamp: 'di 9/29/97 12:34'!mouseMove: evt    evt redButtonPressed        ifTrue: [editor mouseMove: evt.                self changed].    ! !!TextMorph methodsFor: 'editing' stamp: 'di 10/2/97 10:32'!mouseUp: evt    editor mouseUp: evt.    evt hand showTemporaryCursor: nil.    self changed! !!TextMorph methodsFor: 'editing'!xeqLinkText: sourceString withParameter: param    self confirm: 'xeqLinkText:' asText allBold , sourceString asText! !!TextMorph methodsFor: 'printing'!fullPrintOn: aStream    aStream nextPutAll: '('.    super fullPrintOn: aStream.    aStream nextPutAll: ') contents: '; print: text! !!TextMorph methodsFor: 'anchors' stamp: 'di 9/29/97 18:09'!anchor: aMorph    "Set an anchor for this morph in the current text selection"    | anchor index |    editor ifNil: [^ self halt].  "No can do"    anchor _ TextMorphAnchor new            anchoredObject: aMorph            location: (self paragraph characterBlockForIndex: editor selectionInterval first) topLeft                        - self position.    index _ editor selectionInterval first.    self removeAllAnchorsTo: aMorph.    text addAttribute: anchor from: index to: index! !!TextMorph methodsFor: 'anchors' stamp: 'jm 9/28/97 19:01'!anchorMorph: evt    | root |    root _ evt hand argumentOrNil.    root ifNil: [^ self].    evt hand selectSubmorphToOperateOn: self selector: #anchor:.! !!TextMorph methodsFor: 'anchors'!removeAllAnchors    submorphs do: [:m | self removeAllAnchorsTo: m]! !!TextMorph methodsFor: 'anchors'!removeAllAnchorsTo: aMorph    "Remove any anchor of this morph"    | anchor |    anchor _ TextMorphAnchor new anchoredObject: aMorph.    (text findAttribute: anchor) do:  "Remove any old anchor fragments"        [:range | text removeAttribute: anchor from: range first to: range last]! !!TextMorph methodsFor: 'anchors' stamp: 'di 9/29/97 18:16'!updateAnchors    | anchors ranges |    anchors _ OrderedCollection new.    text runsDoStartStopAndAttributes:        [:start :stop :attributes |        attributes do: [:att | (att isMemberOf: TextMorphAnchor) ifTrue: [anchors add: att]]].    anchors isEmpty ifTrue: [^ self].    anchors do:        [:a |        ranges _ text findAttribute: a.        "Update anchor location"        a newLocation: (self paragraph characterBlockForIndex: ranges first first) topLeft                            - self position.        ranges size > 1 ifTrue:            [ranges allButFirst do:  "Remove any other fragmentary references"                [:range | text removeAttribute: a from: range first to: range last]]].    self layoutChanged! !!TextMorph methodsFor: 'geometry' stamp: 'di 9/30/97 15:36'!extent: aPoint    self releaseEditor.    self releaseParagraph.  "invalidate the paragraph cache"    super extent: (aPoint max: 20@20).    self fit! !!TextMorph methodsFor: 'geometry' stamp: 'di 9/29/97 12:55'!privateMoveBy: delta    self releaseEditor.    super privateMoveBy: delta.! !!TextMorph methodsFor: 'geometry' stamp: 'di 9/30/97 15:36'!privateOwner: aMorph    self releaseParagraph.  "invalidate the paragraph cache"    super privateOwner: aMorph! !!TextMorph methodsFor: 'menu' stamp: 'di 9/30/97 10:15'!addCustomMenuItems: aCustomMenu hand: aHandMorph    (submorphs isEmpty and: [editor ~~nil]) ifFalse:        [aCustomMenu add: 'set anchor' action: #anchorMorph:].    aCustomMenu add: 'remove all anchors' action: #removeAllAnchors.    aCustomMenu add: 'set font...' action: #chooseFont.    aCustomMenu add: 'set style...' action: #chooseStyle.    aCustomMenu add: 'set alignment...' action: #chooseAlignment.! !!TextMorph methodsFor: 'private' stamp: 'di 9/30/97 15:25'!fit    "Adjust bounds vertically to fit the text."    | height extent |    wrapFlag ifTrue:        [height _ self paragraph height.        height ~= bounds height ifTrue: [super extent: bounds width @ height]]        ifFalse:        [extent _ self paragraph extent.        extent ~= bounds extent ifTrue: [super extent: extent]].    self updateAnchors.    self changed! !!TextMorph methodsFor: 'private' stamp: 'di 10/2/97 11:17'!installEditor    "Install an editor for my paragraph.  This constitutes 'hasFocus'."    | editView |    editor ifNotNil: [^ editor].    editor _ TextMorphEditor new morph: self.    editView _ DisplayTextView new model: self paragraph controller: editor.    editView window: self bounds viewport: self bounds.    editor changeParagraph: self paragraph.    ^ editor! !!TextMorph methodsFor: 'private'!paragraph    "Paragraph instantiation is lazy -- create it only when needed"    | compWidth fullWidth |    paragraph ifNotNil: [^ paragraph].    text ifNil: [text _ 'Text' asText allBold].  "Default contents"    "...Code here to recreate the paragraph..."    compWidth _ wrapFlag ifTrue: [bounds width] ifFalse: [999999].    paragraph _ Paragraph basicNew.    fullWidth _ paragraph setWithText: text style: textStyle            compositionRectangle: (bounds topLeft extent: compWidth @ 999999)            clippingRectangle: bounds             foreColor: color backColor: Color white.    wrapFlag ifFalse:        [paragraph compositionRectangle:            (paragraph compositionRectangle withWidth: fullWidth)].    self fit.    ^ paragraph! !!TextMorph methodsFor: 'private' stamp: 'di 10/1/97 19:48'!prepareToBeSaved    self releaseEditor; releaseParagraph! !!TextMorph methodsFor: 'private'!releaseEditor    "Release the editor for my paragraph.  This morph no longer 'hasFocus'."    editor ifNotNil:        [self paragraph release.        editor _ nil].self releaseParagraph "THIS IS A TEST!!"! !!TextMorph methodsFor: 'private' stamp: 'di 9/30/97 15:35'!releaseParagraph    "Paragraph instantiation is lazy -- it will be created only when needed"    paragraph ifNotNil:        [paragraph release.        paragraph _ nil]! !!TextMorph methodsFor: 'private' stamp: 'di 10/2/97 10:42'!text: t textStyle: s    "Private -- for use only in morphic duplication"    text _ t.    textStyle _ s! !!TextMorph methodsFor: 'private' stamp: 'di 10/2/97 01:20'!updateFromParagraph    paragraph ifNil: [^ self].    wrapFlag ifNil: [wrapFlag _ true].    text _ paragraph text.    textStyle _ paragraph textStyle.    self fit! !!TextMorph methodsFor: 'private' stamp: 'di 10/2/97 11:14'!updateReferencesUsing: refDict    | anchors range new |    super updateReferencesUsing: refDict.    "Update any anchors in the text of a newly copied morph"    anchors _ IdentityDictionary new.    text runsDoStartStopAndAttributes:        [:start :stop :attributes |        attributes do: [:att | (att isMemberOf: TextMorphAnchor)                            ifTrue: [anchors at: att put: (start to: stop)]]].    anchors isEmpty ifTrue: [^ self].    anchors keysDo:        [:old |  range _ anchors at: old.        text removeAttribute: old from: range first to: range last.        new _ TextMorphAnchor new anchoredObject: (refDict at: old anchoredObject)                                location: old location.        text addAttribute: new from: range first to: range last].    self layoutChanged "for good measure"! !!TextMorph methodsFor: 'object fileIn' stamp: 'di 10/1/97 19:47'!convertbosfceptthpeh0: varDict bosfcepttwpe0: smartRefStrm    "These variables are automatically stored into the new instance ('textStyle' 'text' 'paragraph' 'editor' ).    This method is for additional changes. Use statements like (foo _ varDict at: 'foo')."    "Be sure to to fill in ('wrapFlag' ) and deal with the information in ('hasFocus' 'hideSelection' )"    wrapFlag _ true.    editor _ nil.    self updateFromParagraph; releaseParagraph.! !!TextMorph class methodsFor: 'as yet unclassified' stamp: 'di 10/2/97 10:30'!initialize    "TextMorph initialize"    "Initialize constants shared by classes associated with text display."    SelectionColor _ Color r: 0.4 g: 1.0 b: 0.    CaretForm _ (ColorForm extent: 16@5                    fromArray: #(2r001100e26 2r001100e26 2r011110e26 2r111111e26 2r110011e26)                    offset: -2@0)                    colors: (Array with: Color transparent with: SelectionColor)! !TextMorphAnchor comment:'A TextMorphAnchor is a non-visual attribute of text, whose sole purpose is to associate an anchoredObject with a range of text (typically a single character) through the existing text attribute mechanism.  The location is typically relative to the position of a textMorph.  The anchor constraint is maintained by propagating the effect of newLocation: to the anchoredObject.'!!TextMorphAnchor methodsFor: 'all'!= other    "Any anchor matches another anchor to the same object.    There should only be one anchor for any given object, but sometimes    a dummy may be created just for the purpose of searching for a match,    as in TextMorph>>removeAllAnchorsTo:."    ^ self class == other class and: [anchoredObject == other anchoredObject]! !!TextMorphAnchor methodsFor: 'all'!anchoredObject    ^ anchoredObject! !!TextMorphAnchor methodsFor: 'all'!anchoredObject: obj    "Dummy coordinates provide an object to match"    ^ self anchoredObject: obj location: 0@0! !!TextMorphAnchor methodsFor: 'all'!anchoredObject: obj location: loc    anchoredObject _ obj.    location _ loc! !!TextMorphAnchor methodsFor: 'all' stamp: 'di 10/2/97 11:13'!location    ^ location! !!TextMorphAnchor methodsFor: 'all'!newLocation: newLocation    newLocation = location ifTrue: [^ self].    anchoredObject position: anchoredObject position - location + newLocation.    location _ newLocation! !!TextMorphEditor methodsFor: 'all'!accept    "Save the current text of the text being edited as the current acceptable version for purposes of canceling.  Allow my morph to take appropriate action"    super accept.    morph acceptContents! !!TextMorphEditor methodsFor: 'all'!changeEmphasis: characterStream     "May be a request to create a link (Cmd-6).  Intercept if so, else call super"    | keyCode attribute index |    "Test if it's really the droids we're looking for..."    keyCode _ ('0123456789-=' indexOf: sensor keyboardPeek ifAbsent: [1]) - 1.    keyCode ~= 6 ifTrue: [^ super changeEmphasis: characterStream "handle other keys"].    sensor keyboard  "Yes, it is Cmd-6;  consume the command character".    index _ (PopUpMenu labelArray: #(black magenta red yellow green blue active)                            lines: #(6)) startUp.    index = 0 ifTrue: [^ true].    index < 7 ifTrue:        [attribute _ TextColor color:                (Color perform: (#(black magenta red yellow green blue cyan) at: index))].    index = 7 ifTrue:        [attribute _ TextMorphHotLink new sourceString: self selection asString                    targetMorph: morph                    parameterString: (FillInTheBlank                                        request: 'Secondary text for this link (or CR)...'                                        initialAnswer: '')].    self replaceSelectionWith: (self selection addAttribute: attribute).    ^ true! !!TextMorphEditor methodsFor: 'all'!controlInitialize    "super controlInitialize."  "do not display the scroll bar"    self recomputeInterval.    self initializeSelection.    beginTypeInBlock _ nil.! !!TextMorphEditor methodsFor: 'all' stamp: 'di 9/25/97 09:57'!cursorPointFrom: evt    ^ evt cursorPoint + morph world viewBox topLeft! !!TextMorphEditor methodsFor: 'all'!morph: aMorph    "Install a link back to the morph being editted (esp for text links)"    morph _ aMorph! !!TextMorphEditor methodsFor: 'all'!mouseDown: evt     "An attempt to break up the old processRedButton code into threee phases"    | clickPoint |    oldInterval _ startBlock stringIndex to: stopBlock stringIndex - 1.    clickPoint _ evt cursorPoint.    (paragraph clickAt: clickPoint for: nil) ifTrue: [^ self].    self closeTypeIn.  "probably not necess"    sensor leftShiftDown        ifFalse:            [stopBlock _ startBlock _ pivotBlock _                paragraph characterBlockAtPoint: clickPoint]        ifTrue:            [(self characterBlockAtPoint: clickPoint) <= startBlock            ifTrue: [stopBlock _ startBlock.                    pivotBlock _ stopBlock]            ifFalse: [startBlock _  stopBlock.                    pivotBlock _ startBlock]].! !!TextMorphEditor methodsFor: 'all'!mouseMove: evt     "An attempt to break up the old processRedButton code into threee phases"    | dragBlock |    dragBlock _ paragraph characterBlockAtPoint: (evt cursorPoint).    dragBlock > pivotBlock        ifTrue: [stopBlock _ dragBlock.  startBlock _ pivotBlock]        ifFalse: [startBlock _ dragBlock.  stopBlock _ pivotBlock]! !!TextMorphEditor methodsFor: 'all' stamp: 'di 9/29/97 12:34'!mouseUp: evt    "An attempt to break up the old processRedButton code into threee phases"    (startBlock = stopBlock         and: [oldInterval = (startBlock stringIndex to: startBlock stringIndex-1)])        ifTrue: [self selectWord].    self setEmphasisHere.    (self isDisjointFrom: oldInterval) ifTrue:        [otherInterval _ oldInterval]! !!TextMorphEditor methodsFor: 'all' stamp: 'di 10/2/97 11:38'!mvcRedisplay    "Ignore mvcRedisplay requests."! !!TextMorphEditor methodsFor: 'all' stamp: 'di 10/2/97 09:08'!scrollBy: ignore     "Ignore scroll requests."! !!TextMorphEditor methodsFor: 'all'!select    "Ignore selection redraw requests."! !!TextMorphEditor methodsFor: 'all' stamp: 'di 9/29/97 12:34'!selectionRects    "Return an array of rectangles comprising the selection"    ^ paragraph selectionRectsFrom: startBlock to: stopBlock! !!TextMorphEditor methodsFor: 'all'!updateMarker    "Ignore scrollbar redraw requests."! !!TextMorphEditor methodsFor: 'all' stamp: 'di 10/1/97 17:00'!zapSelectionWith: aText    "**overridden to inhibit old-style display"    | start stop |    self deselect.    start _ startBlock stringIndex.    stop _ stopBlock stringIndex.    (start = stop and: [aText size = 0]) ifFalse:        [paragraph replaceFrom: start to: stop - 1            with: aText displaying: false.  "** was true in super"        self computeIntervalFrom: start to: start + aText size - 1.        UndoInterval _ otherInterval _ self selectionInterval]! !!TextMorphHotLink methodsFor: 'all'!actOnClickFor: anObject    "MouseDown on this link"    targetMorph xeqLinkText: evalString withParameter: parameterString.    ^ true! !!TextMorphHotLink methodsFor: 'all'!sourceString: str1 targetMorph: morph parameterString: str2    evalString _ str1.    targetMorph _ morph.    parameterString _ str2! !!TextStream methodsFor: 'as yet unclassified'!applyAttribute: att beginningAt: startPos    collection addAttribute: att from: startPos to: self position! !!TextStream methodsFor: 'as yet unclassified'!nextPutAll: aCollection     "Optimized access to get around Text at:Put: overhead"    | n |    n _ aCollection size.    ((aCollection isMemberOf: String) not or: [position + n > writeLimit])        ifTrue: [^ super nextPutAll: aCollection].    collection string        replaceFrom: position+1        to: position + n        with: aCollection        startingAt: 1.    position _ position + n! !!TextStream methodsFor: 'as yet unclassified'!withAttribute: att do: strmBlock    | pos1 val |    pos1 _ self position.    val _ strmBlock value.    collection addAttribute: att from: pos1+1 to: self position.    ^ val! !!TextStyle methodsFor: 'accessing'!centered    alignment _ 2! !!TextStyle methodsFor: 'accessing'!justified    alignment _ 3! !!TextStyle methodsFor: 'accessing'!leading    "Leading (from typographers historical use of extra lead (type metal))    is the extra spacing above and beyond that needed just to accomodate    the various font heights in the set."    ^ leading! !!TextStyle methodsFor: 'accessing'!leading: yDelta    leading _ yDelta! !!TextStyle methodsFor: 'accessing'!leftFlush    alignment _ 0! !!TextStyle methodsFor: 'accessing'!rightFlush    alignment _ 1! !!TextStyle methodsFor: 'fonts and font indexes' stamp: 'tk 6/26/97 14:20'!collectionFromFileNamed: fileName    "Read the file.  It is an Array of StrikeFonts.  File format is the ReferenceStream format.  (Do not use SmartRefStream, it is too smart.  It only writes a DiskProxy!!)   For any fonts with new names, add them to DefaultTextStyle.fontArray.      To write out fonts:         | ff | ff _ ReferenceStream fileNamed: 'new fonts'.        ff nextPut: (TextStyle default fontArray).        ff close.    To read: (TextStyle default collectionFromFileNamed: 'new fonts')*** Do not remove this method *** "    | ff this names |    ff _ ReferenceStream fileNamed: fileName.    this _ ff nextAndClose.    this class == Array ifTrue:            [names _ self fontNames.            this do: [:each | each class == StrikeFont ifTrue:                [(names includes: each name) ifFalse:                    [fontArray _ fontArray copyWith: each]]]].! !!TextStyle methodsFor: 'private'!consolidate    "If this style includes any fonts that are also in the default style,    then replace them with references to the default ones.""    TextStyle allInstancesDo: [:s | s == TextStyle default ifFalse: [s consolidate]]"    | defFonts font |    defFonts _ TextStyle default fontArray.    1 to: fontArray size do:        [:i | font _ fontArray at: i.        1 to: defFonts size do:            [:j | (font name asUppercase copyWithout: $ )            = ((defFonts at: j) name asUppercase copyWithout: $ )            ifTrue: [fontArray at: i put: (defFonts at: j)]]]! !!TextStyle methodsFor: 'private'!gridForFont: fontIndex withLead: leadInteger     "Force whole style to suit one of its fonts. Assumes only one font referred    to by runs."    | font |    font _ self fontAt: fontIndex.    self lineGrid: font height + leadInteger.    self baseline: font ascent.    self leading: leadInteger! !!TextStyle methodsFor: 'private' stamp: 'tk 8/20/96'!newFontArray: anArray    "Currently there is no supporting protocol for changing these arrays. If an editor wishes to implement margin setting, then a copy of the default should be stored with these instance variables.      , Make size depend on first font."    fontArray _ anArray.    lineGrid _ (fontArray at: 1) height + leading.    "For whole family"    baseline _ (fontArray at: 1) ascent + leading.    alignment _ 0.    firstIndent _ 0.    restIndent _ 0.    rightIndent _ 0.    tabsArray _ DefaultTabsArray.    marginTabsArray _ DefaultMarginTabsArray"TextStyle allInstancesDo: [:ts | ts newFontArray: TextStyle default fontArray]."! !!TextStyle methodsFor: 'Disk I/O' stamp: 'tk 5/13/97'!storeDataOn: aDataStream    "Store myself on a DataStream. This is a low-level DataStream/ReferenceStream method. See also objectToStoreOnDataStream.  Need this to share tabsArray and marginTabsArray.  Fonts will take care of themselves.  "    | cntInstVars cntIndexedVars instVars ti tm |    cntInstVars _ self class instSize.    cntIndexedVars _ self basicSize.    instVars _ self class allInstVarNames.    ti _ (instVars indexOf: 'tabsArray').    tm _ (instVars indexOf: 'marginTabsArray').    (ti = 0) | (tm = 0) | (ti > tm) ifTrue: [self error: 'this method is out of date'].    aDataStream        beginInstance: self class        size: cntInstVars + cntIndexedVars.    1 to: ti-1 do:        [:i | aDataStream nextPut: (self instVarAt: i)].    tabsArray == DefaultTabsArray         ifTrue: [aDataStream nextPut: (DiskProxy global: #TextConstants selector: #at:                         args: #(DefaultTabsArray))]        ifFalse: [aDataStream nextPut: tabsArray].    ti+1 to: tm-1 do:        [:i | aDataStream nextPut: (self instVarAt: i)].    marginTabsArray == DefaultMarginTabsArray        ifTrue: [aDataStream nextPut: (DiskProxy global: #TextConstants selector: #at:                         args: #(DefaultMarginTabsArray))]        ifFalse: [aDataStream nextPut: marginTabsArray].    tm+1 to: cntInstVars do:        [:i | aDataStream nextPut: (self instVarAt: i)].    1 to: cntIndexedVars do:        [:i | aDataStream nextPut: (self basicAt: i)]! !!TextStyle class methodsFor: 'instance creation' stamp: 'di 6/16/97 12:31'!changeDefaultFontSizeBy: delta      "TextStyle changeDefaultFontSizeBy: 1"    "This sample method recreates the default textStyle, with font 1 being a size    larger than the smallest.  It then initializes most references in the system    as well, although most windows will have to beclosed and reopened to get the effect."    | allFonts |    allFonts _ TextStyle default fontArray asSortedCollection: [:a :b | a height < b height].    TextConstants at: #DefaultTextStyle put:        (TextStyle fontArray: ((1 to: allFonts size) collect: [:i | allFonts atWrap: i+delta])).    PopUpMenu initialize.  "Change this method for difft menu font"    ListParagraph initialize.  "Change this method for difft ListPane font"    StandardSystemView initialize.  "Change this method for difft Window label font"! !!TextStyle class methodsFor: 'instance creation'!initDefaultFontsAndStyle    "This provides the system with 10 and 12-pt basal fonts.    Bold and italic versions will be automatically generated as needed"    | fontArray |        fontArray _ Array new: 2.    fontArray at: 1 put: (StrikeFont new readFromStrike2: 'NewYork10.sf2').    fontArray at: 2 put: (StrikeFont new readFromStrike2: 'NewYork12.sf2').    TextConstants at: #DefaultTextStyle put:        (TextStyle fontArray: fontArray).    "TextStyle initDefaultFontsAndStyle."! !!TextStyle class methodsFor: 'instance creation'!new    ^ super new leading: 2! !!TGoToNode methodsFor: 'all'!copyTree    ^self class new setLabel: label! !!TGoToNode methodsFor: 'all'!emitCCodeOn: aStream level: level generator: aCodeGen    "Emit a C goto statement."    aStream nextPutAll: 'goto '.    aStream nextPutAll: label.! !!TGoToNode methodsFor: 'all'!isGoTo    ^true! !!TGoToNode methodsFor: 'all'!label    ^label! !!TGoToNode methodsFor: 'all'!printOn: aStream level: level    aStream nextPutAll: 'goto '.    aStream nextPutAll: label.! !!TGoToNode methodsFor: 'all'!setLabel: aString    label _ aString.! !!ThumbnailMorph methodsFor: 'all' stamp: 'jm 6/11/97 10:10'!drawOn: aCanvas     | viewedMorphBox myBox scale c shrunkForm diag |    super drawOn: aCanvas.    morphToView ifNil: [^ self].    (morphToView isKindOf: SketchMorph) ifTrue: [        diag _ morphToView form extent r asInteger.        viewedMorphBox _            (morphToView bounds center - (diag // 2)) extent: diag@diag.    ] ifFalse: [        viewedMorphBox _ morphToView fullBounds].    myBox _ self innerBounds.    scale _ myBox width / (viewedMorphBox width max: viewedMorphBox height).    c _ FormCanvas extent: viewedMorphBox extent depth: aCanvas depth.    c _ c copyOffset: viewedMorphBox topLeft negated.    morphToView fullDrawOn: c.    shrunkForm _ c form magnify: c form boundingBox by: scale smoothing: 1.    aCanvas image: shrunkForm at: self center - shrunkForm boundingBox center.! !!ThumbnailMorph methodsFor: 'all'!initialize    super initialize.    self extent: 25@25.    self color: (Color r: 0.781 g: 0.781 b: 0.781).    self borderWidth: 1.! !!ThumbnailMorph methodsFor: 'all'!morphToView    ^ morphToView! !!ThumbnailMorph methodsFor: 'all'!morphToView: aMorphOrNil    (aMorphOrNil allMorphs includes: self) ifTrue: [        "cannot view a morph containing myself or drawOn: goes into infinite recursion"        morphToView _ nil.        ^ self].    morphToView _ aMorphOrNil.! !!ThumbnailMorph methodsFor: 'all'!step    self changed.! !!ThumbnailMorph methodsFor: 'all'!stepTime    ^ 50! !!Time class methodsFor: 'instance creation'!fromSeconds: secondCount     "Answer an instance of me that is secondCount number of seconds since midnight."    | secondsInHour hours secs |    secs _ secondCount asInteger.    hours _ secs // 3600.    secondsInHour _ secs \\ 3600.    ^self new hours: hours               minutes: secondsInHour // 60               seconds: secondsInHour \\ 60! !!TinyPaint methodsFor: 'initialization' stamp: 'jm 9/25/97 17:01'!initialize    super initialize.    color _ Color veryVeryLightGray.    brushColor _ Color red.    brushSize _ 3.    self clear.! !!TinyPaint methodsFor: 'events'!handlesMouseDown: evt    ^ true! !!TinyPaint methodsFor: 'events'!mouseDown: evt    lastMouse _ evt cursorPoint.! !!TinyPaint methodsFor: 'events'!mouseMove: evt    | p |    p _ evt cursorPoint.    p = lastMouse ifTrue: [^ self].    brush drawFrom: lastMouse - bounds origin to: p - bounds origin.    self invalidRect: (        ((lastMouse min: p) - brush sourceForm extent) corner:        ((lastMouse max: p) + brush sourceForm extent)).    lastMouse _ p.! !!TinyPaint methodsFor: 'menu'!addCustomMenuItems: aCustomMenu hand: aHandMorph    super addCustomMenuItems: aCustomMenu hand: aHandMorph.    aCustomMenu add: 'clear' action: #clear.    aCustomMenu add: 'pen color' action: #setPenColor:.    aCustomMenu add: 'pen size' action: #setPenSize.    aCustomMenu add: 'fill' action: #fill.! !!TinyPaint methodsFor: 'menu' stamp: 'jm 9/25/97 16:53'!brushColor: aColor    brushColor _ aColor.    brush color: aColor.! !!TinyPaint methodsFor: 'menu' stamp: 'jm 9/25/97 17:02'!clear    self form: ((Form extent: 400@300 depth: 8) fillColor: color).    brush _ Pen newOnForm: originalForm.    brush roundNib: brushSize.    brush color: brushColor.! !!TinyPaint methodsFor: 'menu'!fill    | fillPt |    Cursor blank show.    Cursor crossHair showWhile:        [fillPt _ Sensor waitButton - self world viewBox origin - self position].    originalForm shapeFill: brushColor interiorPoint: fillPt.    self changed.! !!TinyPaint methodsFor: 'menu' stamp: 'jm 9/25/97 16:55'!setPenColor: evt    evt hand changeColorTarget: self selector: #brushColor:.! !!TinyPaint methodsFor: 'menu' stamp: 'jm 9/25/97 17:01'!setPenSize    | menu sizes nibSize |    menu _ CustomMenu new.    sizes _ (0 to: 5), (6 to: 12 by: 2), (15 to: 40 by: 5).    sizes do: [:w | menu add: w printString action: w].    nibSize _ menu startUp.    nibSize ifNotNil: [        brushSize _ nibSize.        brush roundNib: nibSize].! !!TLabeledCommentNode methodsFor: 'all'!copyTree    ^self class new        setLabel: label        comment: comment! !!TLabeledCommentNode methodsFor: 'all'!emitCCodeOn: aStream level: level generator: aCodeGen    "Emit a C comment with optional label."    self printOptionalLabelOn: aStream.    aStream nextPutAll: '/* '.    aStream nextPutAll: comment.    aStream nextPutAll: ' */'.! !!TLabeledCommentNode methodsFor: 'all'!isComment    "Answer true if the receiver is just a comment (i.e., it has no label)."    ^label = nil! !!TLabeledCommentNode methodsFor: 'all'!isLabel    ^true! !!TLabeledCommentNode methodsFor: 'all'!isLeaf    ^true! !!TLabeledCommentNode methodsFor: 'all'!label    ^label! !!TLabeledCommentNode methodsFor: 'all'!printOn: aStream level: level    self printOptionalLabelOn: aStream.    aStream nextPut: $".    aStream nextPutAll: comment.    aStream nextPut: $".! !!TLabeledCommentNode methodsFor: 'all'!printOptionalLabelOn: aStream    label ~= nil ifTrue: [        self unindentOneTab: aStream.        aStream nextPutAll: label.        aStream nextPut: $:.        aStream tab.        ].! !!TLabeledCommentNode methodsFor: 'all'!setComment: commentString    label _ nil.    comment _ commentString.! !!TLabeledCommentNode methodsFor: 'all'!setLabel: labelString    label _ labelString.! !!TLabeledCommentNode methodsFor: 'all'!setLabel: labelString comment: commentString    label _ labelString.    comment _ commentString.! !!TLabeledCommentNode methodsFor: 'all'!unindentOneTab: aStream    "Remove the last tab from the given stream if possible."    (aStream isKindOf: ReadWriteStream) ifFalse: [ ^self ].    aStream position > 0 ifTrue: [        aStream position: aStream position - 1.        "restore stream position if previous char was not a tab"        aStream peek = Character tab ifFalse: [ aStream next ].    ].! !!TMethod methodsFor: 'initialization'!setSelector: sel args: argList locals: localList block: aBlockNode    "Initialize this method using the given information."    selector _ sel.    returnType _ 'int'.      "assume return type is int for now"    args _ argList asOrderedCollection collect: [ :arg | arg key ].    locals _ localList asOrderedCollection collect: [ :arg | arg key ].    declarations _ Dictionary new.    parseTree _ aBlockNode asTranslatorNode.    labels _ OrderedCollection new.    complete _ false.        "set to true when all possible inlining has been done"    self removeFinalSelfReturn.    self recordDeclarations.! !!TMethod methodsFor: 'initialization'!setSelector: sel returnType: retType args: argList locals: localList declarations: decls parseTree: aNode labels: labelList complete: completeFlag    "Initialize this method using the given information. Used for copying."    selector _ sel.    returnType _ retType.    args _ argList.    locals _ localList.    declarations _ decls.    parseTree _ aNode.    labels _ labelList.    complete _ completeFlag.! !!TMethod methodsFor: 'accessing'!args    "The arguments of this method."    ^args! !!TMethod methodsFor: 'accessing'!declarations    "The type declaration dictionary of this method."    ^declarations! !!TMethod methodsFor: 'accessing'!isComplete    "A method is 'complete' if it does not contain any more inline-able calls."    ^complete! !!TMethod methodsFor: 'accessing'!labels    ^labels! !!TMethod methodsFor: 'accessing'!locals    "The local variables of this method."    ^locals! !!TMethod methodsFor: 'accessing'!parseTree    "The parse tree of this method."    ^parseTree! !!TMethod methodsFor: 'accessing'!parseTree: aNode    "Set the parse tree of this method."    parseTree _ aNode.! !!TMethod methodsFor: 'accessing'!returnType    "The type of the values returned by this method. This string will be used in the C declaration of this function."    ^returnType! !!TMethod methodsFor: 'accessing'!selector    "The Smalltalk selector of this method."    ^selector! !!TMethod methodsFor: 'accessing'!selector: newSelector    selector _ newSelector.! !!TMethod methodsFor: 'accessing'!statements    parseTree isStmtList        ifFalse: [ self error: 'expected method parse tree to be a TStmtListNode' ].    ((parseTree args = nil) or: [parseTree args isEmpty])        ifFalse: [ self error: 'expected method parse tree to have no args' ].    ^parseTree statements! !!TMethod methodsFor: 'primitive compilation'!argConversionExprFor: varName stackIndex: stackIndex    "Return the parse tree for an expression that fetches and converts the primitive argument at the given stack offset."    | expr decl |    expr _ '(self longAt: stackPointer - ( ', stackIndex printString, ' * 4))'.    (declarations includesKey: varName) ifTrue: [  "array"        decl _ declarations at: varName.        (decl includes: $*) ifTrue: [            expr _ varName, ' _ self arrayValueOf: ', expr.        ] ifFalse: [  "must be a double"            ((decl findString: 'double' startingAt: 1) = 0)                ifTrue: [ self error: 'unsupported type declaration in a primitive method' ].            expr _ varName, ' _ self floatValueOf: ', expr.        ].    ] ifFalse: [  "undeclared variables are taken to be integer"        expr _ varName, ' _ self checkedIntegerValueOf: ', expr.    ].    ^ self statementsFor: expr varName: varName! !!TMethod methodsFor: 'primitive compilation'!checkSuccessExpr    "Return the parse tree for an expression that aborts the primitive if the successFlag is not true."    | expr |    expr _ 'successFlag ifFalse: [^ nil ]'.    ^ self statementsFor: expr varName: ''! !!TMethod methodsFor: 'primitive compilation'!covertToZeroBasedArrayReferences    "Replace the index expressions in at: and at:put: messages with (<expr> - 1), since C uses zero-based array indexing."    | oldIndexExpr newIndexExpr |    parseTree nodesDo: [ :n |        (n isSend and: [(n selector = #at:) or: [ n selector = #at:put: ]]) ifTrue: [            oldIndexExpr _ n args first.            oldIndexExpr isConstant ifTrue: [                "index expression is a constant: decrement the constant now"                newIndexExpr _ TConstantNode new setValue: (n args first value - 1).            ] ifFalse: [                "index expression is complex: build an expression to decrement result at runtime"                newIndexExpr _ TSendNode new                    setSelector: #-                    receiver: oldIndexExpr                    arguments: (Array with: (TConstantNode new setValue: 1)).            ].            n args at: 1 put: newIndexExpr.        ].    ].! !!TMethod methodsFor: 'primitive compilation'!fetchRcvrExpr    "Return the parse tree for an expression that fetches the receiver from the stack."    | expr |    expr _ 'rcvr _ self longAt: stackPointer - (', args size printString, ' * 4)'.    ^ self statementsFor: expr varName: ''! !!TMethod methodsFor: 'primitive compilation'!instVarGetExprFor: varName offset: instIndex    "Return the parse tree for an expression that fetches and converts the value of the instance variable at the given offset."    | decl expr |    (declarations includesKey: varName) ifTrue: [        decl _ declarations at: varName.        (decl includes: $*) ifTrue: [  "array"            expr _ varName, ' _ self fetchArray: ', instIndex printString, ' ofObject: rcvr'.        ] ifFalse: [  "must be a double"            ((decl findString: 'double' startingAt: 1) = 0)                ifTrue: [ self error: 'unsupported type declaration in a primitive method' ].            expr _ varName, ' _ self fetchFloat: ', instIndex printString, ' ofObject: rcvr'.        ].    ] ifFalse: [  "undeclared variables are taken to be integer"        expr _ varName, ' _ self fetchInteger: ', instIndex printString, ' ofObject: rcvr'.    ].    ^ self statementsFor: expr varName: varName! !!TMethod methodsFor: 'primitive compilation'!instVarPutExprFor: varName offset: instIndex    "Return the parse tree for an expression that saves the value of the integer instance variable at the given offset."    | expr |    (declarations includesKey: varName) ifTrue: [        self error: 'a primitive method can only modify integer instance variables'.    ].    expr _ 'self storeInteger: ', instIndex printString, ' ofObject: rcvr withValue: ', varName.    ^ self statementsFor: expr varName: varName! !!TMethod methodsFor: 'primitive compilation'!popArgsExpr    "Return the parse tree for an expression that removes the primitive's arguments from the stack."    | expr |    expr _ 'self pop: ', args size printString.    ^ self statementsFor: expr varName: ''! !!TMethod methodsFor: 'primitive compilation'!preparePrimitiveInClass: aClass    "Add a prolog and postlog to a primitive method. The prolog copies any instance variables referenced by this primitive method into local variables. The postlog copies values of assigned-to variables back into the instance. The names of the new locals are added to the local variables list.The declarations dictionary defines the types of any non-integer variables (locals, arguments, or instance variables). In particular, it may specify the types:    int *        -- an array of 32-bit values (e.g., a BitMap)    short *        -- an array of 16-bit values (e.g., a SoundBuffer)    char *        -- an array of unsigned bytes (e.g., a String)    double        -- a double precision floating point number (e.g., 3.14159)Undeclared variables are taken to be integers and will be converted from Smalltalk to C ints.""Current restrictions:    o method must not contain explicit returns    o method must not contain message sends    o method must not allocate objects    o method must not manipulate raw oops    o method cannot access class variables    o compiled primitives can only return self"    | prolog postlog instVarsUsed varsAssignedTo instVarList varName |    prolog _ OrderedCollection new.    postlog _ OrderedCollection new.    instVarsUsed _ self freeVariableReferences asSet.    varsAssignedTo _ self variablesAssignedTo asSet.    instVarList _ aClass allInstVarNames.    "add receiver fetch to prolog"    prolog addAll: self fetchRcvrExpr.    "add arg conversions to prolog"    1 to: args size do: [ :argIndex |        varName _ args at: argIndex.        prolog addAll:            (self argConversionExprFor: varName stackIndex: args size - argIndex).    ].    "add instance variable fetches to prolog and instance variable stores to postlog"    1 to: instVarList size do: [ :varIndex |        varName _ instVarList at: varIndex.        (instVarsUsed includes: varName) ifTrue: [            locals add: varName.            prolog addAll: (self instVarGetExprFor: varName offset: varIndex - 1).            (varsAssignedTo includes: varName) ifTrue: [                postlog addAll: (self instVarPutExprFor: varName offset: varIndex - 1).            ].        ].    ].    prolog addAll: self checkSuccessExpr.    postlog addAll: self popArgsExpr.    locals addAllFirst: args.    locals addFirst: 'rcvr'.    args _ args class new.    locals asSet size = locals size        ifFalse: [ self error: 'local name conflicts with instance variable name' ].    self hasReturn        ifTrue: [ self error: 'returns in primitive methods are not yet supported' ].    selector _ 'prim', aClass name, selector.    parseTree setStatements: prolog, parseTree statements, postlog.    self covertToZeroBasedArrayReferences.! !!TMethod methodsFor: 'primitive compilation'!statementsFor: sourceText varName: varName    "Return the parse tree for the given expression. The result is the statements list of the method parsed from the given source text."    "Details: Various variables are declared as locals to avoid Undeclared warnings from the parser."    | s |    s _ WriteStream on: ''.    s nextPutAll: 'temp'; cr; cr; tab.    s nextPutAll: '| rcvr stackPointer successFlag ', varName,' |'; cr.    s nextPutAll: sourceText.    ^ ((Compiler new parse: s contents in: Object notifying: nil)            asTMethodFromClass: Object) statements! !!TMethod methodsFor: 'transformations'!bindClassVariablesIn: constantDictionary    "Class variables are used as constants. This method replaces all references to class variables in the body of this method with the corresponding constant looked up in the class pool dictionary of the source class. The source class class variables should be initialized before this method is called."    parseTree _ parseTree bindVariablesIn: constantDictionary.! !!TMethod methodsFor: 'transformations'!buildCaseStmt: aSendNode    "Build a case statement node for the given send of dispatchOn:in:."    "Note: the first argument is the variable to be dispatched on. The second argument is a constant node holding an array of unary selectors, which will be turned into sends to self."    ((aSendNode args size = 2) and:     [aSendNode args last isConstant and:     [aSendNode args last value class = Array]]) ifFalse: [        self error: 'wrong node structure for a case statement'.    ].    ^TCaseStmtNode new        setExpression: aSendNode args first        selectors: aSendNode args last value! !!TMethod methodsFor: 'transformations'!prepareMethodIn: aCodeGen    "Record sends of builtin operators and replace sends of the special selector dispatchOn:in: with case statement nodes."    "Note: Only replaces top-level sends of dispatchOn:in:. Case statements must be top-level statements; they cannot appear in expressions."    | stmts stmt |    parseTree nodesDo: [ :node |        node isSend ifTrue: [            "record sends of builtin operators"            (aCodeGen builtin: node selector) ifTrue: [ node isBuiltinOperator: true ].        ].        node isStmtList ifTrue: [            "replace dispatchOn:in: with case statement node"            stmts _ node statements.            1 to: stmts size do: [ :i |                stmt _ stmts at: i.                (stmt isSend and: [stmt selector = #dispatchOn:in:]) ifTrue: [                    stmts at: i put: (self buildCaseStmt: stmt).                ].            ].        ].    ].! !!TMethod methodsFor: 'transformations'!recordDeclarations    "Record C type declarations of the forms        self returnTypeC: 'float'.        self var: #foo declareC: 'float foo'     and remove the declarations from the method body."    | newStatements isDeclaration |    newStatements _ OrderedCollection new: parseTree statements size.    parseTree statements do: [ :stmt |        isDeclaration _ false.        stmt isSend ifTrue: [            stmt selector = #var:declareC: ifTrue: [                isDeclaration _ true.                declarations at: stmt args first value asString put: stmt args last value.            ].            stmt selector = #returnTypeC: ifTrue: [                isDeclaration _ true.                returnType _ stmt args last value.            ].        ].        isDeclaration ifFalse: [            newStatements add: stmt.        ].    ].    parseTree setStatements: newStatements asArray.! !!TMethod methodsFor: 'transformations'!removeFinalSelfReturn    "The Smalltalk parser automatically adds the statement '^self' to the end of methods without explicit returns. This method removes such statements, since the generated code has no notion of 'self' anyway."    | stmtList lastStmt |    stmtList _ parseTree statements asOrderedCollection.    lastStmt _ stmtList last.    ((lastStmt isReturn) and:     [(lastStmt expression isVariable) and:     [lastStmt expression name = 'self']]) ifTrue: [        stmtList removeLast.        parseTree setStatements: stmtList.    ].! !!TMethod methodsFor: 'utilities'!allCalls    "Answer a collection of selectors for the messages sent by this method."    ^parseTree allCalls! !!TMethod methodsFor: 'utilities'!copy    "Make a deep copy of this TMethod."    ^self class basicNew        setSelector: selector        returnType: returnType        args: args copy        locals: locals copy        declarations: declarations copy        parseTree: parseTree copyTree        labels: labels copy        complete: complete! !!TMethod methodsFor: 'utilities'!freeVariableReferences    "Answer a collection of variables referenced this method, excluding locals, arguments, and pseudovariables."    | refs |    refs _ Set new.    parseTree nodesDo: [ :node |        node isVariable ifTrue: [ refs add: node name asString ].    ].    args do: [ :var | refs remove: var asString ifAbsent: [] ].    locals do: [ :var | refs remove: var asString ifAbsent: [] ].    #('self' 'nil' 'true' 'false') do: [ :var | refs remove: var ifAbsent: [] ].    ^ refs asSortedCollection! !!TMethod methodsFor: 'utilities'!hasNoCCode    "Answer true if the receiver does not use inlined C or C declarations, which are not currently renamed properly by the the inliner."    declarations isEmpty ifFalse: [ ^ false ].    parseTree nodesDo: [ :node |        node isSend ifTrue: [            node selector = #cCode: ifTrue: [ ^ false ].        ].    ].    ^ true! !!TMethod methodsFor: 'utilities'!nodeCount    "Answer the number of nodes in this method's parseTree (a rough measure of its size)."    | cnt |    cnt _ 0.    parseTree nodesDo: [ :n | cnt _ cnt + 1 ].    ^cnt! !!TMethod methodsFor: 'utilities'!variablesAssignedTo    "Answer a collection of variables assigned to by this method."    | refs |    refs _ Set new.    parseTree nodesDo: [ :node |        node isAssignment ifTrue: [ refs add: node variable name ].    ].    ^ refs! !!TMethod methodsFor: 'inlining'!argAssignmentsFor: meth args: argList in: aCodeGen    "Return a collection of assignment nodes that assign the given argument expressions to the formal parameter variables of the given method."    "Optimization: If the actual parameters are either constants or local variables in the target method (the receiver), substitute them directly into the body of meth. Note that global variables cannot be subsituted because the inlined method might depend on the exact ordering of side effects to the globals."    | stmtList substitutionDict |    stmtList _ OrderedCollection new: 16.    substitutionDict _ Dictionary new.    meth args with: argList do: [ :argName :exprNode |        (self isSubstitutableNode: exprNode intoMethod: meth in: aCodeGen) ifTrue: [            substitutionDict at: argName asSymbol put: exprNode.            locals remove: argName.        ] ifFalse: [            stmtList add: (TAssignmentNode new                setVariable: (TVariableNode new setName: argName)                expression: exprNode copyTree).        ].    ].    meth parseTree: (meth parseTree bindVariablesIn: substitutionDict).    ^stmtList! !!TMethod methodsFor: 'inlining'!checkForCompleteness: stmtLists in: aCodeGen    "Set the complete flag if none of the given statement list nodes contains further candidates for inlining."    complete _ true.    stmtLists do: [ :stmtList |        stmtList statements do: [ :node |            (self inlineableSend: node in: aCodeGen) ifTrue: [                complete _ false.  "more inlining to do"                ^self            ].        ].    ].    parseTree nodesDo: [ :n |        (self inlineableFunctionCall: n in: aCodeGen) ifTrue: [            complete _ false.  "more inlining to do"            ^self        ].    ].! !!TMethod methodsFor: 'inlining'!exitVar: exitVar label: exitLabel    "Replace each return statement in this method with an assignment to the exit variable followed by a goto to the given label. Return true if a goto was generated."    "Optimization: If exitVar is nil, the return value of the inlined method is not being used, so don't add the assignment statement."    | newStmts labelUsed |    labelUsed _ false.    parseTree nodesDo: [ :node |        node isStmtList ifTrue: [            newStmts _ OrderedCollection new: 100.            node statements do: [ :stmt |                (stmt isReturn) ifTrue: [                    exitVar = nil ifTrue: [                        stmt expression isLeaf ifFalse: [                            "evaluate return expression even though value isn't used"                            newStmts add: stmt expression.                        ].                    ] ifFalse: [                        "assign return expression to exit variable"                        newStmts add:                            (TAssignmentNode new                                setVariable: (TVariableNode new setName: exitVar)                                expression: stmt expression).                    ].                    (stmt == parseTree statements last) ifFalse: [                        "generate a goto (this return is NOT the last statement in the method)"                        newStmts add: (TGoToNode new setLabel: exitLabel).                        labelUsed _ true.                    ].                ] ifFalse: [                    newStmts addLast: stmt.                ].            ].            node setStatements: newStmts asArray.        ].    ].    ^labelUsed! !!TMethod methodsFor: 'inlining'!inlineableFunctionCall: aNode in: aCodeGen    "Answer true if the given send node is a call to a 'functional' method--a method whose body is a single return statement of some expression and whose actual parameters can all be directly substituted."    | m |    aNode isSend ifFalse: [ ^false ].    m _ aCodeGen methodNamed: aNode selector.  "nil if builtin or external function"    ((m ~= nil) and: [m isFunctional and: [aCodeGen mayInline: m selector]]) ifTrue: [        aNode args do: [ :a | (self isSubstitutableNode: a intoMethod: m in: aCodeGen) ifFalse: [ ^false ]].        ^true    ] ifFalse: [        ^false    ].! !!TMethod methodsFor: 'inlining'!inlineableSend: aNode in: aCodeGen    "Answer true if the given send node is a call to a method that can be inlined."    | m |    aNode isSend ifFalse: [ ^false ].    m _ aCodeGen methodNamed: aNode selector.  "nil if builtin or external function"    ^(m ~= nil) and: [m isComplete and: [aCodeGen mayInline: m selector]]! !!TMethod methodsFor: 'inlining'!inlineCaseStatementBranchesIn: aCodeGen localizingVars: varsList    | stmt sel meth newStatements maxTemp usedVars exitLabel v |    maxTemp _ 0.    parseTree nodesDo: [ :n |        n isCaseStmt ifTrue: [            n cases do: [ :stmtNode |                stmt _ stmtNode statements first.                stmt isSend ifTrue: [                    sel _ stmt selector.                    meth _ aCodeGen methodNamed: sel.                    ((meth ~= nil) and:                     [meth hasNoCCode and:                     [meth args size = 0]]) ifTrue: [                        meth _ meth copy.                        maxTemp _ maxTemp max: (meth renameVarsForCaseStmt).                        meth hasReturn ifTrue: [                            exitLabel _ self unusedLabelForInliningInto: self.                            meth exitVar: nil label: exitLabel.                            labels add: exitLabel.                        ] ifFalse: [ exitLabel _ nil ].                        meth renameLabelsForInliningInto: self.                        meth labels do: [ :label | labels add: label ].                        newStatements _ stmtNode statements asOrderedCollection.                        newStatements removeFirst.                        exitLabel ~= nil ifTrue: [                            newStatements addFirst:                                (TLabeledCommentNode new                                    setLabel: exitLabel comment: 'end case').                        ].                        newStatements addAllFirst: meth statements.                        newStatements addFirst:                            (TLabeledCommentNode new setComment: meth selector).                        stmtNode setStatements: newStatements.                    ].                ].            ].        ].    ].    usedVars _ (locals, args) asSet.    1 to: maxTemp do: [ :i |        v _ ('t', i printString).        (usedVars includes: v) ifTrue: [ self error: 'temp variable name conflicts with an existing local or arg' ].        locals addLast: v.    ].    "make local versions of the given globals"    varsList do: [ :var |        (usedVars includes: var) ifFalse: [ locals addFirst: var asString ].    ].! !!TMethod methodsFor: 'inlining'!inlineCodeOrNilForStatement: aNode in: aCodeGen    "If the given statement node can be inlined, answer the statements that replace it. Otherwise, answer nil."    | stmts |    aNode isReturn ifTrue: [        (self inlineableSend: aNode expression in: aCodeGen) ifTrue: [            stmts _ self inlineSend: aNode expression                directReturn: true exitVar: nil in: aCodeGen.            ^stmts        ].    ].    aNode isAssignment ifTrue: [        (self inlineableSend: aNode expression in: aCodeGen) ifTrue: [            ^self inlineSend: aNode expression                directReturn: false exitVar: aNode variable name in: aCodeGen        ].    ].    aNode isSend ifTrue: [        (self inlineableSend: aNode in: aCodeGen) ifTrue: [            ^self inlineSend: aNode                directReturn: false exitVar: nil in: aCodeGen        ].    ].    ^nil! !!TMethod methodsFor: 'inlining'!inlineFunctionCall: aSendNode in: aCodeGen    "Answer the body of the called function, substituting the actual parameters for the formal argument variables in the method body."    "Assume caller has established that:        1. the method arguments are all substitutable nodes, and        2. the method to be inlined contains no additional embedded returns."    | sel meth substitutionDict |    sel _ aSendNode selector.    meth _ (aCodeGen methodNamed: sel) copy.    meth renameVarsForInliningInto: self in: aCodeGen.    meth renameLabelsForInliningInto: self.    self addVarsDeclarationsAndLabelsOf: meth.    substitutionDict _ Dictionary new.    meth args with: aSendNode args do: [ :argName :exprNode |        substitutionDict at: argName asSymbol put: exprNode.        locals remove: argName.    ].    meth parseTree bindVariablesIn: substitutionDict.    ^meth statements first expression! !!TMethod methodsFor: 'inlining'!inlineSend: aSendNode directReturn: directReturn exitVar: exitVar in: aCodeGen    "Answer a collection of statments to replace the given send. directReturn indicates that the send is the expression of a return statement, so returns can be left in the body of the inlined method. If exitVar is nil, the value returned by the send is not used; thus, returns need not assign to the output variable."    | sel meth exitLabel labelUsed inlineStmts |    sel _ aSendNode selector.    meth _ (aCodeGen methodNamed: sel) copy.    meth renameVarsForInliningInto: self in: aCodeGen.    meth renameLabelsForInliningInto: self.    self addVarsDeclarationsAndLabelsOf: meth.    meth hasReturn ifTrue: [        directReturn ifTrue: [            "propagate the return type, if necessary"            returnType = meth returnType ifFalse: [ self halt ].  "caller's return type should be declared by user"            returnType _ meth returnType.        ] ifFalse: [            exitLabel _ self unusedLabelForInliningInto: self.            labelUsed _ meth exitVar: exitVar label: exitLabel.            labelUsed                ifTrue: [ labels add: exitLabel ]                ifFalse: [ exitLabel _ nil ].        ].        "propagate type info if necessary"        ((exitVar ~= nil) and: [meth returnType ~= 'int']) ifTrue: [            declarations at: exitVar put: meth returnType, ' ', exitVar.        ].    ].    inlineStmts _ OrderedCollection new: 100.    inlineStmts add: (TLabeledCommentNode new setComment: 'begin ', sel).    inlineStmts addAll:        (self argAssignmentsFor: meth args: aSendNode args in: aCodeGen).    inlineStmts addAll: meth statements.  "method body"    (directReturn and: [meth endsWithReturn not]) ifTrue: [        inlineStmts add: (TReturnNode new setExpression: (TVariableNode new setName: 'nil')).    ].    exitLabel ~= nil ifTrue: [        inlineStmts add:            (TLabeledCommentNode new                setLabel: exitLabel comment: 'end ', meth selector).    ].    ^inlineStmts! !!TMethod methodsFor: 'inlining'!isFunctional    "Answer true if the receiver is a functional method. That is, if it consists of a single return statement of an expression that contains no other returns."    (parseTree statements size = 1 and:     [parseTree statements last isReturn]) ifFalse: [ ^false ].    parseTree statements last expression nodesDo: [ :n | n isReturn ifTrue: [ ^false ]].    ^true! !!TMethod methodsFor: 'inlining'!isSubstitutableNode: aNode    "Answer true if the given parameter node is either a constant, a local variable, or a formal parameter of the receiver. Such parameter nodes may be substituted directly into the body of the method during inlining. Note that global variables cannot be subsituted because the inlined method might depend on the exact ordering of side effects to the globals."    aNode isConstant ifTrue: [ ^true ].    ^aNode isVariable and:        [(locals includes: aNode name) or:        [args includes: aNode name]]! !!TMethod methodsFor: 'inlining'!isSubstitutableNode: aNode intoMethod: targetMeth in: aCodeGen    "Answer true if the given parameter node is either a constant, a local variable, or a formal parameter of the receiver. Such parameter nodes may be substituted directly into the body of the method during inlining. Note that global variables cannot be subsituted into methods with possible side effects (i.e., methods that may assign to global variables) because the inlined method might depend on having the value of the global variable captured when it is passed in as an argument."    | var |    aNode isConstant ifTrue: [ ^ true ].    aNode isVariable ifTrue: [        var _ aNode name.        ((locals includes: var) or: [args includes: var]) ifTrue: [ ^ true ].        (#(self true false nil) includes: var) ifTrue: [ ^ true ].        (targetMeth maySubstituteGlobal: var in: aCodeGen) ifTrue: [ ^ true ].    ].    "scan expression tree; must contain only constants, builtin ops, and inlineable vars"    aNode nodesDo: [ :node |        node isSend ifTrue: [            node isBuiltinOperator ifFalse: [ ^false ].        ].        node isVariable ifTrue: [            var _ node name.            ((locals includes: var) or:             [(args includes: var) or:             [(#(self true false nil) includes: var) or:             [targetMeth maySubstituteGlobal: var in: aCodeGen]]]) ifFalse: [ ^ false ].        ].        (node isConstant or: [node isVariable or: [node isSend]]) ifFalse: [ ^false ].    ].    ^ true! !!TMethod methodsFor: 'inlining'!statementsListsForInlining    "Answer a collection of statement list nodes that are candidates for inlining. Currently, we cannot inline into the argument blocks of and: and or: messages."    | stmtLists |    stmtLists _ OrderedCollection new: 10.    parseTree nodesDo: [ :node |         node isStmtList ifTrue: [ stmtLists add: node ].    ].    parseTree nodesDo: [ :node |         node isSend ifTrue: [            ((node selector = #and:) or: [node selector = #or:]) ifTrue: [                "Note: the PP 2.3 compiler produces two arg nodes for these selectors"                stmtLists remove: node args first ifAbsent: [].                stmtLists remove: node args last ifAbsent: [].            ].            ((node selector = #ifTrue:) or: [node selector = #ifFalse:]) ifTrue: [                stmtLists remove: node receiver ifAbsent: [].            ].            ((node selector = #ifTrue:ifFalse:) or: [node selector = #ifFalse:ifTrue:]) ifTrue: [                stmtLists remove: node receiver ifAbsent: [].            ].            ((node selector = #whileFalse:) or: [node selector = #whileTrue:]) ifTrue: [                stmtLists remove: node receiver ifAbsent: [].            ].            (node selector = #to:do) ifTrue: [                stmtLists remove: node receiver ifAbsent: [].                stmtLists remove: node args first ifAbsent: [].            ].            (node selector = #to:do) ifTrue: [                stmtLists remove: node receiver ifAbsent: [].                stmtLists remove: node args first ifAbsent: [].                stmtLists remove: (node args at: 2) ifAbsent: [].            ].        ].        node isCaseStmt ifTrue: [            "don't inline cases"            node cases do: [: case | stmtLists remove: case ifAbsent: [] ].        ].    ].    ^stmtLists! !!TMethod methodsFor: 'inlining'!tryToInlineMethodsIn: aCodeGen    "Expand any (complete) inline methods called by this method. Set the complete bit when all inlining has been done. Return true if something was inlined."    | stmtLists didSomething newStatements inlinedStmts sendsToInline |    didSomething _ false.    sendsToInline _ Dictionary new.    parseTree nodesDo: [ :n |        (self inlineableFunctionCall: n in: aCodeGen) ifTrue: [            sendsToInline at: n put: (self inlineFunctionCall: n in: aCodeGen).        ].    ].    sendsToInline isEmpty ifFalse: [        didSomething _ true.        parseTree _ parseTree replaceNodesIn: sendsToInline.    ].    didSomething ifTrue: [        possibleSideEffectsCache _ nil.        ^didSomething    ].    stmtLists _ self statementsListsForInlining.    stmtLists do: [ :stmtList |         newStatements _ OrderedCollection new: 100.        stmtList statements do: [ :stmt |            inlinedStmts _ self inlineCodeOrNilForStatement: stmt in: aCodeGen.            (inlinedStmts = nil) ifTrue: [                newStatements addLast: stmt.            ] ifFalse: [                didSomething _ true.                newStatements addAllLast: inlinedStmts.            ].        ].        stmtList setStatements: newStatements asArray.    ].    didSomething ifTrue: [        possibleSideEffectsCache _ nil.        ^didSomething    ].    complete ifFalse: [        self checkForCompleteness: stmtLists in: aCodeGen.        complete ifTrue: [ didSomething _ true ].  "marking a method complete is progress"    ].    ^didSomething! !!TMethod methodsFor: 'inlining'!unusedLabelForInliningInto: targetMethod    | usedLabels |    usedLabels _ labels asSet.    usedLabels addAll: targetMethod labels.    ^self unusedNamePrefixedBy: 'l' avoiding: usedLabels! !!TMethod methodsFor: 'inlining support'!addVarsDeclarationsAndLabelsOf: methodToBeInlined    "Prepare to inline the body of the given method into the receiver by making the args and locals of the argument to the receiver be locals of the receiver. Record any type declarations for these variables. Record labels. Assumes that the variables have already be renamed to avoid name clashes."    methodToBeInlined args, methodToBeInlined locals do: [ :v |        (locals includes: v) ifFalse: [ locals addLast: v ].    ].    methodToBeInlined declarations associationsDo: [ :assoc |        declarations add: assoc.    ].    methodToBeInlined labels do: [ :label |        labels add: label.    ].! !!TMethod methodsFor: 'inlining support'!computePossibleSideEffectsIn: aCodeGen    "Answer true if this method may have side effects. It has side effects if it assigns to a global variable. It may have side effects if it calls a non-built-in method."    parseTree nodesDo: [ :node |        node isSend ifTrue: [            node isBuiltinOperator ifFalse: [ ^true ].        ].    ].    ^ false! !!TMethod methodsFor: 'inlining support'!endsWithReturn    "Answer true if the last statement of this method is a return."    ^ parseTree statements last isReturn! !!TMethod methodsFor: 'inlining support'!extractInlineDirective    "Scan the top-level statements for an inlining directive of the form:        self inline: <boolean>     and remove the directive from the method body. Return the argument of the directive or #dontCare if there is no inlining directive."    | result newStatements |    result _ #dontCare.    newStatements _ OrderedCollection new: parseTree statements size.    parseTree statements do: [ :stmt |        (stmt isSend and: [stmt selector = #inline:]) ifTrue: [            result _ stmt args first name = 'true'.        ] ifFalse: [            newStatements add: stmt.        ].    ].    parseTree setStatements: newStatements asArray.    ^ result! !!TMethod methodsFor: 'inlining support'!hasReturn    "Answer true if this method contains a return statement."    parseTree nodesDo: [ :n | n isReturn ifTrue: [ ^ true ]].    ^ false! !!TMethod methodsFor: 'inlining support'!maySubstituteGlobal: globalVar in: aCodeGen    "Answer true if this method does or may have side effects on the given global variable."    possibleSideEffectsCache = nil ifTrue: [        "see if this calls any other method and record the result"        possibleSideEffectsCache _ self computePossibleSideEffectsIn: aCodeGen.    ].    possibleSideEffectsCache ifTrue: [ ^ false ].    parseTree nodesDo: [ :node |        node isAssignment ifTrue: [            node variable name = globalVar ifTrue: [ ^ false ].        ].    ].    "if we get here, receiver calls no other method     and does not itself assign to the given global variable"    ^ true! !!TMethod methodsFor: 'inlining support'!renameLabelsForInliningInto: destMethod    "Rename any labels that would clash with those of the destination method."    | destLabels usedLabels labelMap newLabelName |    destLabels _ destMethod labels asSet.    usedLabels _ destLabels copy.  "usedLabels keeps track of labels in use"    usedLabels addAll: labels.    labelMap _ Dictionary new.    self labels do: [ :l |        (destLabels includes: l) ifTrue: [            newLabelName _ self unusedNamePrefixedBy: 'l' avoiding: usedLabels.            labelMap at: l put: newLabelName.        ].    ].    self renameLabelsUsing: labelMap.! !!TMethod methodsFor: 'inlining support'!renameLabelsUsing: aDictionary    "Rename all labels according to the old->new mappings of the given dictionary."    labels _ labels collect: [ :label |        (aDictionary includesKey: label) ifTrue: [ aDictionary at: label ] ifFalse: [ label ].    ].    parseTree nodesDo: [ :node |        (node isGoTo and: [aDictionary includesKey: node label]) ifTrue: [            node setLabel: (aDictionary at: node label).        ].        (node isLabel and: [aDictionary includesKey: node label]) ifTrue: [            node setLabel: (aDictionary at: node label).        ].    ].! !!TMethod methodsFor: 'inlining support'!renameVariablesUsing: aDictionary    "Rename all variables according to old->new mappings of the given dictionary."    | newDecls |    "map args and locals"    args _ args collect: [ :arg |        (aDictionary includesKey: arg) ifTrue: [ aDictionary at: arg ] ifFalse: [ arg ].    ].    locals _ locals collect: [ :v |        (aDictionary includesKey: v) ifTrue: [ aDictionary at: v ] ifFalse: [ v ].    ].    "map declarations"    newDecls _ declarations species new.    declarations associationsDo: [ :assoc |        (aDictionary includesKey: assoc key)            ifTrue: [ newDecls at: (aDictionary at: assoc key) put: assoc value ]            ifFalse: [ newDecls add: assoc ].    ].    declarations _ newDecls.    "map variable names in parse tree"    parseTree nodesDo: [ :node |        (node isVariable and:         [aDictionary includesKey: node name]) ifTrue: [            node setName: (aDictionary at: node name).        ].        (node isStmtList and: [node args size > 0]) ifTrue: [            node setArguments:                (node args collect: [ :arg |                    (aDictionary includesKey: arg)                        ifTrue: [ aDictionary at: arg ]                        ifFalse: [ arg ].                ]).        ].    ].! !!TMethod methodsFor: 'inlining support'!renameVarsForCaseStmt    "Rename the arguments and locals of this method with names like t1, t2, t3, etc. Return the number of variable names assigned. This is done to allow registers to be shared among the cases."    | i varMap |    i _ 1.    varMap _ Dictionary new.    args, locals do: [ :v |        varMap at: v put: ('t', i printString) asSymbol.        i _ i + 1.    ].    self renameVariablesUsing: varMap.    ^ i - 1! !!TMethod methodsFor: 'inlining support'!renameVarsForInliningInto: destMethod in: aCodeGen    "Rename any variables that would clash with those of the destination method."    | destVars usedVars varMap newVarName |    destVars _ aCodeGen globalsAsSet copy.    destVars addAll: destMethod locals.    destVars addAll: destMethod args.    usedVars _ destVars copy.  "keeps track of names in use"    usedVars addAll: args; addAll: locals.    varMap _ Dictionary new.    args, locals do: [ :v |        (destVars includes: v) ifTrue: [            newVarName _ self unusedNamePrefixedBy: v avoiding: usedVars.            varMap at: v put: newVarName.        ].    ].    self renameVariablesUsing: varMap.! !!TMethod methodsFor: 'inlining support'!unusedNamePrefixedBy: aString avoiding: usedNames    "Choose a unique variable or label name with the given string as a prefix, avoiding the names in the given collection. The selected name is added to usedNames."    | n newVarName |    n _ 1.    newVarName _ aString, n printString.    [usedNames includes: newVarName] whileTrue: [        n _ n + 1.        newVarName _ aString, n printString.    ].    usedNames add: newVarName.    ^ newVarName! !!TMethod methodsFor: 'C code generation'!emitCCodeOn: aStream generator: aCodeGen    "Emit C code for this method onto the given stream. All calls to inlined methods should already have been expanded."    self emitCHeaderOn: aStream generator: aCodeGen.    parseTree emitCCodeOn: aStream level: 1 generator: aCodeGen.    aStream nextPutAll: '}'; cr.! !!TMethod methodsFor: 'C code generation'!emitCFunctionPrototype: aStream generator: aCodeGen    "Emit a C function header for this method onto the given stream."    | arg |    aStream nextPutAll: returnType; space.    aStream nextPutAll: (aCodeGen cFunctionNameFor: selector), '('.    args isEmpty ifTrue: [ aStream nextPutAll: 'void' ].    1 to: args size do: [ :i |        arg _ args at: i.        (declarations includesKey: arg) ifTrue: [            aStream nextPutAll: (declarations at: arg).        ] ifFalse: [            aStream nextPutAll: 'int ', (args at: i).        ].        i < args size ifTrue: [ aStream nextPutAll: ', ' ].    ].    aStream nextPutAll: ')'.! !!TMethod methodsFor: 'C code generation'!emitCHeaderOn: aStream generator: aCodeGen    "Emit a C function header for this method onto the given stream."    aStream cr.    self emitCFunctionPrototype: aStream generator: aCodeGen.    aStream nextPutAll: ' {'; cr.    locals do: [ :var |        aStream nextPutAll: '    '.        aStream nextPutAll: (declarations at: var ifAbsent: [ 'int ', var]), ';'; cr.    ].    locals isEmpty ifFalse: [ aStream cr ].! !!TMethod methodsFor: 'printing'!printOn: aStream    aStream nextPutAll: 'TMethod(', selector, ')'.! !!TParseNode methodsFor: 'all'!allCalls    "Answer a collection of selectors for the messages sent in this parse tree."    | calls |    calls _ Set new: 100.    self nodesDo: [ :node |        node isSend ifTrue: [ calls add: node selector ].    ].    ^calls! !!TParseNode methodsFor: 'all'!bindVariablesIn: aDictionary    ^self! !!TParseNode methodsFor: 'all'!hasExplicitReturn    self nodesDo: [ :node |        node isReturn ifTrue: [ ^true ].    ].    ^false! !!TParseNode methodsFor: 'all'!inlineMethodsUsing: aDictionary    self! !!TParseNode methodsFor: 'all'!isAssignment    ^false! !!TParseNode methodsFor: 'all'!isCaseStmt    ^false! !!TParseNode methodsFor: 'all'!isComment    ^false! !!TParseNode methodsFor: 'all'!isConstant    ^false! !!TParseNode methodsFor: 'all'!isGoTo    ^false! !!TParseNode methodsFor: 'all'!isLabel    ^false! !!TParseNode methodsFor: 'all'!isLeaf    "Answer true if the receiver is a variable or a constant node."    ^false! !!TParseNode methodsFor: 'all'!isReturn    ^false! !!TParseNode methodsFor: 'all'!isSend    ^false! !!TParseNode methodsFor: 'all'!isStmtList    ^false! !!TParseNode methodsFor: 'all'!isVariable    ^false! !!TParseNode methodsFor: 'all'!nodeCount    "Answer the number of nodes in this parseTree (a rough measure of its size)."    | cnt |    cnt _ 0.    self nodesDo: [ :n | cnt _ cnt + 1 ].    ^cnt! !!TParseNode methodsFor: 'all'!nodesDo: aBlock    aBlock value: self.! !!TParseNode methodsFor: 'all'!printOn: aStream     "Append a description of the receiver onto the given stream."    self printOn: aStream level: 0.! !!TParseNode methodsFor: 'all'!printOn: aStream level: anInteger     "Typically overridden. If control actually gets here, avoid recursion loop by sending to super."    super printOn: aStream.! !!TParseNode methodsFor: 'all'!replaceNodesIn: aDictionary    ^aDictionary at: self ifAbsent: [self]! !TransformMorph class comment:'A WindowMorph introduces a 2-D transformation between its (global) coordinates and the (local) coordinates of its submoprhs, while also clipping all display to its bounds.  Specifically, with no offset, angle or scaling, a submorph with coordinates (0@0) will appear exactly at the topLeft of the windowMorph (its position).  Rotation and scaling are relative to the local origin, (0@0).WindowMorphs operate with two different display strategies, depending on whether the transformation is a pure translation or not.  If so, then they simply use a clipping canvas and display their submorphs with the appropriate offset.  If the transformation includes scaling or rotation, then a caching canvas is used, whose active area covers the fullBounds of the submorphs intersected with the source quadrilateral corresponding to the window bounds.'!!TransformMorph methodsFor: 'initialization'!initialize    super initialize.    color _ Color lightGreen.    smoothing _ 1.    transform _ MorphicTransform identity.! !!TransformMorph methodsFor: 'accessing'!angle    ^ transform angle! !!TransformMorph methodsFor: 'accessing'!angle: newAngle    transform _ transform withAngle: newAngle.    self changed! !!TransformMorph methodsFor: 'accessing'!offset    ^ transform offset + self innerBounds topLeft! !!TransformMorph methodsFor: 'accessing'!offset: newOffset    transform _ transform withOffset: newOffset - self innerBounds topLeft.    self changed! !!TransformMorph methodsFor: 'accessing'!scale    ^ transform scale! !!TransformMorph methodsFor: 'accessing'!scale: newScale    transform _ transform withScale: newScale.    self changed! !!TransformMorph methodsFor: 'accessing'!setOffset: newOffset angle: newAngle scale: newScale    transform _ MorphicTransform offset: newOffset angle: newAngle scale: newScale.    self changed! !!TransformMorph methodsFor: 'accessing'!smoothing: cellSize    smoothing _ cellSize.    self changed! !!TransformMorph methodsFor: 'accessing'!smoothingOff    smoothing _ 1.    self changed! !!TransformMorph methodsFor: 'accessing'!smoothingOn    smoothing _ 2.    self changed! !!TransformMorph methodsFor: 'submorphs-accessing' stamp: 'tk 5/22/97'!morphsAt: aPoint addTo: mList    "Return a collection of all morphs in this morph structure that contain the given point.  Map through my transform.  Must do this recursively because of transforms.  "    | p |    (self containsPoint: aPoint) ifFalse:        ["TransformMorph clips to bounds"        ^ mList].    p _ transform transform: aPoint.    submorphs do: [:m | m morphsAt: p addTo: mList].    mList addLast: self.    ^ mList! !!TransformMorph methodsFor: 'drawing'!fullDrawOn: aCanvas    "Overridden to clip submorph drawing to my bounds,    and to translate, rotate and scale as appropriate."    | clippingCanvas sourceQuad imageForm imageQuad warp innerRect |    (aCanvas isVisible: self bounds) ifFalse: [^ self].    self drawOn: aCanvas.    transform isPureTranslation        ifTrue:        [clippingCanvas _ aCanvas copyOffset: transform offset negated                                    clipRect: self innerBounds.        submorphs reverseDo: [:m | m fullDrawOn: clippingCanvas]]        ifFalse:        [innerRect _ self innerBounds.        sourceQuad _ transform sourceQuadFor: innerRect.        submorphs reverseDo:            [:m | imageForm _ m imageForm.            imageQuad _ sourceQuad collect: [:p | p - imageForm offset].            warp _ aCanvas warpFrom: imageQuad toRect: innerRect.            warp cellSize: smoothing;  "installs a colormap if smoothing > 1"                sourceForm: imageForm;                warpBits]]    ! !!TransformMorph methodsFor: 'geometry'!fullBounds    "Overridden to clip submorph hit detection to my bounds."    ^ bounds! !!TransformMorph methodsFor: 'geometry'!moveBy: delta    "Relocate me, but not my subMorphs"    (delta x = 0 and: [delta y = 0]) ifTrue: [^ self].  "Null change"    self changed.    self privateMoveBy: delta.    self offset: self offset - delta.    self changed! !!TransformMorph methodsFor: 'geometry'!submorphBounds    | subBounds |    subBounds _ nil.    self submorphsDo:        [:m |        subBounds ifNil: [subBounds _ m fullBounds]                ifNotNil: [subBounds _ subBounds quickMerge: m fullBounds]].    ^ subBounds! !!TransformMorph methodsFor: 'geometry'!superFullBounds    fullBounds := nil.    ^super fullBounds! !!TransformMorph methodsFor: 'change reporting'!changed    "Needs to be overridden to call superclass's invalidRect:."    super invalidRect: self fullBounds.! !!TransformMorph methodsFor: 'change reporting'!invalidRect: damageRect    "Translate damage reports from submorphs by the scrollOffset."    | affectedRect |    owner ifNil: [^ self].    transform isPureTranslation ifTrue:        [^ owner invalidRect: (transform invertRect: damageRect)].    affectedRect _ (transform invert: damageRect topLeft) extent: 0@0.    affectedRect _ affectedRect encompass: (transform invert: damageRect topRight).    affectedRect _ affectedRect encompass: (transform invert: damageRect bottomLeft).    affectedRect _ affectedRect encompass: (transform invert: damageRect bottomRight).    owner invalidRect: (affectedRect expandBy: 1)! !!TransformMorph methodsFor: 'events'!transformFrom: uberMorph    "Return a transform to map coorinates of uberMorph, a morph above me in my owner chain, into the coordinates of my submorphs."    owner == uberMorph ifTrue: [^ transform].    owner ifNil: [^ transform].    ^ (owner transformFrom: uberMorph) composedWith: transform! !!TransformMorph methodsFor: 'menu'!addCustomMenuItems: aCustomMenu hand: aHandMorph    smoothing = 1        ifTrue: [aCustomMenu add: 'turn on smoothing' action: #smoothingOn]        ifFalse: [aCustomMenu add: 'turn off smoothing' action: #smoothingOff]! !TranslucentColor comment:'A TranslucentColor behaves just like a normal color, except that it will pack its alpha value into the high byte of a 32-bit pixelValue.  This allows creating forms with translucency for use with the alpha blend function of BitBlt.  An alpha of zero is transparent, and 1.0 is opaque.'!!TranslucentColor methodsFor: 'accessing'!alpha    "Return my alpha value, a number between 0.0 and 1.0 where 0.0 is completely transparent and 1.0 is completely opaque."    ^ alpha asFloat / 255.0! !!TranslucentColor methodsFor: 'equality'!hash    ^ rgb bitXor: alpha! !!TranslucentColor methodsFor: 'printing'!storeOn: aStream    super storeOn: aStream.    aStream        skip: -1;      "get rid of trailing )"        nextPutAll: ' alpha: ';        nextPutAll: alpha printString;        nextPutAll: ')'.! !!TranslucentColor methodsFor: 'conversions'!pixelWordForDepth: depth    "Return the pixel value for this color at the given depth. Translucency only works at a bit-depth of 32; this color will appear opaque at all other depths."    | basicPixelWord |    basicPixelWord _ super pixelWordForDepth: depth.    depth < 32        ifTrue: [^ basicPixelWord]        ifFalse: [^ basicPixelWord bitOr: (alpha bitShift: 24)].! !!TranslucentColor methodsFor: 'private'!privateAlpha    "Return my raw alpha value, an integer in the range 0..255. Used for fast equality testing."    ^ alpha! !!TranslucentColor methodsFor: 'private'!setRgb: rgbValue alpha: alphaValue    "Set the state of this translucent color. Alpha is represented internally by an integer in the range 0..255."    rgb == nil ifFalse: [self attemptToMutateError].    rgb _ rgbValue.    alpha _ (255.0 * alphaValue) asInteger min: 255 max: 0.! !TransparentColor class comment:'An instance of me is the transparent color.  My pixel value is 0 in any depth.  A NullColor is also used when no fill color is desired, as with the background of transparent text.  It will produce all zeroes in any color map entry initialized from it.  In combination with BitBlt paint mode (which does not store zeroes), this will result in transparency.  Note that when this approach is being used in RGB, true black will look the same as a null color, unless you put something in the alpha bits, or use an off-color black.Transparent _ NullColor r: 0 g: 0 b: 0.Color transparent'!!TransparentColor methodsFor: 'equality'!= aColor    ^ aColor isTransparent! !!TransparentColor methodsFor: 'equality'!hash    ^ 0! !!TransparentColor methodsFor: 'queries'!isColor    "I'm not a real color."    ^ false! !!TransparentColor methodsFor: 'queries'!isTransparent    ^ true! !!TransparentColor methodsFor: 'transformations'!* aFactor    ^ self! !!TransparentColor methodsFor: 'transformations'!+ aColor    ^ aColor! !!TransparentColor methodsFor: 'transformations'!- aColor    ^ self! !!TransparentColor methodsFor: 'transformations'!/ aFactor    ^ self! !!TransparentColor methodsFor: 'transformations'!darker    ^ self! !!TransparentColor methodsFor: 'transformations'!lighter    ^ self! !!TransparentColor methodsFor: 'transformations'!mixed: proportion with: aColor    ^ aColor alpha: (1.0 - proportion)! !!TransparentColor methodsFor: 'printing'!shortPrintString    ^ 'Transparent'! !!TransparentColor methodsFor: 'printing'!storeOn: aStream    aStream nextPutAll: '(Color transparent)'.! !!TransparentColor methodsFor: 'conversions'!bitPatternForDepth: depth    ^ Bitmap with: 0! !!TransparentColor methodsFor: 'conversions'!pixelValueForDepth: d    ^ 0! !!TransparentColor methodsFor: 'conversions'!pixelWordForDepth: depth    ^ 0! !!TransparentColor methodsFor: 'private'!setRed: r green: g blue: b    "Ignored."! !!TrashCanMorph methodsFor: 'all'!acceptDroppingMorph: aMorph event: evt    aMorph delete.! !!TrashCanMorph methodsFor: 'all'!addLabel    | m |    self removeAllMorphs.    m _ StringMorph new contents: 'Trash'.    self extent: (m width + 6) @ (m height + 10).    m position: self center - (m extent // 2).    self addMorph: m.! !!TrashCanMorph methodsFor: 'all' stamp: 'jm 6/15/97 13:33'!initialize    super initialize.    color _ (Color r: 0.4 g: 0.4 b: 1.0).    self addLabel.! !!TrashCanMorph methodsFor: 'all'!wantsDroppedMorph: aMorph event: evt    ^ true! !!TReturnNode methodsFor: 'all'!bindVariablesIn: aDictionary    expression _ expression bindVariablesIn: aDictionary.! !!TReturnNode methodsFor: 'all'!copyTree    ^self class new        setExpression: expression copyTree! !!TReturnNode methodsFor: 'all'!emitCCodeOn: aStream level: level generator: aCodeGen    aStream nextPutAll: 'return '.    expression emitCCodeOn: aStream level: level generator: aCodeGen.! !!TReturnNode methodsFor: 'all'!expression    ^expression! !!TReturnNode methodsFor: 'all'!inlineMethodsUsing: aDictionary    expression _ expression inlineMethodsUsing: aDictionary.! !!TReturnNode methodsFor: 'all'!isReturn    ^true! !!TReturnNode methodsFor: 'all'!nodesDo: aBlock    expression nodesDo: aBlock.    aBlock value: self.! !!TReturnNode methodsFor: 'all'!printOn: aStream level: level    aStream nextPut: $^.    expression printOn: aStream level: level.! !!TReturnNode methodsFor: 'all'!replaceNodesIn: aDictionary    ^aDictionary at: self ifAbsent: [        expression _ expression replaceNodesIn: aDictionary.        self]! !!TReturnNode methodsFor: 'all'!setExpression: aNode    expression _ aNode.! !!TSendNode methodsFor: 'all'!args    ^arguments! !!TSendNode methodsFor: 'all'!bindVariablesIn: aDictionary    receiver _ receiver bindVariablesIn: aDictionary.    arguments _ arguments collect: [ :a | a bindVariablesIn: aDictionary ].! !!TSendNode methodsFor: 'all'!copyTree    ^self class new        setSelector: selector        receiver: receiver copyTree        arguments: (arguments collect: [ :arg | arg copyTree ])        isBuiltInOp: isBuiltinOperator! !!TSendNode methodsFor: 'all'!emitCCodeOn: aStream level: level generator: aCodeGen    "If the selector is a built-in construct, translate it and return"    (aCodeGen emitBuiltinConstructFor: self on: aStream level: level) ifTrue: [ ^self ].    "Translate this message send into a C function call."    aStream nextPutAll: (aCodeGen cFunctionNameFor: selector), '('.    (receiver isVariable and:     [(receiver name = 'self') or: [receiver name = 'interpreterProxy']]) ifFalse: [        "self is omitted from the arguments list of the generated call"        "Note: special case for translated BitBltSimulator--also omit         the receiver if this is a send to the variable 'interpreterProxy'"        receiver emitCCodeOn: aStream level: level generator: aCodeGen.        arguments isEmpty ifFalse: [ aStream nextPutAll: ', ' ].    ].    1 to: arguments size do: [ :i |        (arguments at: i) emitCCodeOn: aStream level: level generator: aCodeGen.        i < arguments size ifTrue: [ aStream nextPutAll: ', ' ].    ].    aStream nextPutAll: ')'.! !!TSendNode methodsFor: 'all'!inlineMethodsUsing: aDictionary    arguments _ arguments collect: [ :arg |        arg inlineMethodsUsing: aDictionary.    ].    "xxx inline this message if it is in the dictionary xxx"! !!TSendNode methodsFor: 'all'!isBuiltinOperator    ^ isBuiltinOperator! !!TSendNode methodsFor: 'all'!isBuiltinOperator: builtinFlag    isBuiltinOperator _ builtinFlag.! !!TSendNode methodsFor: 'all'!isSend    ^true! !!TSendNode methodsFor: 'all'!nodesDo: aBlock    receiver nodesDo: aBlock.    arguments do: [ :arg | arg nodesDo: aBlock ].    aBlock value: self.! !!TSendNode methodsFor: 'all'!printOn: aStream level: level    | keywords |    receiver printOn: aStream level: level.    arguments size = 0 ifTrue: [        aStream space; nextPutAll: selector.        ^self    ].    keywords _ selector keywords.    1 to: keywords size do: [ :i |        aStream space.        aStream nextPutAll: (keywords at: i); space.        (arguments at: i) printOn: aStream level: level + 1.    ].! !!TSendNode methodsFor: 'all'!receiver    ^receiver! !!TSendNode methodsFor: 'all'!receiver: aNode    receiver _ aNode.! !!TSendNode methodsFor: 'all'!replaceNodesIn: aDictionary    ^aDictionary at: self ifAbsent: [        receiver _ receiver replaceNodesIn: aDictionary.        arguments _ arguments collect: [ :a | a replaceNodesIn: aDictionary ].        self]! !!TSendNode methodsFor: 'all'!selector    ^selector! !!TSendNode methodsFor: 'all'!setSelector: aSymbol receiver: rcvrNode arguments: argList    selector _ aSymbol.    receiver _ rcvrNode.    arguments _ argList asArray.    isBuiltinOperator _ false.! !!TSendNode methodsFor: 'all'!setSelector: aSymbol receiver: rcvrNode arguments: argList isBuiltInOp: builtinFlag    selector _ aSymbol.    receiver _ rcvrNode.    arguments _ argList asArray.    isBuiltinOperator _ builtinFlag.! !!TStmtListNode methodsFor: 'all'!args    ^arguments! !!TStmtListNode methodsFor: 'all'!bindVariablesIn: aDictionary    statements _ statements collect: [ :s | s bindVariablesIn: aDictionary ].! !!TStmtListNode methodsFor: 'all'!copyTree    ^self class new        setArguments: arguments copy        statements: (statements collect: [ :s | s copyTree ])! !!TStmtListNode methodsFor: 'all'!emitCCodeOn: aStream level: level generator: aCodeGen    statements do: [ :s |        level timesRepeat: [ aStream tab ].        s emitCCodeOn: aStream level: level generator: aCodeGen.        ((self endsWithCloseBracket: aStream) or: [s isComment]) ifFalse: [ aStream nextPut: $; ].        aStream cr.    ].! !!TStmtListNode methodsFor: 'all'!endsWithCloseBracket: aStream    "Answer true if the given stream ends in with $} character."    | ch pos |    (pos _ aStream position) > 0 ifTrue: [        aStream position: pos - 1.        ch _ aStream next.        aStream position: pos.    ].    ^ ch = $}" *** There's something wrong with File positioning.  If you execute the following code, it will print '(hello));;' , but it will give an error if you remove the line the says    f position: f position. | f c p1 p2 p3 | f _ FileStream fileNamed: 'test'.f nextPutAll: '(hello))'.f position: (p1 _ f position)-1.p2 _ f position.c _ f next.p3 _ f position.f position: f position.f nextPut: $;; nextPut: $;.f close.(FileStream fileNamed: 'test') contentsOfEntireFile"! !!TStmtListNode methodsFor: 'all'!inlineMethodsUsing: aDictionary    statements do: [ :s | s inlineMethodsUsing: aDictionary ].! !!TStmtListNode methodsFor: 'all'!isStmtList    ^true! !!TStmtListNode methodsFor: 'all'!nodesDo: aBlock    statements do: [ :s | s nodesDo: aBlock ].        aBlock value: self.! !!TStmtListNode methodsFor: 'all'!printOn: aStream level: level    aStream nextPut: $[.    arguments size > 0 ifTrue: [        arguments do: [ :arg | aStream nextPutAll: ' :', arg ].        aStream nextPutAll: ' | '.    ].    self printStatementsOn: aStream level: level.    aStream nextPut: $].! !!TStmtListNode methodsFor: 'all'!printStatementsOn: aStream level: level    statements size > 1 ifTrue: [ aStream crtab: level + 1 ].    1 to: statements size do: [ :i |        (statements at: i) printOn: aStream level: level.        i = statements size ifTrue: [            (statements size > 1) ifTrue: [                aStream crtab: level.            ].        ] ifFalse: [            aStream nextPut: $.; crtab: level + 1.        ].    ].! !!TStmtListNode methodsFor: 'all'!replaceNodesIn: aDictionary    ^aDictionary at: self ifAbsent: [        statements _ statements collect: [ :s | s replaceNodesIn: aDictionary ].        self]! !!TStmtListNode methodsFor: 'all'!setArguments: argList    arguments _ argList.! !!TStmtListNode methodsFor: 'all'!setArguments: argList statements: statementList    "Initialize this method using the given information."    arguments _ argList.    statements _ statementList.! !!TStmtListNode methodsFor: 'all'!setStatements: stmtList    statements _ stmtList asOrderedCollection.! !!TStmtListNode methodsFor: 'all'!statements    ^statements! !!TVariableNode methodsFor: 'all'!bindVariablesIn: aDictionary    | newNode |    newNode _ aDictionary at: name asSymbol ifAbsent: [ ^self ].    ^newNode copyTree! !!TVariableNode methodsFor: 'all'!copyTree    ^self class new setName: name! !!TVariableNode methodsFor: 'all'!emitCCodeOn: aStream level: level generator: aCodeGen    name = 'nil'        ifTrue: [ aStream nextPutAll: (aCodeGen cLiteralFor: nil) ]        ifFalse: [ aStream nextPutAll: name ].! !!TVariableNode methodsFor: 'all'!isLeaf    ^true! !!TVariableNode methodsFor: 'all'!isVariable    ^true! !!TVariableNode methodsFor: 'all'!name    ^name! !!TVariableNode methodsFor: 'all'!printOn: aStream level: level    aStream nextPutAll: name.! !!TVariableNode methodsFor: 'all'!setName: aString    name _ aString.! !!UndefinedObject methodsFor: 'testing'!ifNil: aBlock    "A convenient test, in conjunction with Object ifNil:"    ^ aBlock value! !!UndefinedObject methodsFor: 'testing'!ifNil: nilBlock ifNotNil: ifNotNilBlock    "Evaluate the block for nil because I'm == nil"    ^ nilBlock value! !!UndefinedObject methodsFor: 'testing'!ifNotNil: aBlock    "A convenient test, in conjunction with Object ifNotNil:"    ^ self! !!UndefinedObject methodsFor: 'testing'!ifNotNil: ifNotNilBlock ifNil: nilBlock     "If I got here, I am nil, so evaluate the block nilBlock"    ^ nilBlock value! !!UndefinedObject methodsFor: 'dependents access'!addDependent: ignored     "Refer to the comment in Object|dependents."    self error: 'Nil should not have dependents'! !!UndefinedObject methodsFor: 'class hierarchy'!subclass: nameOfClass  "Define root (superclass = nil) of a class hierarchy"    instanceVariableNames: instVarNames    classVariableNames: classVarNames    poolDictionaries: poolDictnames    category: category    | newClass |    newClass _ Object subclass: nameOfClass  "First, define as a normal class"    instanceVariableNames: instVarNames    classVariableNames: classVarNames    poolDictionaries: poolDictnames    category: category.    Object removeSubclass: newClass.   "Then remove it from the old hierarchy"    newClass superclass: nil.    ^ newClass! !!UnixFileDirectory methodsFor: 'file creation'!fileClass    ^ StandardFileStream! !!UnixFileDirectory methodsFor: 'private' stamp: 'jm 9/17/97 15:43'!setPathName: pathString    (pathString isEmpty or: [pathString first ~= self pathNameDelimiter])        ifTrue: [pathName _ self pathNameDelimiter asString, pathString]        ifFalse: [pathName _ pathString].! !!UnixFileDirectory methodsFor: 'file names' stamp: 'jm 9/17/97 15:48'!fullNameFor: fileName    "Return the fully-qualified path name for the given file. Correct syntax errors in the file name."    FileDirectory splitName: fileName to: [:path :localName |        ^ (path isEmpty ifFalse: [path] ifTrue: [            pathName = self pathNameDelimiter asString ifTrue: [''] ifFalse: [pathName]]),                self pathNameDelimiter asString, (self checkName: localName fixErrors: true)].! !!UnixFileDirectory class methodsFor: 'initialization' stamp: 'jm 9/17/97 15:48'!pathNameDelimiter    ^ $/! !UnsavableWorkspace comment:'A workspace whose window will happily close without warning when the user so requests.  Used for throwaway windows, for example, to hold help messages..  1/27/96 sw'!!UpdatingStringMorph methodsFor: 'initialization'!initialize    super initialize.    format _ #default.  "formats: #string, #default"    target _ getSelector _ putSelector _ nil.! !!UpdatingStringMorph methodsFor: 'accessing'!getSelector    ^ getSelector! !!UpdatingStringMorph methodsFor: 'accessing'!getSelector: aSymbol    getSelector _ aSymbol.! !!UpdatingStringMorph methodsFor: 'accessing'!putSelector    ^ putSelector! !!UpdatingStringMorph methodsFor: 'accessing'!putSelector: aSymbol    putSelector _ aSymbol.! !!UpdatingStringMorph methodsFor: 'accessing'!target    ^ target! !!UpdatingStringMorph methodsFor: 'accessing'!target: anObject    target _ anObject.! !!UpdatingStringMorph methodsFor: 'stepping'!step    | s |    hasFocus ifFalse: [        "update contents, but only if user isn't editing this string"        s _ self readFromTarget.        s = contents ifFalse: [self contentsClipped: s]].! !!UpdatingStringMorph methodsFor: 'stepping'!stepTime    ^ 50! !!UpdatingStringMorph methodsFor: 'formats'!useDefaultFormat    "Use the object's own printString format."    format _ #default.! !!UpdatingStringMorph methodsFor: 'formats'!useStringFormat    format _ #string.! !!UpdatingStringMorph methodsFor: 'target access'!informTarget    | newValue |    ((target ~~ nil) and: [putSelector ~~ nil]) ifTrue: [        newValue _ self valueFromContents.        target perform: putSelector with: newValue.        target isMorph ifTrue: [target changed]].! !!UpdatingStringMorph methodsFor: 'target access'!readFromTarget    | v |    ((target == nil) or: [getSelector == nil]) ifTrue: [^ contents].    v _ target perform: getSelector.    lastValue _ v.    format = #string ifTrue: [^ v].    (format = #default and: [v isNumber]) ifTrue: [        v isInteger ifTrue: [^ v asInteger printString].        (v isKindOf: Float) ifTrue: [^ (v roundTo: 0.01) printString]].    ^ v printString  "default: use object's printString"! !!UpdatingStringMorph methodsFor: 'target access'!valueFromContents    "Return a new value from the current contents string."    format = #string ifTrue: [^ contents].    ^ Compiler evaluate: contents! !!UpdatingStringMorph methodsFor: 'editing'!acceptContents    self informTarget.! !!UpdatingStringMorph methodsFor: 'editing'!keyStroke: evt    "Handle a keystroke event. Accept change if enter key or Cmd-S is pressed."    ((evt keyCharacter = Character enter) or:     [(evt keyCharacter = Character cr) or:     [evt keyCharacter = $s and: [evt commandKeyPressed]]]) ifTrue: [        self informTarget.        evt hand newKeyboardFocus: evt hand world.        ^ self].    super keyStroke: evt.! !!Utilities class methodsFor: 'investigations'!inspectGlobals    "Utilities  inspectGlobals"    | associations aDict |    associations _ ((Smalltalk keys select: [:aKey | ((Smalltalk at: aKey) isKindOf: Class) not]) asSortedArray collect:        [:aKey | Smalltalk associationAt: aKey]).    aDict _ IdentityDictionary new.    associations do: [:as | aDict add: as].    aDict inspectWithLabel: 'The Globals'! !!Utilities class methodsFor: 'identification' stamp: 'sw 1/18/96'!authorInitials    "Answer the initials to be used to identify the current code author.  "    [AuthorInitials isEmpty] whileTrue: [self setAuthorInitials].    ^ AuthorInitials! !!Utilities class methodsFor: 'identification' stamp: 'di 6/13/97 13:00'!changeStamp     "Answer a string to be pasted into source code to mark who changed it and when."    ^ self authorInitials , ' ' , Date today mmddyy, ' ',        ((String streamContents: [:s | Time now print24: true on: s]) copyFrom: 1 to: 5)! !!Utilities class methodsFor: 'identification' stamp: 'di 6/13/97 13:52'!fixStamp: changeStamp     | parts |    parts _ changeStamp findTokens: ' '.    (parts size > 0 and: [parts last first isLetter]) ifTrue:        ["Put initials first in all time stamps..."        ^ String streamContents:                [:s | s nextPutAll: parts last.                parts allButLast do: [:p | s space; nextPutAll: p]]].    ^ changeStamp! !!Utilities class methodsFor: 'identification' stamp: 'sw 5/10/96'!setAuthorInitials    "Put up a dialog allowing the user to specify the author's initials.  "    AuthorInitials _ FillInTheBlank request: 'Please type your initals: '            initialAnswer: AuthorInitials.! !!Utilities class methodsFor: 'support windows'!commandKeyMappings    ^ self class firstCommentAt: #commandKeyMappings"Lower-case command keysa    Select allb    Browse itc    Copyd    Do ite    Exchangef    Findg    Find againh    Set Search Stringi    Inspect itj    Again oncek    Set fontl    Cancelm    Implementors of itn    Senders of ito    Spawnp    Print itq    Query symbolr    Recognizers    Save (i.e. accept)u    Alignv    Pastew    Delete preceding wordx    Cuty    Swap charactersz    UndoUpper-case command keys (Hold down Cmd & Shift, or Ctrl key)A    Advance argumentB    Browse it in this same browser (in System browsers only)C    Compare argument to clipboardD    DuplicateF    Insert 'ifFalse:'J    Again manyK    Set styleL    Outdent (move selection one tab-stop left)N    References to itR    Indent (move selection one tab-stap right)S    SearchT    Insert 'ifTrue:'W    Selectors containing itV    Paste author's initials<return>        Insert return followed by as many tabs as the previous line            (with a further adjustment for additional brackets in that line)esc            Select current type-inshift-delete    Forward delete character (not currently undo-able)[    Enclose within [ and ], or remove enclosing [ and ](    Enclose within ( and ), or remove enclosing ( and )   NB: use ctrl ({    Enclose within { and }, or remove enclosing { and }<    Enclose within < and >, or remove enclosing < and >'    Enclose within ' and ', or remove enclosing ' and '""    Enclose within "" and "", or remove enclosing "" and ""1    10 point font2    12 point font3    18 point font  (not in base image)4    24 point font  (not in base image)5    8 point font  (not in base image)6    add color / make active    (nb: to remove the active quality of text, you must select    more than the active part and then use command-0)7    bold8    italic9    narrow0    plain text (resets all emphasis)-    underlined=    struck out"    "Answer a string to be presented in a window at user request as a crib sheet for command-key mappings.  2/7/96 sw5/1/96 sw: modified so that the long string lives in a comment, hence doesn't take up memory.  Also, fixed up some of the actual text, and added help for parentheses-enclosing items and text-style controls.5/10/96 sw: added a bunch of changes at JM's suggestion8/11/96 sw: fixed the font sizes, added align & references to it, and help for cmd-shift-B11/2/96 di: added ctrl-return and shift-delete, and new assignments of cmd 0-911/7/96 di: new assignments of cmd 0-9, with - and = "! !!Utilities class methodsFor: 'user interface' stamp: 'di 9/1/96'!informUser: aString during: aBlock    "Put a message above (or below if insufficient room) the cursor.     Like informUser:while:, but end when aBlock ends.  "    (SelectionMenu labels: '') displayAt: Sensor cursorPoint        withCaption: aString during: [aBlock value]! !!Utilities class methodsFor: 'user interface' stamp: 'sw 1/22/96'!informUser: aString while: aBlock    "Put a message above (or below if insufficient room) the cursor.     "    "Utilities informUser: 'How do you do' while: [Sensor anyButtonPressed not]"    | cp  |    cp _ Sensor cursorPoint.    (SelectionMenu labels: '') displayAt: cp                withCaption: aString                during: [[aBlock value] whileTrue]! !!Utilities class methodsFor: 'common requests' stamp: 'sw 12/12/96'!commonRequestStrings: aString    "Initialize the common request strings from aString.  "    CommonRequestStrings _ StringHolder new contents: aString! !!Utilities class methodsFor: 'recent method submissions' stamp: 'sw 1/17/97'!browseRecentSubmissions    "Open up a browser on the most recent methods submitted in the image.  5/96 sw.    5/29/96 sw: fixed so the browser doesn't go all wonkie after you submit more code    : reverse the order, have most recent submissions at the top of the list        : use RecentMessageList"    "Utilities browseRecentSubmissions"    | recentMessages |    self recentMethodSubmissions size == 0 ifTrue:        [^ SelectionMenu notify: 'There are no recent submissions'].        recentMessages _ RecentSubmissions copy reversed.    RecentMessageSet openMessageList: recentMessages name: 'Recently submitted methods -- youngest first ' autoSelect: nil! !!Utilities class methodsFor: 'recent method submissions'!recentlySubmittedMessages    ^ RecentSubmissions copy reversed! !!VariableNode methodsFor: 'initialize-release'!name: varName index: i type: type    "Only used for initting instVar refs"    name _ varName.    self key: varName        index: i        type: type! !!VariableNode methodsFor: 'initialize-release'!name: string key: object code: byte    "Only used for initting std variables, nil, true, false, self, etc."    name _ string.    key _ object.    code _ byte! !!VariableNode methodsFor: 'initialize-release'!name: varName key: objRef index: i type: type    "Only used for initting global (litInd) variables"    name _ varName.    self key: objRef        index: i        type: type! !!VariableNode methodsFor: 'testing'!assignmentCheck: encoder at: location    (encoder cantStoreInto: name)        ifTrue: [^ location]        ifFalse: [^ -1]! !!VariableNode methodsFor: 'testing'!isTemp    ^ false! !!VariableNode methodsFor: 'code generation'!emitForValue: stack on: strm    code < 256        ifTrue:             [strm nextPut: (code = LdSuper ifTrue: [LdSelf] ifFalse: [code]).            stack push: 1]        ifFalse:             [self emitLong: LoadLong on: strm.            stack push: 1]! !!VariableNode methodsFor: 'code generation'!emitStorePop: stack on: strm    (code between: 0 and: 7)        ifTrue:             [strm nextPut: ShortStoP + code "short stopop inst"]        ifFalse:            [(code between: 16 and: 23)                ifTrue: [strm nextPut: ShortStoP + 8 + code - 16 "short stopop temp"]                ifFalse: [(code >= 256 and: [code \\ 256 > 63 and: [code // 256 = 4]])                        ifTrue: [self emitLong: Store on: strm. strm nextPut: Pop]                        ifFalse: [self emitLong: StorePop on: strm]]].    stack pop: 1! !!VariableNode methodsFor: 'code generation'!sizeForStore: encoder    self reserve: encoder.    code < 256 ifTrue: [^ 2].    (code \\ 256) <= 63 ifTrue: [^ 2].    ^ 3! !!VariableNode methodsFor: 'code generation'!sizeForStorePop: encoder    self reserve: encoder.    (code < 24 and: [code noMask: 8]) ifTrue: [^ 1].    code < 256 ifTrue: [^ 2].    code \\ 256 <= 63 ifTrue: [^ 2].  "extended StorePop"    code // 256 = 1 ifTrue: [^ 3].  "dbl extended StorePopInst"    code // 256 = 4 ifTrue: [^ 4].  "dbl extended StoreLitVar , Pop"    self halt.  "Shouldn't get here"! !!VariableNode methodsFor: 'printing'!printOn: aStream indent: level     aStream nextPutAll: name! !!VariableNode methodsFor: 'C translation'!asTranslatorNode    ^TVariableNode new setName: name! !!VariableNode class methodsFor: 'class initialization'!initialize    "VariableNode initialize.  Decompiler initialize"    | encoder |    encoder _ Encoder new.    StdVariables _ Dictionary new: 16.    encoder        fillDict: StdVariables        with: VariableNode        mapping: #('self' 'thisContext' 'super' 'nil' 'false' 'true' )        to: (Array with: LdSelf with: LdThisContext with: LdSuper)                , (Array with: LdNil with: LdFalse with: LdTrue).    StdSelectors _ Dictionary new: 64.    encoder        fillDict: StdSelectors        with: SelectorNode        mapping: ((1 to: Smalltalk specialSelectorSize) collect:                             [:i | Smalltalk specialSelectorAt: i])        to: (SendPlus to: SendPlus + 31).    StdLiterals _ LiteralDictionary new: 16.    encoder        fillDict: StdLiterals        with: LiteralNode        mapping: #(-1 0 1 2 )        to: (LdMinus1 to: LdMinus1 + 3).    encoder initScopeAndLiteralTables.    NodeNil _ encoder encodeVariable: 'nil'.    NodeTrue _ encoder encodeVariable: 'true'.    NodeFalse _ encoder encodeVariable: 'false'.    NodeSelf _ encoder encodeVariable: 'self'.    NodeThisContext _ encoder encodeVariable: 'thisContext'.    NodeSuper _ encoder encodeVariable: 'super'! !!View methodsFor: 'testing'!bordersOn: otherView along: herSide     | myBox herBox |    myBox _ self displayBox.    herBox _ otherView displayBox.    (herSide = #right and: [myBox left = herBox right])    | (herSide = #left and: [myBox right = herBox left])        ifTrue:        [^ (myBox top max: herBox top) <= (myBox bottom min: herBox bottom)].    (herSide = #bottom and: [myBox top = herBox bottom])    | (herSide = #top and: [myBox bottom = herBox top])        ifTrue:        [^ (myBox left max: herBox left) <= (myBox right min: herBox right)].    ^ false! !!View methodsFor: 'testing'!containsPoint: aPoint    "Answer whether aPoint is within the receiver's display box. It is sent to     a View's subViews by View|subViewAt: in order to determine which     subView contains the cursor point (so that, for example, control can be     pass down to that subView's controller)."    ^ self insetDisplayBox containsPoint: aPoint! !!View methodsFor: 'deEmphasizing'!deEmphasizeForDebugger    "Overridden by StandardSystemView. This default behavior does nothing."! !!View methodsFor: 'bordering'!backgroundColor    insideColor == nil ifFalse:        [(insideColor isMemberOf: Symbol) ifTrue:            [^ Color perform: insideColor].        ^ insideColor].    superView == nil ifFalse: [^ superView backgroundColor].    ^ Color white! !!View methodsFor: 'bordering'!backgroundColor: aColor    Display depth = 1 ifTrue:        [(aColor ~= nil and: [aColor ~= Color transparent]) ifTrue:            ["Avoid stipple due to attempts to match non-whites"            ^ insideColor _ Color white]].    insideColor _ aColor! !!View methodsFor: 'bordering'!foregroundColor    borderColor == nil ifFalse:        [(borderColor isMemberOf: Symbol) ifTrue:            [^ Color perform: borderColor].        ^ borderColor].    superView == nil ifFalse: [^ superView foregroundColor].    ^ Color black! !!View methodsFor: 'clearing'!clear    "Use the border color to paint the display box (including the border, see     View|displayBox) of the receiver."    borderColor ~= nil ifTrue: [self clear: Color black]! !!View methodsFor: 'miscellaneous'!stretchFrame: newFrameBlock startingWith: startFrame     "Track the outline of a newFrame as long as mouse drags it.    Maintain max and min constraints throughout the drag"    | frame newFrame click |    frame _ startFrame origin extent: ((startFrame extent min: self maximumSize)                                            max: self minimumSize).    Display border: frame width: 2 rule: Form reverse fillColor: Color gray.    click _ false.    [click and: [Sensor noButtonPressed]] whileFalse:         [Processor yield.        click _ click | Sensor anyButtonPressed.        newFrame _ newFrameBlock value: frame.        newFrame _ newFrame topLeft extent: ((newFrame extent min: self maximumSize)                                            max: self minimumSize).        newFrame = frame ifFalse:            [Display border: frame width: 2 rule: Form reverse fillColor: Color gray.            Display border: newFrame width: 2 rule: Form reverse fillColor: Color gray.            frame _ newFrame]].    Display border: frame width: 2 rule: Form reverse fillColor: Color gray.    ^ frame! !!WarpBlt methodsFor: 'setup'!cellSize    ^ cellSize! !!WarpBlt methodsFor: 'setup'!cellSize: s    cellSize _ s.    cellSize = 1 ifTrue: [^ self].    cellSize > 3 ifTrue:        [(self confirm:'Do you really want to averagemore than 3x3 pixels?') ifFalse: [self halt]].    colorMap _ Color colorMapIfNeededFrom: 32 to: destForm depth.! !!WarpBlt methodsFor: 'smoothing' stamp: 'di 6/24/97 00:09'!mixPix: pix sourceMap: sourceMap destMap: destMap    "Average the pixels in array pix to produce a destination pixel.    First average the RGB values either from the pixels directly,    or as supplied in the sourceMap.  Then return either the resulting    RGB value directly, or use it to index the destination color map."     | r g b rgb nPix bitsPerColor d |    nPix _ pix size.    r _ 0. g _ 0. b _ 0.    1 to: nPix do:        [:i |   "Sum R, G, B values for each pixel"        rgb _ sourceForm depth <= 8                ifTrue: [sourceMap at: (pix at: i) + 1]                ifFalse: [sourceForm depth = 32                        ifTrue: [pix at: i]                        ifFalse: [self rgbMap: (pix at: i) from: 5 to: 8]].        r _ r + ((rgb bitShift: -16) bitAnd: 16rFF).        g _ g + ((rgb bitShift: -8) bitAnd: 16rFF).        b _ b + ((rgb bitShift: 0) bitAnd: 16rFF)].    destMap == nil        ifTrue: [bitsPerColor _ 3.  "just in case eg depth <= 8 and no map"                destForm depth = 16 ifTrue: [bitsPerColor _ 5].                destForm depth = 32 ifTrue: [bitsPerColor _ 8]]        ifFalse: [destMap size = 512 ifTrue: [bitsPerColor _ 3].                destMap size = 4096 ifTrue: [bitsPerColor _ 4].                destMap size = 32768 ifTrue: [bitsPerColor _ 5]].    d _ bitsPerColor - 8.    rgb _ ((r // nPix bitShift: d) bitShift: bitsPerColor*2)        + ((g // nPix bitShift: d) bitShift: bitsPerColor)        + ((b // nPix bitShift: d) bitShift: 0).    destMap == nil        ifTrue: [^ rgb]        ifFalse: [^ destMap at: rgb+1]! !!WarpBlt methodsFor: 'smoothing' stamp: 'di 6/24/97 00:08'!rgbMap: sourcePixel from: nBitsIn to: nBitsOut    "NOTE: This code is copied verbatim from BitBltSimulation so that it    may be removed from the system"    "Convert the given pixel value with nBitsIn bits for each color component to a pixel value with nBitsOut bits for each color component. Typical values for nBitsIn/nBitsOut are 3, 5, or 8."    | mask d srcPix destPix |    self inline: true.    (d _ nBitsOut - nBitsIn) > 0        ifTrue:            ["Expand to more bits by zero-fill"            mask _ (1 << nBitsIn) - 1.  "Transfer mask"            srcPix _ sourcePixel << d.            mask _ mask << d.            destPix _ srcPix bitAnd: mask.            mask _ mask << nBitsOut.            srcPix _ srcPix << d.            ^ destPix + (srcPix bitAnd: mask)                     + (srcPix << d bitAnd: mask << nBitsOut)]        ifFalse:            ["Compress to fewer bits by truncation"            d = 0 ifTrue: [^ sourcePixel].  "no compression"            sourcePixel = 0 ifTrue: [^ sourcePixel].  "always map 0 (transparent) to 0"            d _ nBitsIn - nBitsOut.            mask _ (1 << nBitsOut) - 1.  "Transfer mask"            srcPix _ sourcePixel >> d.            destPix _ srcPix bitAnd: mask.            mask _ mask << nBitsOut.            srcPix _ srcPix >> d.            destPix _ destPix + (srcPix bitAnd: mask)                    + (srcPix >> d bitAnd: mask << nBitsOut).            destPix = 0 ifTrue: [^ 1].  "Dont fall into transparent by truncation"            ^ destPix]! !!WarpBlt methodsFor: 'primitives'!copyQuad: pts toRect: destRect    self sourceQuad: pts destRect: destRect.    self warpBits! !!WarpBlt methodsFor: 'primitives'!deltaFrom: x1 to: x2 nSteps: n    "Utility routine for computing Warp increments.    x1 is starting pixel, x2 is ending pixel;  assumes n >= 1"    | fixedPtOne |    fixedPtOne _ 16384.  "1.0 in fixed-pt representation"    x2 > x1        ifTrue: [^ x2 - x1 + fixedPtOne // (n+1) + 1]        ifFalse: [x2 = x1 ifTrue: [^ 0].                ^ 0 - (x1 - x2 + fixedPtOne // (n+1) + 1)]! !!WarpBlt methodsFor: 'primitives'!sourceQuad: pts destRect: aRectangle    | fixedPt1 |    sourceX _ sourceY _ 0.    self destRect: aRectangle.    fixedPt1 _ (pts at: 1) x isInteger ifTrue: [16384] ifFalse: [16384.0].    p1x _ (pts at: 1) x * fixedPt1.    p2x _ (pts at: 2) x * fixedPt1.    p3x _ (pts at: 3) x * fixedPt1.    p4x _ (pts at: 4) x * fixedPt1.    p1y _ (pts at: 1) y * fixedPt1.    p2y _ (pts at: 2) y * fixedPt1.    p3y _ (pts at: 3) y * fixedPt1.    p4y _ (pts at: 4) y * fixedPt1.    p1z _ p2z _ p3z _ p4z _ 16384.  "z-warp ignored for now"! !!WarpBlt methodsFor: 'primitives'!startFrom: x1 to: x2 offset: sumOfDeltas    "Utility routine for computing Warp increments."    x2 >= x1        ifTrue: [^ x1]        ifFalse: [^ x2 - sumOfDeltas]! !!WarpBlt methodsFor: 'primitives'!warpBits    "Move those pixels!!"    self warpBitsSmoothing: cellSize        sourceMap: (Color colorMapIfNeededFrom: sourceForm depth to: 32).! !!WarpBlt methodsFor: 'primitives'!warpBitsSmoothing: n sourceMap: sourceMap    | deltaP12 deltaP43 pA pB deltaPAB sp fixedPtOne picker poker pix nSteps |    <primitive: 147>    (width < 1) | (height < 1) ifTrue: [^ self].    fixedPtOne _ 16384.  "1.0 in fixed-pt representation"    n > 1 ifTrue:        [(destForm depth < 16 and: [colorMap == nil])            ifTrue: ["color map is required to smooth non-RGB dest"                    ^ self primitiveFail].        pix _ Array new: n*n].    nSteps _ height-1 max: 1.    deltaP12 _ (self deltaFrom: p1x to: p2x nSteps: nSteps)            @ (self deltaFrom: p1y to: p2y nSteps: nSteps).    pA _ (self startFrom: p1x to: p2x offset: nSteps*deltaP12 x)        @ (self startFrom: p1y to: p2y offset: nSteps*deltaP12 y).    deltaP43 _ (self deltaFrom: p4x to: p3x nSteps: nSteps)            @ (self deltaFrom: p4y to: p3y nSteps: nSteps).    pB _ (self startFrom: p4x to: p3x offset: nSteps*deltaP43 x)        @ (self startFrom: p4y to: p3y offset: nSteps*deltaP43 y).    picker _ BitBlt bitPeekerFromForm: sourceForm.    poker _ BitBlt bitPokerToForm: destForm.    poker clipRect: self clipRect.    nSteps _ width-1 max: 1.    destY to: destY+height-1 do:        [:y |        deltaPAB _ (self deltaFrom: pA x to: pB x nSteps: nSteps)                @ (self deltaFrom: pA y to: pB y nSteps: nSteps).        sp _ (self startFrom: pA x to: pB x offset: nSteps*deltaPAB x)            @ (self startFrom: pA y to: pB y offset: nSteps*deltaPAB x).        destX to: destX+width-1 do:            [:x |             n = 1            ifTrue:                [Transcript cr; print: sp // fixedPtOne asPoint.                poker pixelAt: x@y                        put: (picker pixelAt: sp // fixedPtOne asPoint)]            ifFalse:                [0 to: n-1 do:                    [:dx | 0 to: n-1 do:                        [:dy |                        pix at: dx*n+dy+1 put:                                (picker pixelAt: sp                                    + (deltaPAB*dx//n)                                    + (deltaP12*dy//n)                                        // fixedPtOne asPoint)]].                poker pixelAt: x@y put: (self mixPix: pix                                        sourceMap: sourceMap                                        destMap: colorMap)].            sp _ sp + deltaPAB].        pA _ pA + deltaP12.        pB _ pB + deltaP43]! !!WarpBlt class methodsFor: 'initialization'!toForm: destinationForm    "Default cell size is 1 (no pixel smoothing)"    ^ (super toForm: destinationForm) cellSize: 1! !!WarpBlt class methodsFor: 'examples'!test1   "Display restoreAfter: [WarpBlt test1]"    "Demonstrates variable scale and rotate"    | warp pts r1 p0 p ext |    Utilities informUser: 'Choose a rectangle with interesting stuff'        during: [r1 _ Rectangle originFromUser: 50@50.                Sensor waitNoButton].    Utilities informUser: 'Now click down and upand move the mouse around the dot'        during: [p0 _ Sensor waitClickButton.                (Form dotOfSize: 8) displayAt: p0].    warp _ (self toForm: Display)        clipRect: (0@0 extent: r1 extent*5);        sourceForm: Display;        combinationRule: Form over.    [Sensor anyButtonPressed] whileFalse:        [p _ Sensor cursorPoint.        pts _ {r1 topLeft. r1 bottomLeft. r1 bottomRight. r1 topRight}            collect: [:pt | pt rotateBy: (p-p0) theta about: r1 center].        ext _ (r1 extent*((p-p0) r / 20.0 max: 0.1)) asIntegerPoint.        warp copyQuad: pts toRect: (r1 extent*5-ext//2 extent: ext)]! !!WarpBlt class methodsFor: 'examples'!test12   "Display restoreAfter: [WarpBlt test12]"    "Just like test1, but comparing smooth to non-smooth warps"    | warp pts r1 p0 p ext warp2 |    Utilities informUser: 'Choose a rectangle with interesting stuff'        during: [r1 _ Rectangle originFromUser: 50@50.                Sensor waitNoButton].    Utilities informUser: 'Now click down and upand move the mouse around the dot'        during: [p0 _ Sensor waitClickButton.                (Form dotOfSize: 8) displayAt: p0].    warp _ (self toForm: Display)        cellSize: 2;  "installs a colormap"        clipRect: (0@0 extent: r1 extent*5);        sourceForm: Display;        combinationRule: Form over.    warp2 _ (self toForm: Display)        clipRect: ((0@0 extent: r1 extent*5) translateBy: 200@0);        sourceForm: Display;        combinationRule: Form over.    [Sensor anyButtonPressed] whileFalse:        [p _ Sensor cursorPoint.        pts _ {r1 topLeft. r1 bottomLeft. r1 bottomRight. r1 topRight}            collect: [:pt | pt rotateBy: (p-p0) theta about: r1 center].        ext _ (r1 extent*((p-p0) r / 20.0 max: 0.1)) asIntegerPoint.        warp copyQuad: pts toRect: (r1 extent*5-ext//2 extent: ext).        warp2 copyQuad: pts toRect: ((r1 extent*5-ext//2 extent: ext) translateBy: 200@0).        ]! !!WarpBlt class methodsFor: 'examples'!test3   "Display restoreAfter: [WarpBlt test3]"    "The Squeak Release Mandala - 9/23/96 di"    "Move the mouse near the center of the square.    Up and down affects shrink/grow    Left and right affect rotation angle"    | warp pts p0 p box map d t |    box _ 100@100 extent: 300@300.    Display border: (box expandBy: 2) width: 2.    "Make a color map that steps through the color space"    map _ (Display depth > 8        ifTrue: ["RGB is a bit messy..."                d _ Display depth = 16 ifTrue: [5] ifFalse: [8].                (1 to: 512) collect: [:i | t _ i bitAnd: 511.                    ((t bitAnd: 16r7) bitShift: d-3)                    + ((t bitAnd: 16r38) bitShift: d-3*2)                    + ((t bitAnd: 16r1C0) bitShift: d-3*3)]]        ifFalse: ["otherwise simple"                1 to: (1 bitShift: Display depth)])            as: Bitmap.    warp _ (WarpBlt toForm: Display)        clipRect: box;        sourceForm: Display;        colorMap: map;        combinationRule: Form over.    p0 _ box center.    [Sensor anyButtonPressed] whileFalse:        [p _ Sensor cursorPoint.        pts _ (box insetBy: p y - p0 y) innerCorners            collect: [:pt | pt rotateBy: p x - p0 x / 50.0 about: p0].        warp copyQuad: pts toRect: box]! !!WarpBlt class methodsFor: 'examples'!test4   "Display restoreAfter: [WarpBlt test4]"    "The Squeak Release Mandala - 9/23/96 di    This version does smoothing"    "Move the mouse near the center ofhe square.    Up and dn affects shrink/grow    Left and right affect rotation angle"    | warp pts p0 p box |    box _ 100@100 extent: 300@300.    Display border: (box expandBy: 2) width: 2.    warp _ (WarpBlt toForm: Display)        clipRect: box;        sourceForm: Display;        cellSize: 2;  "installs a colormap"        combinationRule: Form over.    p0 _ box center.    [Sensor anyButtonPressed] whileFalse:        [p _ Sensor cursorPoint.        pts _ (box insetBy: p y - p0 y) innerCorners            collect: [:pt | pt rotateBy: p x - p0 x / 50.0 about: p0].        warp copyQuad: pts toRect: box]! !!WarpBlt class methodsFor: 'examples'!test5   "Display restoreAfter: [WarpBlt test5]"    "Demonstrates variable scale and rotate"    | warp pts r1 p0 p |    Utilities informUser: 'Choose a rectangle with interesting stuff'        during: [r1 _ Rectangle fromUser.                Sensor waitNoButton].    Utilities informUser: 'Now click down and upand move the mouse around the dot'        during: [p0 _ Sensor waitClickButton.                (Form dotOfSize: 8) displayAt: p0].    warp _ (self toForm: Display)        cellSize: 1;        sourceForm: Display;        cellSize: 2;  "installs a colormap"        combinationRule: Form over.    [Sensor anyButtonPressed] whileFalse:        [p _ Sensor cursorPoint.        pts _ {r1 topLeft. r1 bottomLeft. r1 bottomRight. r1 topRight}            collect: [:pt | pt rotateBy: (p-p0) theta about: r1 center].        warp copyQuad: pts toRect: (r1 translateBy: r1 width@0)]! !!WarpBlt class methodsFor: 'form rotation'!rotate: aForm degrees: angleInDegrees center: aPoint smoothing: cellSize    "Rotate the given Form the given number of degrees around the given point relative to the top-left corner of the form. Smooth using the given cell size, an integer between 1 and 3 where 1 means no smoothing. Return a pair where the first element is the rotated form and the second is the position offset required to align the center of the rotated form with that of the original. Note that the dimensions of the resulting form generally differ from those of the original."    | oldCenter newCenter pair |    oldCenter _ aForm boundingBox center.    newCenter _ (oldCenter        rotateBy: angleInDegrees degreesToRadians        about: aPoint) truncated.    pair _ self rotate: aForm        degrees: angleInDegrees        smoothing: cellSize.    pair at: 2 put: (pair at: 2) + (newCenter - oldCenter).    ^ pair! !!WarpBlt class methodsFor: 'form rotation'!rotate: srcForm degrees: angleInDegrees smoothing: cellSize    "Rotate the given Form the given number of degrees around its own center. Smooth using the given cell size, an integer between 1 and 3, where 1 means no smoothing. Return a pair where the first element is the rotated form and the second is the position offset required to align the center of the rotated form with that of the original. Note that the dimensions of the resulting form generally differ from those of the original."    | srcRect center dstOrigin radians dstCorner p dstRect quad dstForm |    srcRect _ srcForm boundingBox.    center _ srcRect center.    dstOrigin _ dstCorner _ center.    radians _ angleInDegrees degreesToRadians.    srcRect corners do: [:corner |        "find the limits of a rectangle that just encloses the rotated         original; in general, this rectangle will be larger than the         original (e.g., consider a square rotated by 45 degrees)"        p _ (corner rotateBy: radians about: center) truncated.        dstOrigin _ dstOrigin min: p.        dstCorner _ dstCorner max: p].    "rotate the enclosing rectangle back to get the source quadrilateral"    dstRect _ dstOrigin corner: dstCorner.    quad _ dstRect innerCorners collect: [:corner |        corner rotateBy: radians negated about: center].    "make a form to hold the result and do the rotation"    dstForm _ self rotate: srcForm        destinationExtent: dstRect extent        quad: quad        cellSize: cellSize.    ^ Array with: dstForm with: dstRect origin! !!WarpBlt class methodsFor: 'private'!rotate: srcForm destinationExtent: dstExtent quad: quad cellSize: cellSize    "Private!! Rotate the given Form using the given parameters."    | dstForm |    dstForm _ Form extent: dstExtent depth: srcForm depth.    (WarpBlt toForm: dstForm)        sourceForm: srcForm;        colorMap: (dstForm colormapIfNeededForDepth: srcForm depth);        cellSize: cellSize;  "installs a new colormap if cellSize > 1"        combinationRule: Form over;        copyQuad: quad toRect: dstForm boundingBox.    ^ dstForm.! !!WaveTableSound methodsFor: 'initialization' stamp: 'jm 9/18/97 18:37'!setPitch: p dur: d loudness: l    "((WaveTableSound pitch: 880.0 dur: 5.5 loudness: 800) decayRate: 0.96) play"    waveTable _ SineTable.    waveTableSize _ waveTable size.    self pitch: p.    initialCount _ (d * self samplingRate asFloat) rounded.    initialAmplitude _ l rounded.    decayRate _ 1.0.  "no decay"    self reset.! !!WaveTableSound methodsFor: 'sound generation' stamp: 'jm 9/18/97 18:33'!doControl    decayRate ~= 1.0        ifTrue: [            amplitude _ (decayRate * amplitude asFloat) truncated.            amplitude > SmallInteger maxVal ifTrue: [amplitude _ SmallInteger maxVal]].! !!WaveTableSound methodsFor: 'sound generation' stamp: 'jm 9/18/97 18:33'!mixSampleCount: n into: aSoundBuffer startingAt: startIndex pan: pan    "Play samples from a wave table by stepping a fixed amount throught the table on every sample. The decay parameter may be used to make the sound fade away, but its default value of 1.0 produces a sustained sound, like a flute. The abrupt start and stops of this sound result in transient clicks; it would benefit greatly from a simple attack-sustain-decay envelope."    "(WaveTableSound pitch: 440.0 dur: 1.0 loudness: 200) play"    | lastIndex mySample channelIndex sample |    <primitive: 176>    self var: #aSoundBuffer declareC: 'short int *aSoundBuffer'.    self var: #waveTable declareC: 'short int *waveTable'.    lastIndex _ (startIndex + n) - 1.    startIndex to: lastIndex do: [ :i |        mySample _ (amplitude * (waveTable at: index)) // 1000.        pan > 0 ifTrue: [            channelIndex _ 2 * i.            sample _ (aSoundBuffer at: channelIndex) + ((mySample * pan) // 1000).            sample >  32767 ifTrue: [ sample _  32767 ].  "clipping!!"            sample < -32767 ifTrue: [ sample _ -32767 ].  "clipping!!"            aSoundBuffer at: channelIndex put: sample.        ].        pan < 1000 ifTrue: [            channelIndex _ (2 * i) - 1.            sample _ (aSoundBuffer at: channelIndex) + ((mySample * (1000 - pan)) // 1000).            sample >  32767 ifTrue: [ sample _  32767 ].  "clipping!!"            sample < -32767 ifTrue: [ sample _ -32767 ].  "clipping!!"            aSoundBuffer at: channelIndex put: sample.        ].        index _ index + increment.        index > waveTableSize ifTrue: [            index _ index - waveTableSize.        ].    ].    count _ count - n.! !!WaveTableSound methodsFor: 'sound generation' stamp: 'jm 9/18/97 18:34'!reset    super reset.    amplitude _ initialAmplitude.    count _ initialCount.    index _ 1.! !!WaveTableSound methodsFor: 'copying' stamp: 'jm 10/4/97 16:45'!copy    ^ self clone! !!WaveTableSound class methodsFor: 'class initialization' stamp: 'jm 9/18/97 15:39'!initialize    "Build a sine wave table."    "WaveTableSound initialize"    | radiansPerStep scale |    SineTable _ SoundBuffer newMonoSampleCount: 10000.    radiansPerStep _ (2.0 * Float pi) / SineTable size asFloat.    scale _ ((1 bitShift: 15) - 1) asFloat.  "range is +/- (2^15 - 1)"    1 to: SineTable monoSampleCount do: [ :i |        SineTable at: i put:            (scale * (radiansPerStep * i) sin) rounded].! !!WorldMorph methodsFor: 'initialization'!initialize    super initialize.    color _ (Color r:0.937 g: 0.937 b: 0.937).    hands _ Array new.    self addHand: HandMorph new.    viewBox _ canvas _ nil.    damageRecorder _ DamageRecorder new.    stepList _ OrderedCollection new.    lastStepTime _ 0.    model _ nil.! !!WorldMorph methodsFor: 'initialization'!open    "Open a view on this WorldMorph."    MorphWorldView openOn: self.! !!WorldMorph methodsFor: 'initialization' stamp: 'jm 6/21/97 17:03'!openWithTitle: aString    "Open a view on this WorldMorph with the given title."    MorphWorldView openOn: self label: aString! !!WorldMorph methodsFor: 'install / exit'!exit    Cursor normal show.    "restore the normal cursor"    self canvas: nil.        "free my canvas to save space"    Project current exit.! !!WorldMorph methodsFor: 'install / exit'!install    "hide the hardware cursor, since hand will draw it"    Cursor blank show.    self viewBox: Display boundingBox.    hands do: [:h | h initForEvents].    self displayWorld.! !!WorldMorph methodsFor: 'classification'!isWorldMorph    ^ true! !!WorldMorph methodsFor: 'accessing'!canvas    ^ canvas! !!WorldMorph methodsFor: 'accessing'!canvas: aCanvas    "Start displaying on the given canvas."    canvas _ aCanvas.    self fullRepaintNeeded.! !!WorldMorph methodsFor: 'accessing'!color: aColor    "Set the background color of this world."    super color: aColor.    self fullRepaintNeeded.    "Propagate to view"    self changed: #newColor.! !!WorldMorph methodsFor: 'accessing' stamp: 'jm 6/21/97 22:58'!eToyHolder        ^ eToyHolder! !!WorldMorph methodsFor: 'accessing' stamp: 'jm 6/21/97 22:58'!eToyHolder: anEToyHolder    eToyHolder _ anEToyHolder.! !!WorldMorph methodsFor: 'accessing'!viewBox        ^ viewBox! !!WorldMorph methodsFor: 'accessing' stamp: 'di 6/24/97 10:09'!viewBox: aRectangle    (viewBox == nil or:     [viewBox extent ~= aRectangle extent])        ifTrue: [self canvas: nil].    viewBox _ aRectangle.    bounds _ 0@0 extent: viewBox extent.    "Paragraph problem workaround; clear selections to avoid screen droppings:"    hands do: [:h | h newKeyboardFocus: nil].    self fullRepaintNeeded.! !!WorldMorph methodsFor: 'structure'!addAllMorphs: array    super addAllMorphs: array.    array do: [:m | self startSteppingSubmorphsOf: m]! !!WorldMorph methodsFor: 'structure'!world    ^ self! !!WorldMorph methodsFor: 'submorphs-accessing' stamp: 'jm 6/11/97 17:07'!allMorphsDo: aBlock    "Enumerate all morphs in the world, including those held in hands."    super allMorphsDo: aBlock.    hands reverseDo: [:h | h allMorphsDo: aBlock].! !!WorldMorph methodsFor: 'submorphs-accessing'!rootMorphsAt: aPoint    "Return the list of root morphs containing the given point, excluding the world and its hands."    | mList |    mList _ OrderedCollection new.    submorphs do: [:m |        (m fullContainsPoint: aPoint) ifTrue: [mList addLast: m]].    ^ mList! !!WorldMorph methodsFor: 'drawing'!displayWorld    "Update this world's display."    | rectList |    submorphs do: [:m | m fullBounds].  "force re-layout if needed"    damageRecorder updateIsNeeded ifFalse: [^ self].  "display is already up-to-date"    (canvas == nil or:     [(canvas extent ~= viewBox extent) or:     [canvas form depth ~= Display depth]]) ifTrue: [        "allocate a new offscreen canvas the size of the window"        self canvas: (FormCanvas extent: viewBox extent)].    false ifTrue: [  "*make this true to flash damaged areas for testing*"        damageRecorder blackenDamageOn: canvas.        canvas showAt: viewBox origin].    rectList _ self drawInvalidAreasOn: canvas.  "redraw on offscreen canvas"    canvas showAt: viewBox origin invalidRects: rectList.  "copy redrawn rects to Display"    damageRecorder reset.! !!WorldMorph methodsFor: 'drawing'!displayWorldAsTwoTone    "Display the world in living black-and-white. (This is typically done to save space.)"    | f |    f _ ColorForm extent: viewBox extent depth: 1.    f colors: (Array with: color with: Color black).    self canvas: (FormCanvas new setForm: f).    "force the entire canvas to be redrawn"    self fullRepaintNeeded.    self drawInvalidAreasOn: canvas.  "redraw on offscreen canvas"    canvas showAt: viewBox origin.  "copy redrawn areas to Display"    self canvas: nil.  "forget my canvas to save space"! !!WorldMorph methodsFor: 'drawing'!displayWorldNonIncrementally    "Display the morph world non-incrementally. Used for testing."    (canvas == nil or:     [(canvas extent ~= viewBox extent) or:     [canvas form depth ~= Display depth]]) ifTrue: [        "allocate a new offscreen canvas the size of the window"        self canvas: (FormCanvas extent: viewBox extent)].    canvas fillColor: color.    submorphs reverseDo: [:m | m fullDrawOn: canvas].    hands reverseDo: [:h | h fullDrawOn: canvas].    canvas form displayOn: Display at: viewBox origin.    self fullRepaintNeeded.  "don't collect damage"! !!WorldMorph methodsFor: 'drawing'!drawInvalidAreasOn: aCanvas    "Redraw the damaged areas of the given canvas and clear the damage list. Return a collection of the areas that were redrawn."    | rectList c |    rectList _ damageRecorder invalidRectsFullBounds: (0@0 extent: aCanvas extent).    rectList do: [:r |        c _ aCanvas copyClipRect: r.        c fillColor: color.        submorphs reverseDo: [:m |            (m fullBounds intersects: r) ifTrue: [m fullDrawOn: c]].        hands reverseDo: [:h | h fullDrawOn: c]].    ^ rectList! !!WorldMorph methodsFor: 'events'!handlesMouseDown: evt    ^ true! !!WorldMorph methodsFor: 'events'!mouseDown: evt    "Handle a mouse down event on the world."    evt hand newKeyboardFocus: self.! !!WorldMorph methodsFor: 'stepping'!adjustWakeupTimes    "Fix the wakeup times in my step list. This is necessary when this world has been restarted after a pause, say because some other view had control, after a snapshot, or because the millisecond clock has wrapped around. (The latter is a rare occurence with a 32-bit clock!!)"    | earliestTime t now |    "find earliest wakeup time"    earliestTime _ SmallInteger maxVal.    stepList do: [:entry |        t _ entry at: 2.        t < earliestTime ifTrue: [earliestTime _ t]].    "recompute all wakeup times, using earliestTime as the origin"    now _ Time millisecondClockValue.    stepList do:        [:entry | entry at: 2 put: (now + ((entry at: 2) - earliestTime))].! !!WorldMorph methodsFor: 'stepping' stamp: '6/10/97 18:54 jm'!runStepMethods    "Run morph 'step' methods whose time has come.    Also purge any morphs that are no longer with us"    | now wakeupTime m deletions |    stepList size = 0 ifTrue: [^ self].    deletions _ OrderedCollection new.    now _ Time millisecondClockValue.    ((now < lastStepTime) or: [(now - lastStepTime) > 5000])         ifTrue: [self adjustWakeupTimes].  "clock slipped"    stepList do: [:entry |        wakeupTime _ entry at: 2.        m _ entry at: 1.        m world == self            ifTrue: [wakeupTime <= now ifTrue:                        [m step.                        entry at: 2 put: now + m stepTime]]            ifFalse: [deletions addLast: m]].    deletions do: [:goner | self stopStepping: goner].    lastStepTime _ now.! !!WorldMorph methodsFor: 'stepping' stamp: '6/10/97 18:53 jm'!startStepping: aMorph    "Add the given morph to the step list. Do nothing if it is already being stepped."    stepList do: [:entry | entry first = aMorph ifTrue: [^ self]].  "already stepping"    stepList add:        (Array            with: aMorph            with: Time millisecondClockValue - aMorph stepTime).! !!WorldMorph methodsFor: 'stepping'!startSteppingSubmorphsOf: aMorph    "Ensure that all submorphs of the given morph that want to be stepped are added to the step list. Typically used after adding a morph to the world."    aMorph allMorphsDo: [:m |        m wantsSteps ifTrue: [self startStepping: m]].! !!WorldMorph methodsFor: 'stepping'!stopStepping: aMorph    "Remove the given morph from the step list."    stepList copy do: [:entry |        entry first == aMorph ifTrue: [stepList remove: entry ifAbsent: []]].! !!WorldMorph methodsFor: 'hands' stamp: 'jm 9/26/97 15:00'!addHand: aHandMorph    "Add the given hand to the list of hands for this world."    hands _ hands copyWith: aHandMorph.    aHandMorph privateOwner: self.! !!WorldMorph methodsFor: 'hands'!hands    ^ hands copy! !!WorldMorph methodsFor: 'hands' stamp: 'jm 9/26/97 10:32'!removeHand: aHandMorph    "Remove the given hand from the list of hands for this world."    (hands includes: aHandMorph) ifTrue: [        aHandMorph dropMorphsEvent: MorphicEvent new.        hands _ hands copyWithout: aHandMorph].! !!WorldMorph methodsFor: 'change reporting'!fullRepaintNeeded    damageRecorder doFullRepaint.! !!WorldMorph methodsFor: 'change reporting'!invalidRect: damageRect    "Record the given rectangle in the damage list."    damageRecorder recordInvalidRect: damageRect.! !!WorldMorph methodsFor: 'change reporting'!layoutChanged    fullBounds _ nil.! !!WorldMorph methodsFor: 'interaction loop'!doOneCycle    "Do one cycle of the interactive loop. This method is called repeatedly when the world is running."    self runStepMethods.    self processEvents.    self displayWorld.! !!WorldMorph methodsFor: 'interaction loop' stamp: 'jm 9/25/97 09:46'!doOneCycleInBackground    "Do one cycle of the interactive loop. This method is called repeatedly when this world is not the active window but is running in the background."    self runStepMethods.    self processEventsInBackground.    self displayWorld.! !!WorldMorph methodsFor: 'interaction loop'!processEvents    "Process user input events."    hands do: [:h | h processEvents].! !!WorldMorph methodsFor: 'interaction loop' stamp: 'jm 9/25/97 09:45'!processEventsInBackground    "Process user input events, but only for remote hands. Used when this world is not the active window, but is running in background."    hands do:        [:h | (h isKindOf: RemoteHandMorph) ifTrue: [h processEvents]].! !!WorldMorph methodsFor: 'interaction loop' stamp: 'jm 9/25/97 12:04'!startBackgroundProcess    "Start a process to update this world in the background. Return the process created."    | p |    p _ [[true] whileTrue: [        self doOneCycleInBackground.        (Delay forMilliseconds: 20) wait]] newProcess.    p resume.    ^ p! !!WorldMorph methodsFor: 'model access'!createCustomModel    "Create a model object for this world if it does not yet have one. A model object is an initially empty subclass of MorphicModel. As the user names parts and adds behavior, instance variables and methods are added to this class."    model == nil ifFalse: [^ self].  "already has a model"    model _ MorphicModel newSubclass new.! !!WorldMorph methodsFor: 'model access'!model    "Return the model object for this world. If the world has no model, then create one."    self createCustomModel.    ^ model! !!WorldMorph methodsFor: 'model access'!modelOrNil    "Return the model object for this world, or nil if it doesn't have one."    ^ model! !!WorldMorph methodsFor: 'model access'!setModel: aModelMorph    "Set the model for this world. Methods for sensitized morphs will be compiled into the class for this model."    model _ aModelMorph! !!WorldMorph methodsFor: 'dropping'!acceptDroppingMorph: aMorph event: evt    "Add the given morph to this world and make sure it is getting stepped if it wants to be."    self addMorphFront: aMorph.    self startSteppingSubmorphsOf: aMorph.! !!WorldMorph methodsFor: 'painting support' stamp: 'di 6/29/97 09:54'!paintArea    "What rectangle should the user be allowed to create a new painting in??  An area beside the paintBox.  Allow playArea to override with its own bounds!!  "    | playfield paintBoxBounds |    "playfield _ self findA: PlayfieldMorph."    playfield ifNotNil: [^ playfield bounds].    paintBoxBounds _ self paintBox bounds.    self hands first targetOffset x < paintBoxBounds center x        ifTrue: [^ bounds topLeft corner: paintBoxBounds left@bounds bottom]   "paint on left side"        ifFalse: [^ paintBoxBounds right@bounds top corner: bounds bottomRight].  "paint on right side"! !!WorldMorph methodsFor: 'painting support' stamp: 'jm 6/11/97 18:01'!paintBox    "Return the painting controls widget (PaintBox) to be used for painting in this world. If there is not already a PaintBox morph, or if it has been deleted from this world, create a new one."    | newPaintBox |    self allMorphsDo: [:m | (m isKindOf: PaintBox) ifTrue: [^ m]].    newPaintBox _ PaintBox new position: 300@0.    self addMorph: newPaintBox.    ^ newPaintBox! !!WorldMorph methodsFor: 'sensing'!colorAt: aPoint belowMorph: aMorph    "Return the color of the pixel immediately behind the given morph at the given point."    | c root |    c _ FormCanvas extent: 1@1 depth: Display depth.    c _ c copyOrigin: aPoint negated clipRect: ((0@0) extent: 1@1).    c fillColor: color.    root _ aMorph root.    submorphs reverseDo: [:m |        m == root ifTrue: [            (m morphsAt: aPoint) reverseDo: [:subM |                subM == aMorph ifTrue: [^ c form colorAt: 0@0].                subM drawOn: c]].        m fullDrawOn: c].    hands reverseDo: [:h |        h submorphsReverseDo: [:m |            m == root ifTrue: [                (m morphsAt: aPoint) reverseDo: [:subM |                    subM == aMorph ifTrue: [^ c form colorAt: 0@0].                    subM drawOn: c]].            m fullDrawOn: c]].    ^ c form colorAt: 0@0! !!WorldMorph methodsFor: 'save/store' stamp: 'tk 5/28/97'!addMorphsAndModel: aDummyWorld    "Dump in submorphs, model, and stepList from a dummyWorld.  Used to bring a world in from an object file.  "    | |    aDummyWorld isMorph ifTrue: [        aDummyWorld isWorldMorph ifFalse: ["one morph, put on hand"            "aDummyWorld installModelIn: self.      a chance to install model pointers"            self startSteppingSubmorphsOf: aDummyWorld.            self hands first attachMorph: aDummyWorld        ] ifTrue: [            model == nil ifTrue: [self setModel: (aDummyWorld modelOrNil)]                    ifFalse: [aDummyWorld modelOrNil ifNotNil: [                                aDummyWorld modelOrNil privateOwner: nil.                                self addMorph: (aDummyWorld modelOrNil)]].            aDummyWorld privateSubmorphs reverseDo: [:m |                m privateOwner: nil.                self addMorph: m.                m changed].            (aDummyWorld instVarNamed: 'stepList') do: [:entry |                 self startStepping: entry first]]    ] ifFalse: ["list, add them all"        aDummyWorld reverseDo: [:m |            m privateOwner: nil.            self addMorph: m.            self startSteppingSubmorphsOf: m.    "It may not want this!!"            m changed]].! !!WorldMorph methodsFor: 'save/store'!saveAsWorld    | worldName s |    worldName _ FillInTheBlank        request: 'Please give this world a name'        initialAnswer: 'test'.    ((self class class includesSelector: worldName asSymbol) and:        [(PopUpMenu confirm: 'OK to overwrite ' , worldName , '?') not])        ifTrue: [^ self].    s _ WriteStream on: (String new: 1000).    s    nextPutAll: worldName; cr; tab;        nextPutAll: '"' , self class name , ' ' , worldName, ' open"'; cr; cr; tab;        nextPutAll: '^ '.    self printConstructorOn: s indent: 0.    s cr.    self class class        compile: s contents        classified: 'examples'        notifying: nil.! !!WorldMorph methodsFor: 'save/store' stamp: 'tk 5/30/97'!storeDataOn: aDataStream    "WorldMorphs only save certain fields when written to the disk.  Save only the world's submorphs, model, and stepList. See DataStream.typeIDFor:  "    | cntInstVars cntIndexedVars instVars data ind |    cntInstVars _ self class instSize.    cntIndexedVars _ self basicSize.    instVars _ self class allInstVarNames.    data _ Array new: instVars size.    "Add any additional fields to write here"    ind _ (instVars indexOf: 'model').    (ind = 0) ifTrue: [self error: 'this method is out of date']            ifFalse: [data at: ind put: model].    ind _ (instVars indexOf: 'submorphs').    (ind = 0) ifTrue: [self error: 'this method is out of date']            ifFalse: [data at: ind put: submorphs].    ind _ (instVars indexOf: 'stepList').    (ind = 0) ifTrue: [self error: 'this method is out of date']            ifFalse: [data at: ind put: stepList].    aDataStream        beginInstance: self class        size: cntInstVars + cntIndexedVars.    1 to: cntInstVars do:        [:i | aDataStream nextPut: (data at: i)].    1 to: cntIndexedVars do:        [:i | aDataStream nextPut: (self basicAt: i)]! !!WorldMorph class methodsFor: 'instance creation' stamp: 'di 6/22/97 09:07'!includeInNewMorphMenu    "Not to be instantiated from the menu"    ^ false! !!WorldMorph class methodsFor: 'examples'!test    "WorldMorph test open"    ^ ((WorldMorph newBounds: (0@0 corner: 50@40) color: (Color r:0.199 g: 1.0 b: 0.8))    addAllMorphs: ((Array new: 7)    at: 1 put:     ((StringMorph newBounds: (318@76 corner: 390@91) color: Color blue) contents: 'StringMorph');    at: 2 put:     ((EllipseMorph newBounds: (91@73 corner: 141@113) color: (Color r:0.199 g: 0.199 b: 1.0)) setBorderWidth: 1 borderColor: Color black);    at: 3 put:     (((EllipseMorph newBounds: (375@33 corner: 487@137) color: Color yellow) setBorderWidth: 1 borderColor: Color black)        addAllMorphs: ((Array new: 2)        at: 1 put:         ((EllipseMorph newBounds: (365@21 corner: 415@61) color: Color yellow) setBorderWidth: 1 borderColor: Color black);        at: 2 put:         ((EllipseMorph newBounds: (448@23 corner: 498@63) color: Color yellow) setBorderWidth: 1 borderColor: Color black);        yourself));    at: 4 put:     ((FrameRateMorph newBounds: (364@202 corner: 508@217) color: Color black) contents: '22 mSecs (45 frames/sec)');    at: 5 put:     ((ClockMorph newBounds: (301@148 corner: 359@163) color: (Color r:0 g: 0.599 b: 0)) contents: '1:34:02 am');    at: 6 put:     ((FlasherMorph newBounds: (61@151 corner: 297@251) color: Color red) setBorderWidth: 3 borderColor: Color black);    at: 7 put:     ((RectangleMorph newBounds: (81@68 corner: 252@122) color: (Color r:0.656 g: 0.656 b: 0.656)) setBorderWidth: 3 borderColor: (Color r:0.8 g: 0.4 b: 0.199));    yourself))! !!WriteStream methodsFor: 'private' stamp: 'di 6/20/97 08:39'!pastEndPut: anObject    collection _ collection ,        (collection class new: ((collection size max: 20) min: 20000)).    writeLimit _ collection size.    collection at: (position _ position + 1) put: anObject! !!WriteStream methodsFor: 'private'!withAttribute: att do: strmBlock     "No-op here is overriden in TextStream for font emphasis"    ^ strmBlock value! !!ZoomMorph methodsFor: 'all'!initialize    super initialize.    color _ Color transparent! !!ZoomMorph methodsFor: 'all'!step    boundsSeq isEmpty ifTrue:        ["If all done, then grant one final request and vanish"        finalAction value.        ^ self delete].    "Otherwise, zoom to the next rectangle"    self zoomTo: boundsSeq removeFirst! !!ZoomMorph methodsFor: 'all'!stepTime    ^ 40! !!ZoomMorph methodsFor: 'all'!zoomFromMorph: m1 toMorph: m2 andThen: actionBlock    | nSteps topLeft r2 r1 extent ratio r mouthDeltas |    fromMorph _ m1.    toMorph _ m2.    r1 _ fromMorph fullBounds.    r2 _ toMorph fullBounds.    finalAction _ actionBlock.    nSteps _ 8.    boundsSeq _ OrderedCollection new.    r _ (1/nSteps) asFloat.    ratio _ r.r1 _ 105@326 corner: [e-mail] _ {-7@24. -6@21. -6@18. -4@14. -4@10. -3@8. -3@3. 0@0}.    1 to: nSteps do:        [:i | topLeft _ ((r2 topLeft - r1 topLeft) * ratio) asIntegerPoint + r1 topLeft.        extent _ ((r2 extent - r1 extent) * ratio) asIntegerPoint + r1 extent.        boundsSeq addLast: (topLeft + (mouthDeltas at: i) extent: extent).        ratio _ ratio + r].    self addMorph: toMorph.    self step! !!ZoomMorph methodsFor: 'all'!zoomTo: newBounds    | scale |    self bounds: newBounds.    scale _ newBounds extent / toMorph fullBounds extent.    self setOffset: toMorph position - self position angle: 0.0 scale: scale! !Symbol rehash.    Smalltalk condenseChanges.!----QUIT----(5 October 1997 11:28:11 am ) priorSource: 2182822!'From Squeak 1.23 of October 4, 1997 on 5 October 1997 at 4:38:43 pm'!!Paragraph methodsFor: 'accessing' stamp: 'di 10/5/97 15:33'!clippingRectangle: clipRect     clippingRectangle _ clipRect! !!Paragraph methodsFor: 'accessing' stamp: '' prior: 35015526!replaceFrom: start to: stop with: aText displaying: displayBoolean    "Replace the receiver's text starting at position start, stopping at stop, by     the characters in aText. It is expected that most requirements for     modifications to the receiver will call this code. Certainly all cut's or     paste's."     | compositionScanner obsoleteLines obsoleteLastLine firstLineIndex lastLineIndex    startLine stopLine replacementRange visibleRectangle startIndex newLine done    newStop obsoleteY newY moveRectangle |    text replaceFrom: start to: stop with: aText.        "Update the text."    lastLine = 0 ifTrue:        ["if lines have never been set up, measure them and display        all the lines falling in the visibleRectangle"        self composeAll.        displayBoolean ifTrue: [^ self displayLines: (1 to: lastLine)]].    "save -- things get pretty mashed as we go along"    obsoleteLines _ lines copy.    obsoleteLastLine _ lastLine.    "find the starting and stopping lines"    firstLineIndex _ startLine _ self lineIndexOfCharacterIndex: start.    stopLine _ self lineIndexOfCharacterIndex: stop.    "how many characters being inserted or deleted        -- negative if aText size is < characterInterval size."    replacementRange _ aText size - (stop - start + 1).    "Give ourselves plenty of elbow room."    compositionRectangle _ compositionRectangle withHeight: (textStyle lineGrid * 9999).    "build a boundingBox of the actual screen space in question -- we'll need it later"    visibleRectangle _ (clippingRectangle intersect: compositionRectangle)                            intersect: destinationForm boundingBox.    compositionScanner _ CompositionScanner new in: self.        "Initialize a scanner."    "If the starting line is not also the first line, then measuring must commence from line preceding the one in which characterInterval start appears.  For example, deleting a line with only a carriage return may move characters following the deleted portion of text into the line preceding the deleted line."    startIndex _ (lines at: firstLineIndex) first.    startLine > 1        ifTrue:     [newLine _ compositionScanner composeLine: startLine - 1                        fromCharacterIndex: (lines at: startLine - 1) first                        inParagraph: self.                (lines at: startLine - 1) = newLine                    ifFalse:    ["start in line preceding the one with the starting character"                            startLine _ startLine - 1.                            self lineAt: startLine put: newLine.                            startIndex _ newLine last + 1]].    startIndex > text size ifTrue:        ["nil lines after a deletion -- remeasure last line below"        self trimLinesTo: (firstLineIndex - 1 max: 0).        text size = 0 ifTrue:            ["entire text deleted -- clear visibleRectangle and return."            displayBoolean ifTrue: [destinationForm fill: visibleRectangle rule: rule fillColor: self backgroundColor].            self updateCompositionHeight.            ^self]].    "Now we really get to it."    done _ false.    lastLineIndex _ stopLine.    [done or: [startIndex > text size]]        whileFalse:         [self lineAt: firstLineIndex put:            (newLine _ compositionScanner composeLine: firstLineIndex                            fromCharacterIndex: startIndex inParagraph: self).        [(lastLineIndex > obsoleteLastLine            or: ["no more old lines to compare with?"                newLine last <                    (newStop _ (obsoleteLines at: lastLineIndex) last + replacementRange)])                  or: [done]]            whileFalse:             [newStop = newLine last                ifTrue:    ["got the match"                        "get source and dest y's for moving the unchanged lines"                        obsoleteY _ self topAtLineIndex: lastLineIndex + 1                                    using: obsoleteLines and: obsoleteLastLine.                        newY _ self topAtLineIndex: firstLineIndex + 1.                        stopLine _ firstLineIndex.                        done _ true.                            "Fill in the new line vector with the old unchanged lines.                            Update their starting and stopping indices on the way."                        ((lastLineIndex _ lastLineIndex + 1) to: obsoleteLastLine) do:                            [:upDatedIndex |                             self lineAt: (firstLineIndex _ firstLineIndex + 1)                                 put: ((obsoleteLines at: upDatedIndex)                                      slide: replacementRange)].                            "trim off obsolete lines, if any"                        self trimLinesTo: firstLineIndex]                ifFalse:    [lastLineIndex _ lastLineIndex + 1]].        startIndex _ newLine last + 1.        firstLineIndex _ firstLineIndex + 1].    "Now the lines are up to date -- Whew!!.  What remains is to move    the 'unchanged' lines and display those which have changed."    displayBoolean   "Not much to do if not displaying"        ifFalse: [^ self updateCompositionHeight].    startIndex > text size ifTrue:        ["If at the end of previous lines simply display lines from the line in        which the first character of the replacement occured through the        end of the paragraph."        self updateCompositionHeight.        self displayLines:            (startLine to: (stopLine _ firstLineIndex min: lastLine)).        destinationForm  "Clear out area at the bottom"            fill: ((visibleRectangle left @ (self topAtLineIndex: lastLine + 1)                        extent: visibleRectangle extent)                    intersect: visibleRectangle)            rule: rule fillColor: self backgroundColor]        ifFalse:        [newY ~= obsoleteY ifTrue:            ["Otherwise first move the unchanged lines within            the visibleRectangle with a good old bitblt."            moveRectangle _                visibleRectangle left @ (obsoleteY max: visibleRectangle top)                    corner: visibleRectangle corner.            destinationForm copyBits: moveRectangle from: destinationForm                at: moveRectangle origin + (0 @ (newY-obsoleteY))                clippingBox: visibleRectangle                rule: Form over fillColor: nil].        "Then display the altered lines."        self displayLines: (startLine to: stopLine).        newY < obsoleteY            ifTrue:            [(self topAtLineIndex: obsoleteLastLine+1 using: obsoleteLines and: obsoleteLastLine) > visibleRectangle bottom                ifTrue:                ["A deletion may have 'pulled' previously undisplayed lines                into the visibleRectangle.  If so, display them."                self displayLines:                    ((self lineIndexOfTop: visibleRectangle bottom - (obsoleteY - newY))                        to: (self lineIndexOfTop: visibleRectangle bottom))].            "Clear out obsolete material at the bottom of the visibleRectangle."            destinationForm                fill: ((visibleRectangle left @ ((self bottomAtLineIndex: lastLine) + 1)                        extent: visibleRectangle extent)                    intersect: visibleRectangle)  "How about just corner: ??"                rule: rule fillColor: self backgroundColor].        (newY > obsoleteY and: [obsoleteY < visibleRectangle top])            ifTrue:                ["An insertion may have 'pushed' previously undisplayed lines                into the visibleRectangle.  If so, display them."                self displayLines:                    ((self lineIndexOfTop: visibleRectangle top)                        to: (self lineIndexOfTop: visibleRectangle top + (newY-obsoleteY)))].        self updateCompositionHeight]! !!TextMorph methodsFor: 'initialization' stamp: 'di 10/5/97 16:36' prior: 35594908!initialize    super initialize.    color _ Color black.    textStyle _ TextStyle default copy.    text _ 'Text' asText allBold.  "Default contents"    wrapFlag _ true.! !!TextMorph methodsFor: 'drawing' stamp: '' prior: 35596776!drawOn: aCanvas    | selectionRects |    self hasFocus ifTrue:        [aCanvas fillRectangle: bounds color: Color white.        selectionRects _ editor selectionRects.        (selectionRects size = 1 and: [selectionRects first width = 1])            ifTrue: [aCanvas image: CaretForm                            at: (selectionRects first bottomLeft + CaretForm offset)]            ifFalse: [selectionRects do:                        [:rect | aCanvas fillRectangle: rect color: SelectionColor]]].    text size = 0        ifTrue: [self hasFocus ifFalse: [aCanvas fillRectangle: bounds color: Color lightRed]]        ifFalse: [aCanvas paragraph: self paragraph bounds: bounds color: color].! !!TextMorph methodsFor: 'geometry' stamp: 'di 10/5/97 16:12' prior: 35601910!extent: aPoint    self releaseEditor.    self releaseParagraph.  "invalidate the paragraph cache"    super extent: (aPoint max: 20@(textStyle lineGrid+2)).    self fit! !!TextMorph methodsFor: 'private' stamp: 'di 10/5/97 15:36' prior: 35602879!fit    "Adjust bounds vertically to fit the text."    | newExtent |    newExtent _ wrapFlag        ifTrue: [bounds width @ ((self paragraph height max: textStyle lineGrid) + 2)]        ifFalse: [(self paragraph extent max: 20@textStyle lineGrid) + (0@2)].    newExtent ~= bounds extent        ifTrue: [super extent: newExtent.                paragraph clippingRectangle: self bounds].    self updateAnchors.    self changed! !!TextMorph methodsFor: 'private' stamp: 'di 10/5/97 16:35' prior: 35603663!paragraph    "Paragraph instantiation is lazy -- create it only when needed"    | compWidth fullWidth |    paragraph ifNotNil: [^ paragraph].    "...Code here to recreate the paragraph..."    compWidth _ wrapFlag ifTrue: [bounds width] ifFalse: [999999].    paragraph _ Paragraph basicNew.    fullWidth _ paragraph setWithText: text style: textStyle            compositionRectangle: (bounds topLeft extent: compWidth @ 999999)            clippingRectangle: bounds             foreColor: color backColor: Color white.    wrapFlag ifFalse:        [paragraph compositionRectangle:            (paragraph compositionRectangle withWidth: fullWidth)].    self fit.    ^ paragraph! !TextMorph removeSelector: #convertbosfceptthpeh0:bosfcepttwpe0:!TextMorph removeSelector: #convertbosfceptthpeh0:bosfcepttwpe0:!TextMorphEditor removeSelector: #controlInitialize!TextMorphEditor removeSelector: #controlInitialize!----QUIT----(5 October 1997 4:40:36 pm ) priorSource: 2182867!----SNAPSHOT----(12 October 1997 5:42:00 pm ) priorSource: 2192366!'From Squeak 1.22 of September 21, 1997 on 30 September 1997 at 11:02:31 pm'!"Change Set:        RPC-VMDate:            9/30/97Author:            Tim RowledgeMake sure the garbage scanner can cope with the displayBits object when it exists.Use platAllocateMemory instead of malloc, so that DynamicMemory areas can be used for improved performance.Add RiscOSFileDirectory and modify FileDirectory to initialize more simply, also add more explicit filename extension handling.Add proper implementation of #sign for large intergers. Improve performance of asFloat for large integers."!Object subclass: #FileDirectory    instanceVariableNames: 'pathName closed '    classVariableNames: 'DefaultDirectory DefaultDirectoryClass '    poolDictionaries: ''    category: 'System-Files'!Object subclass: #ObjectMemory    instanceVariableNames: 'memory youngStart endOfMemory memoryLimit nilObj falseObj trueObj specialObjectsOop rootTable rootTableCount child field parentField freeBlock lastHash freeLargeContexts freeSmallContexts allocationCount lowSpaceThreshold signalLowSpace compStart compEnd fwdTableNext fwdTableLast remapBuffer remapBufferCount interruptCheckCounter checkAssertions allocationsBetweenGCs tenuringThreshold statFullGCs statFullGCMSecs statIncrGCs statIncrGCMSecs statTenures displayBits '    classVariableNames: 'AllButHashBits AllButMarkBit AllButMarkBitAndTypeMask AllButRootBit AllButTypeMask AllocationsBetweenGCs BaseHeaderSize CharacterTable ClassArray ClassBitmap ClassBlockContext ClassByteArray ClassCharacter ClassCompiledMethod ClassFloat ClassInteger ClassLargePositiveInteger ClassMessage ClassMethodContext ClassPoint ClassProcess ClassSemaphore ClassString CompactClasses ConstMinusOne ConstOne ConstTwo ConstZero Done ExternalObjectsArray FalseObject FreeSizeMask GCTopMarker HashBits HashBitsOffset HeaderTypeClass HeaderTypeFree HeaderTypeGC HeaderTypeShort HeaderTypeSizeAndClass LargeContextSize MarkBit MinimumForwardTableBytes NilContext NilObject RemapBufferSize RootBit RootTableSize SchedulerAssociation SelectorCannotReturn SelectorDoesNotUnderstand SelectorMustBeBoolean SmallContextSize SpecialSelectors StackStart StartField StartObj TheDisplay TheInputSemaphore TheInterruptSemaphore TheLowSpaceSemaphore TheTimerSemaphore TrueObject TypeMask Upward '    poolDictionaries: ''    category: 'Squeak Interpreter'!FileDirectory subclass: #RiscOSFileDirectory    instanceVariableNames: ''    classVariableNames: ''    poolDictionaries: ''    category: 'System-Files'!!ChangeSet methodsFor: 'fileIn/Out' stamp: 'TPR 9/30/97 22:27' prior: 33783995!fileOut    "File out the receiver, to a file whose name is a function of the change-set name and of the date and the time.  1/18/96 sw 2/4/96 sw: show write cursor    5/30/96 sw: put a dot before the date/time stamp 12/18/96 tpr - do it via cleaner extension message"    | file |    Cursor write showWhile:        [file _ FileStream newFileNamed: ((FileDirectory joinExtension: 'cs' toFileName:(FileDirectory joinExtension: Utilities dateTimeSuffix toFileName: self name)) truncateTo: 27).        file header; timeStamp.        self fileOutPreambleOn: file.        self fileOutOn: file.        self fileOutPostscriptOn: file.        file trailer; close]! !!FileDirectory methodsFor: 'path name' stamp: 'TPR 9/30/97 22:27'!pathNameExtensionDelimiter    ^ self class pathNameExtensionDelimiter! !!FileDirectory methodsFor: 'dictionary access' stamp: 'TPR 9/30/97 22:27' prior: 34041492!includesKey: aString    "Answer whether the receiver includes an element of the given name."    "Note: aString may designate a file local to this directory, or it may be a full path name. Try both."    ^ StandardFileStream isAFileNamed: (self fullNameFor: aString)! !!FileDirectory class methodsFor: 'class initialization' stamp: 'TPR 9/30/97 22:27'!initialize    "FileDirectory initialize"    DefaultDirectoryClass _ self activeDirectoryClass! !!FileDirectory class methodsFor: 'class initialization' stamp: 'TPR 9/30/97 22:27' prior: 17512736!newOnPath: pathName    ^ (self defaultClass new setPathName: pathName) open! !!FileDirectory class methodsFor: 'class initialization' stamp: 'TPR 9/30/97 22:27' prior: 17513456!setDefaultDirectoryFrom: imageName    DefaultDirectoryClass _ self activeDirectoryClass.    self defaultClass convertName: imageName        to: [:directory :fileName | DefaultDirectory _ directory]! !!FileDirectory class methodsFor: 'name service' stamp: 'TPR 9/30/97 22:27'!defaultClass    "Answer the default directory class."    ^ DefaultDirectoryClass! !!FileDirectory class methodsFor: 'name service' stamp: 'TPR 9/30/97 22:27'!joinExtension: extName toFileName: fileName    extName isEmpty ifTrue: [^ fileName].    ^ fileName , self pathNameExtensionDelimiter asString , extName! !!FileDirectory class methodsFor: 'name service' stamp: 'TPR 9/30/97 22:27' prior: 17515605!joinVol: volName toFileName: fileName"This might be simpler if we changed the vmPath prim to not include the last delimiter - but maybe the delimiter check is a good idea anyway ? "    volName isEmpty ifTrue: [^ fileName].    volName last = self pathNameDelimiter        ifTrue: ["no need for extra delimiter"                ^volName, fileName].    ^ volName , self pathNameDelimiter asString , fileName! !!FileDirectory class methodsFor: 'name service' stamp: 'TPR 9/30/97 22:27'!splitNameAndExtension: fileName to: volAndNameAndExtBlock    "Take the file name and convert it into a volume name, a fileName and an extension.  FileName must be of the form: d<sep>f<extSep>e where the optional d specifies a known directory, f is the file name within that directory and e is the optional extension."    | delimiter index realName dirName extName |    delimiter _ self pathNameDelimiter.    (index _ fileName findLast: [:c | c = delimiter]) = 0        ifTrue:            [dirName _ String new.            realName _ fileName ]        ifFalse:            [dirName _ fileName copyFrom: 1 to: index - 1.            realName _ fileName copyFrom: index + 1 to: fileName size ].    delimiter _ self pathNameExtensionDelimiter.    (index _ realName findLast: [:c | c = delimiter]) = 0        ifTrue: [ extName  _ String new]        ifFalse: [ extName _ realName copyFrom: index + 1 to: realName size.            realName _ realName copyFrom: 1 to: index - 1].    ^ volAndNameAndExtBlock value: dirName value: realName value: extName! !!FileDirectory class methodsFor: 'primitives' stamp: 'TPR 9/30/97 22:27' prior: 34044732!pathNameDelimiter    ^ self defaultClass pathNameDelimiter! !!FileDirectory class methodsFor: 'primitives' stamp: 'TPR 9/30/97 22:27'!pathNameExtensionDelimiter"return the character used to delimit filename extensions. For most platforms this is a dot"    ^ self defaultClass pathNameExtensionDelimiter! !!Float methodsFor: 'mathematical functions' stamp: 'TPR 9/30/97 22:29' prior: 34057895!floorLog: radix     "Quick computation of (self log: radix) floor."    ^(self log: radix) floor! !!Integer methodsFor: 'converting' stamp: 'TPR 9/30/97 22:29' prior: 17749420!asFloat    "Answer a Float that represents the value of the receiver."    | factor sum numBytes|    sum _ 0.0.    factor _ self sign asFloat.    numBytes _ self size.    numBytes > 128 ifTrue: [^self error: 'value out of range'].    numBytes > 7        ifFalse: [ 1 to: self size do:                 [:i | sum _ (self digitAt: i) * factor + sum.                factor _ factor * 256.0]]        ifTrue: [numBytes -6 to: numBytes do:                [:i| sum _ (self digitAt: i) * factor + sum.                factor _ factor * 256.0].                sum _ sum timesTwoPower: 8* (numBytes - 7)].    ^sum! !!LargePositiveInteger methodsFor: 'testing' stamp: 'TPR 9/30/97 22:29'!sign    "Answer 1 if the receiver is greater than 0, -1 if less than 0, else 0."    ^1! !!LargeNegativeInteger methodsFor: 'testing' stamp: 'TPR 9/30/97 22:29'!sign    "Answer 1 if the receiver is greater than 0, -1 if less than 0, else 0."    ^-1! !!MacFileDirectory class methodsFor: 'initialization' stamp: 'TPR 9/30/97 22:27'!pathNameExtensionDelimiter"return the character used to delimit filename extensions. For most platforms this is a dot"    ^ $.! !!ObjectMemory methodsFor: 'initialization' stamp: 'TPR 9/30/97 22:16' prior: 34906943!initializeObjectMemory: bytesToShift    "Initialize object memory variables at startup time. Assume endOfMemory is initially set (by the image-reading code) to the end of the last object in the image. Initialization redefines endOfMemory to be the end of the object allocation area based on the total available memory, but reserving some space for forwarding blocks."    "Assume: image reader initializes the following variables:        memory        endOfMemory        memoryLimit        specialObjectsOop        lastHash    "    self inline: false.    checkAssertions _ false.  "set this early to allow assertions in initialization code to use it"    "set the start of the young object space"    youngStart _ endOfMemory.    self initializeMemoryFirstFree: endOfMemory.        "initializes endOfMemory, freeBlock"    "image may be at a different address; adjust oops for new location"    self adjustAllOopsBy: bytesToShift.    specialObjectsOop _ specialObjectsOop + bytesToShift.    "heavily used special objects"    nilObj    _ self splObj: NilObject.    falseObj    _ self splObj: FalseObject.    trueObj    _ self splObj: TrueObject.    rootTableCount _ 0.    child _ 0.    field _ 0.    parentField _ 0.    freeLargeContexts _ NilContext.    freeSmallContexts _ NilContext.    allocationCount _ 0.    lowSpaceThreshold _ 0.    signalLowSpace _ false.    compStart _ 0.    compEnd _ 0.    fwdTableNext _ 0.    fwdTableLast _ 0.    remapBufferCount _ 0.    displayBits _ 0. "TPR Make sure displayBits oop is ok"    allocationsBetweenGCs _ 4000.  "do incremental GC after this many allocations"    tenuringThreshold _ 2000.  "tenure all suriving objects if count is over this threshold"    "garbage collection statistics"    statFullGCs _ 0.    statFullGCMSecs _ 0.    statIncrGCs _ 0.    statIncrGCMSecs _ 0.    statTenures _ 0.! !!ObjectMemory methodsFor: 'gc -- mark and sweep' stamp: 'TPR 9/30/97 22:17' prior: 34945532!sweepPhase    "Sweep memory from youngStart through the end of memory. Free all inaccessible objects and coalesce adjacent free chunks. Clear the mark bits of accessible objects. Compute the starting point for the first pass of incremental compaction (compStart). Return the number of surviving objects."    "Details: Each time a non-free object is encountered, decrement the number of available forward table entries. If all entries are spoken for (i.e., entriesAvailable reaches zero), set compStart to the last free chunk before that object or, if there is no free chunk before the given object, the first free chunk after it. Thus, at the end of the sweep phase, compStart through compEnd spans the highest collection of non-free objects that can be accomodated by the forwarding table. This information is used by the first pass of incremental compaction to ensure that space is initially freed at the end of memory. Note that there should always be at least one free chunk--the one at the end of the heap."    | entriesAvailable survivors freeChunk firstFree oop oopHeader oopHeaderType hdrBytes oopSize freeChunkSize |    self inline: false.    entriesAvailable _ self fwdTableInit.    survivors _ 0.    freeChunk _ nil.    firstFree _ nil.  "will be updated later"    oop _ self oopFromChunk: youngStart.    [oop < endOfMemory] whileTrue: [        "get oop's header, header type, size, and header size"        oopHeader _ self baseHeader: oop.        oopHeaderType _ oopHeader bitAnd: TypeMask.        (oopHeaderType = HeaderTypeShort) ifTrue: [            oopSize _ oopHeader bitAnd: 16rFC.            hdrBytes _ 0.        ] ifFalse: [            (oopHeaderType = HeaderTypeClass) ifTrue: [                oopSize _ oopHeader bitAnd: 16rFC.                hdrBytes _ 4.            ] ifFalse: [                (oopHeaderType = HeaderTypeSizeAndClass) ifTrue: [                    oopSize _ (self sizeHeader: oop) bitAnd: AllButTypeMask.                    hdrBytes _ 8.                ] ifFalse: [  "free chunk"                    oopSize _ oopHeader bitAnd: FreeSizeMask.                    hdrBytes _ 0.                ].            ].        ].        (oopHeader bitAnd: MarkBit) = 0 ifTrue: [            "object is not marked; free it"            freeChunk ~= nil ifTrue: [                "enlarge current free chunk to include this oop"                freeChunkSize _ freeChunkSize + oopSize + hdrBytes.            ] ifFalse: [                "start a new free chunk"                freeChunk _ oop - hdrBytes.  "chunk may start 4 or 8 bytes before oop"                freeChunkSize _ oopSize + (oop - freeChunk).  "adjust size for possible extra header bytes"                firstFree = nil ifTrue: [ firstFree _ freeChunk ].            ].        ] ifFalse: [            "object is marked; clear its mark bit and possibly adjust the compaction start"            self longAt: oop put: (oopHeader bitAnd: AllButMarkBit).            entriesAvailable > 0 ifTrue: [                entriesAvailable _ entriesAvailable - 1.            ] ifFalse: [                "start compaction at the last free chunk before this object"                firstFree _ freeChunk.            ].            freeChunk ~= nil ifTrue: [                "record the size of the last free chunk"                self longAt: freeChunk                        put: ((freeChunkSize bitAnd: FreeSizeMask) bitOr: HeaderTypeFree).            ].            freeChunk _ nil.            survivors _ survivors + 1.        ].        oop _ self oopFromChunk: (oop + oopSize).  "get next oop"    ].    freeChunk ~= nil ifTrue: [        "record size of final free chunk"        self longAt: freeChunk                put: ((freeChunkSize bitAnd: FreeSizeMask) bitOr: HeaderTypeFree).    ].    oop = endOfMemory        ifFalse: [ self error: 'sweep failed to find exact end of memory' ].    firstFree = nil        ifTrue: [ self error: 'expected to find at least one free object' ]        ifFalse: [ compStart _ firstFree ].    displayBits = 0 ifFalse: ["TPR sweep the Display's bits array, which may be outside object space on an Acorn RPC"        oopHeader _ self baseHeader: displayBits.        self longAt: displayBits put: (oopHeader bitAnd: AllButMarkBit)].        ^ survivors! !!Interpreter methodsFor: 'I/O primitives' stamp: 'TPR 9/30/97 22:09' prior: 34385374!primitiveBeDisplay    "Record the system Display object."    | rcvr w h d suggestedByteSize answer dispBits |    rcvr _ self stackTop.    self success: ((self isPointers: rcvr) and: [(self lengthOf: rcvr) >= 4]).    successFlag ifTrue: [        "11/7/96 TPR Give the VM a chance to setup the display bitmap. Implement the routine ioSetDisplayBitmap() simply to return true if, like the Mac, you can manage with the bits for the display form being part of normal ST object space. Implement it to alter the displaybits or some other object pointer if you can't. If the returned value is false, fail the prim and hope your system still works. First, check that the displayBits object is at least a word indexed object"    dispBits _ self fetchPointer: 0 ofObject: rcvr.        (self isWords: dispBits)            ifFalse: [^self primitiveFail].        w _ self fetchInteger: 1 ofObject: rcvr.        h _ self fetchInteger: 2 ofObject: rcvr.        d _ self fetchInteger: 3 ofObject: rcvr.        suggestedByteSize _ self sizeBitsOf: dispBits.        answer _ self cCode: 'ioSetDisplayBitmap(rcvr, suggestedByteSize, w, h, d)'.        "Something went wrong, so fail the prim "        answer            ifFalse: [^self primitiveFail].        "record the display object both in a variable and in the specialObjectsOop"        self storePointer: TheDisplay ofObject: specialObjectsOop withValue: rcvr.        self pop: 1.    ].! !!Interpreter methodsFor: 'image save/restore' stamp: 'TPR 9/30/97 22:12' prior: 34447465!readImageFromFile: f HeapSize: desiredHeapSize    "Read an image from the given file stream, allocating the given amount of memory to its object heap. Fail if the image has an unknown format or requires more than the given amount of memory."    "Details: This method detects when the image was stored on a machine with the opposite byte ordering from this machine and swaps the bytes automatically. Furthermore, it allows the header information to start 512 bytes into the file, since some file transfer programs for the Macintosh apparently prepend a Mac-specific header of this size. Note that this same 512 bytes of prefix area could also be used to store an exec command on Unix systems, allowing one to launch Smalltalk by invoking the image name as a command."    "This code is based on C code by Ian Piumarta and Smalltalk code by Tim Rowledge. Many thanks to both of you!!!!"    | swapBytes headerStart headerSize dataSize oldBaseAddr minimumMemory memStart bytesRead bytesToShift |    self var: #f declareC: 'FILE *f'.    swapBytes _ self checkImageVersionFrom: f.    headerStart _ (self positionOfFile: f) - 4.  "record header start position"    headerSize            _ self getLongFromFile: f swap: swapBytes.    dataSize                _ self getLongFromFile: f swap: swapBytes.    oldBaseAddr            _ self getLongFromFile: f swap: swapBytes.    specialObjectsOop        _ self getLongFromFile: f swap: swapBytes.    lastHash            _ self getLongFromFile: f swap: swapBytes.    savedWindowSize    _ self getLongFromFile: f swap: swapBytes.    lastHash = 0 ifTrue: [        "lastHash wasn't stored (e.g. by the cloner); use 999 as the seed"        lastHash _ 999].    "compare memory requirements with availability".    minimumMemory _ dataSize + 80000.  "need at least 80K of breathing room"    desiredHeapSize < minimumMemory        ifTrue: [ self error: 'Insufficient memory for this image' ].    "allocate a contiguous block of memory for the Squeak heap"    memory _ self cCode: '(unsigned char *) platAllocateMemory(desiredHeapSize)'.    memory = nil        ifTrue: [ self error: 'Failed to allocate memory for the heap' ].    memStart _ self startOfMemory.    memoryLimit _ (memStart + desiredHeapSize) - 24.  "decrease memoryLimit a tad for safety"    endOfMemory _ memStart + dataSize.    "position file after the header"    self fileSeek: f position: headerStart + headerSize.    "read in the image in bulk, then swap the bytes if necessary"    bytesRead _ self cCode: 'fread(memory, sizeof(unsigned char), dataSize, f)'.    bytesRead ~= dataSize        ifTrue: [ self error: 'Read failed or premature end of image file' ].    swapBytes ifTrue: [self reverseBytesInImage].    "compute difference between old and new memory base addresses"    bytesToShift _ memStart - oldBaseAddr.    self initializeInterpreter: bytesToShift.  "adjusts all oops to new location"    ^ dataSize! !RiscOSFileDirectory comment:'fileClass    ^ StandardFileStream'!RiscOSFileDirectory comment:'fileClass    ^ StandardFileStream'!!RiscOSFileDirectory methodsFor: 'file creation' stamp: 'TPR 9/30/97 22:27'!fileClass    ^ StandardFileStream! !!RiscOSFileDirectory class methodsFor: 'initialization' stamp: 'TPR 9/30/97 22:27'!pathNameDelimiter    ^ $.! !!RiscOSFileDirectory class methodsFor: 'initialization' stamp: 'TPR 9/30/97 22:27'!setMacFileNamed: fileName type: typeString creator: creatorString    "Set the Macintosh file type and creator info for the file with the given name. Fails if the file does not exist or if the type and creator type arguments are not strings of length 4."    "Mac specific; noop on other platforms. EXCEPT might  be useful for RPC" ! !!RiscOSFileDirectory class methodsFor: 'primitives' stamp: 'TPR 9/30/97 22:27'!pathNameExtensionDelimiter"return the character used to delimit filename extensions. For RiscOS this is sort-of-a-slash, since that is what a dot gets converted to when loading files from foreign file systems"    ^ $/! !!SystemDictionary methodsFor: 'image, changes name' stamp: 'TPR 9/30/97 22:27' prior: 35509871!changesName  "Smalltalk changesName"    "Answer the current name for the changes file that matches the image file name"    | imName index |    FileDirectory splitNameAndExtension: self imageName        to: [:volName :fileName :extName | imName _ fileName].    ^FileDirectory joinExtension: 'changes' toFileName: imName! !!SystemDictionary methodsFor: 'image, changes name' stamp: 'TPR 9/30/97 22:27' prior: 35510370!sourcesName    "Answer the sources file name used in this Smalltalk release."    ^ FileDirectory joinVol: self vmPath toFileName: (FileDirectory joinExtension:'sources' toFileName:'SqueakV1')! !!SystemDictionary methodsFor: 'sources, change log' stamp: 'TPR 9/30/97 22:27' prior: 18567339!openSourceFiles    FileDirectory        setDefaultDirectoryFrom: self imageName;        openSources: self sourcesName        andChanges: self changesName        forImage: self imageName! !!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'TPR 9/30/97 22:27' prior: 18569330!saveAs    | dir newName |    dir _ FileDirectory default.    newName _ (FillInTheBlank request: 'New File Name?'                     initialAnswer: 'NewImageName') asFileName.    (newName endsWith: '.image') ifTrue:        [newName _ newName copyFrom: 1 to: newName size - 6].    (dir includesKey: newName , '.image')        | (dir includesKey: newName , '.changes') ifTrue:        [^ self notify: newName , ' is already in usePlease choose another name.'].    self closeSourceFiles.    dir copyFileNamed: self changesName toFileNamed: (FileDirectory joinExtension:'changes' toFileName: newName)."    self logChange: '----SAVEAS ' , newName , '----'        , Date dateAndTimeNow printString."    self imageName: (dir fullNameFor:(FileDirectory joinExtension:'image' toFileName: newName)).    self openSourceFiles.    "Just so SNAPSHOT appears on the new file, and not the old"    self snapshot: true andQuit: false.! !FileDirectory initialize!'From Squeak 1.22 of September 21, 1997 on 30 September 1997 at 11:21:59 pm'!"Change Set:        LEBitBlt6Date:            30 September 1997Author:            Tim Rowledge [e-mail] the ability to do BitBlting in native little endian mode. Required changes to the interpreter and image. Forms can pixel reverse to the endian-ness reported by the Smalltalk isVMLittleEndian primitive, but they are written out in canonical big-endian form by #storeOn: etc.There is some doubt as to what happens with #writeOn: etc, since there is some compression involved as of v1.22"!!BitBlt methodsFor: 'copying' stamp: 'TPR 9/30/97 23:20' prior: 16868722!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 bits at: 1 put: 0.  "Just to be sure"    self copyBits.    ^Smalltalk isImageLittleEndian            ifTrue: [(destForm bits at: 1) reversePixelsOfDepth: destForm depth]            ifFalse: [destForm bits at: 1]! !!BitBlt methodsFor: 'copying' stamp: 'TPR 9/30/97 23:20' prior: 33587829!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 bits at: 1 put: (Smalltalk isImageLittleEndian            ifTrue: [pixelValue reversePixelsOfDepth: destForm depth]            ifFalse: [pixelValue]).    self copyBits"[Sensor anyButtonPressed] whileFalse:    [Display valueAt: Sensor cursorPoint put: 55]"! !!BitBltSimulation methodsFor: 'setup' stamp: 'TPR 9/30/97 23:20' prior: 33618294!destMaskAndPointerInit    "Compute masks for left and right destination words"    | startBits pixPerM1 endBits |    pixPerM1 _ pixPerWord - 1.  "A mask, assuming power of two"    "how many pixels in first word. Shifts for mask1 7 2 reversed for little endian TPR"    startBits _ pixPerWord - (dx bitAnd: pixPerM1).    self ifLittleEndianDo:[ mask1 _ AllOnes << (32 - (startBits*destPixSize))] elseDo:[ mask1 _ AllOnes >> (32 - (startBits*destPixSize))].    "how many pixels in last word"    endBits _ ((dx + bbW - 1) bitAnd: pixPerM1) + 1.    self ifLittleEndianDo:[mask2 _ AllOnes >> (32 - (endBits*destPixSize))] elseDo:[mask2 _ AllOnes << (32 - (endBits*destPixSize))].    "determine number of words stored per line; merge masks if only 1"    bbW < startBits        ifTrue: [mask1 _ mask1 bitAnd: mask2.                mask2 _ 0.                nWords _ 1]        ifFalse: [nWords _ (bbW - startBits) + pixPerM1 // pixPerWord + 1].    hDir _ vDir _ 1. "defaults for no overlap with source"    "calculate byte addr and delta, based on first word of data"    "Note raster and nwords are longs, not bytes"    destIndex _ (destBits + 4) + (dy * destRaster + (dx // pixPerWord) *4).    destDelta _ 4 * ((destRaster * vDir) - (nWords * hDir)).  "byte addr delta"! !!BitBltSimulation methodsFor: 'setup' stamp: 'TPR 9/30/97 23:20' prior: 33620090!sourceSkewAndPointerInit    "This is only used when source and dest are same depth,    ie, when the barrel-shift copy loop is used."    | dWid sxLowBits dxLowBits pixPerM1 |    pixPerM1 _ pixPerWord - 1.  "A mask, assuming power of two"    sxLowBits _ sx bitAnd: pixPerM1.    dxLowBits _ dx bitAnd: pixPerM1.    "check if need to preload buffer    (i.e., two words of source needed for first word of destination)"    hDir > 0 ifTrue:        ["n Bits stored in 1st word of dest"        dWid _ bbW min: pixPerWord - dxLowBits.        preload _ (sxLowBits + dWid) > pixPerM1]    ifFalse:        [dWid _ bbW min: dxLowBits + 1.        preload _ (sxLowBits - dWid + 1) < 0].    "calculate right-shift skew from source to dest. reversed for little endian TPR"    self ifLittleEndianDo:[skew _ (dxLowBits - sxLowBits) * destPixSize] elseDo:[skew _ (sxLowBits - dxLowBits) * destPixSize].  " -32..32 "    preload ifTrue:         [skew < 0            ifTrue: [skew _ skew+32]            ifFalse: [skew _ skew-32]].    "Calc byte addr and delta from longWord info"    sourceIndex _ (sourceBits + 4) + (sy * sourceRaster + (sx // (32//sourcePixSize)) *4).    "calculate increments from end of 1 line to start of next"    sourceDelta _ 4 * ((sourceRaster * vDir) - (nWords * hDir)).    preload ifTrue:        ["Compensate for extra source word fetched"        sourceDelta _ sourceDelta - (4*hDir)].! !!BitBltSimulation methodsFor: 'inner loop' stamp: 'TPR 9/30/97 23:20' prior: 33627475!copyLoopPixMap    | skewWord halftoneWord mergeWord destMask srcPixPerWord scrStartBits nSourceIncs startBits endBits sourcePixMask destPixMask nullMap |    "This version of the inner loop maps source pixels    to a destination form with different depth.  Because it is already    unweildy, the loop is not unrolled as in the other versions.    Preload, skew and skewMask are all overlooked, since pickSourcePixels    delivers its destination word already properly aligned.    Note that pickSourcePixels could be copied in-line at the top of    the horizontal loop, and some of its inits moved out of the loop."    self inline: false.    "Additional inits peculiar to unequal source and dest pix size..."    srcPixPerWord _ 32//sourcePixSize.    "Check for degenerate shift values 4/28/97 ar"    sourcePixSize = 32         ifTrue: [ sourcePixMask _ -1]        ifFalse: [ sourcePixMask _ (1 << sourcePixSize) - 1].    destPixSize = 32        ifTrue: [ destPixMask _ -1]        ifFalse: [ destPixMask _ (1 << destPixSize) - 1].    nullMap _ colorMap = interpreterProxy nilObject.    sourceIndex _ (sourceBits + 4) +                    (sy * sourceRaster + (sx // srcPixPerWord) *4).    scrStartBits _ srcPixPerWord - (sx bitAnd: srcPixPerWord-1).    bbW < scrStartBits        ifTrue: [nSourceIncs _ 0]        ifFalse: [nSourceIncs _ (bbW - scrStartBits)//srcPixPerWord + 1].    sourceDelta _ (sourceRaster - nSourceIncs) * 4.    "Note following two items were already calculated in destmask setup!!"    startBits _ pixPerWord - (dx bitAnd: pixPerWord-1).    endBits _ ((dx + bbW - 1) bitAnd: pixPerWord-1) + 1.    1 to: bbH do: "here is the vertical loop"        [ :i |        noHalftone            ifTrue: [halftoneWord _ AllOnes]            ifFalse: [halftoneWord _ interpreterProxy longAt: (halftoneBase + (dy+i-1 \\ halftoneHeight * 4))].        srcBitIndex _ (sx bitAnd: srcPixPerWord - 1)*sourcePixSize.        destMask _ mask1.        "pick up first word"        bbW < startBits            ifTrue: [skewWord _ self pickSourcePixels: bbW nullMap: nullMap srcMask: sourcePixMask destMask: destPixMask.                    self ifLittleEndianDo:[skewWord _ skewWord                            bitShift: (bbW - startBits "swapped for little-endian TPR")*destPixSize]                        elseDo:[skewWord _ skewWord                            bitShift: (startBits - bbW)*destPixSize]]            ifFalse: [skewWord _ self pickSourcePixels: startBits nullMap: nullMap srcMask: sourcePixMask destMask: destPixMask].         "Here is the horizontal loop..."        1 to: nWords do: "here is the inner horizontal loop"            [ :word |            mergeWord _ self merge: (skewWord bitAnd: halftoneWord)                with: ((interpreterProxy longAt: destIndex) bitAnd: destMask).            interpreterProxy longAt: destIndex                put: ((destMask bitAnd: mergeWord)                    bitOr:                    (destMask bitInvert32 bitAnd: (interpreterProxy longAt: destIndex))).            destIndex _ destIndex + 4.            word >= (nWords - 1) ifTrue:                [word = nWords ifFalse:                    ["set mask for last word in this row"                    destMask _ mask2.                    skewWord _ self pickSourcePixels: endBits nullMap: nullMap srcMask: sourcePixMask destMask: destPixMask.                    self ifLittleEndianDo:[skewWord _ skewWord                            bitShift: (endBits - pixPerWord"swapped for little-endian TPR")*destPixSize]                        elseDo:[skewWord _ skewWord                            bitShift: (pixPerWord-endBits)*destPixSize]]]                ifFalse:                 ["use fullword mask for inner loop"                destMask _ AllOnes.                skewWord _ self pickSourcePixels: pixPerWord nullMap: nullMap srcMask: sourcePixMask destMask: destPixMask]].    sourceIndex _ sourceIndex + sourceDelta.    destIndex _ destIndex + destDelta]! !!BitBltSimulation methodsFor: 'inner loop' stamp: 'TPR 9/30/97 23:20' prior: 33631223!warpLoop    | skewWord halftoneWord mergeWord destMask startBits      deltaP12x deltaP12y deltaP43x deltaP43y pAx pAy      xDelta yDelta pBx pBy smoothingCount sourceMapOop nSteps t |    "This version of the inner loop traverses an arbirary quadrilateral    source, thus producing a general affine transformation."     (interpreterProxy fetchWordLengthOf: bitBltOop) >= (BBWarpBase+12)        ifFalse: [^ interpreterProxy primitiveFail].    nSteps _ height-1.  nSteps <= 0 ifTrue: [nSteps _ 1].    pAx _ interpreterProxy fetchIntegerOrTruncFloat: BBWarpBase ofObject: bitBltOop.    t _ interpreterProxy fetchIntegerOrTruncFloat: BBWarpBase+3 ofObject: bitBltOop.    deltaP12x _ self deltaFrom: pAx to: t nSteps: nSteps.    deltaP12x < 0 ifTrue: [pAx _ t - (nSteps*deltaP12x)].    pAy _ interpreterProxy fetchIntegerOrTruncFloat: BBWarpBase+1 ofObject: bitBltOop.    t _ interpreterProxy fetchIntegerOrTruncFloat: BBWarpBase+4 ofObject: bitBltOop.    deltaP12y _ self deltaFrom: pAy to: t nSteps: nSteps.    deltaP12y < 0 ifTrue: [pAy _ t - (nSteps*deltaP12y)].    pBx _ interpreterProxy fetchIntegerOrTruncFloat: BBWarpBase+9 ofObject: bitBltOop.    t _ interpreterProxy fetchIntegerOrTruncFloat: BBWarpBase+6 ofObject: bitBltOop.    deltaP43x _ self deltaFrom: pBx to: t nSteps: nSteps.    deltaP43x < 0 ifTrue: [pBx _ t - (nSteps*deltaP43x)].    pBy _ interpreterProxy fetchIntegerOrTruncFloat: BBWarpBase+10 ofObject: bitBltOop.    t _ interpreterProxy fetchIntegerOrTruncFloat: BBWarpBase+7 ofObject: bitBltOop.    deltaP43y _ self deltaFrom: pBy to: t nSteps: nSteps.    deltaP43y < 0 ifTrue: [pBy _ t - (nSteps*deltaP43y)].    interpreterProxy failed ifTrue: [^ false].  "ie if non-integers above"    interpreterProxy argCount = 2        ifTrue: [smoothingCount _ interpreterProxy stackIntegerValue: 1.                sourceMapOop _ interpreterProxy stackValue: 0.                sourceMapOop = interpreterProxy nilObject                ifTrue: [sourcePixSize < 16 ifTrue:                    ["color map is required to smooth non-RGB dest"                    ^ interpreterProxy primitiveFail]]                ifFalse: [(interpreterProxy fetchWordLengthOf: sourceMapOop)                            < (1 << sourcePixSize) ifTrue:                    ["sourceMap must be long enough for sourcePixSize"                    ^ interpreterProxy primitiveFail]]]        ifFalse: [smoothingCount _ 1.                sourceMapOop _ interpreterProxy nilObject].    startBits _ pixPerWord - (dx bitAnd: pixPerWord-1).    nSteps _ width-1.  nSteps <= 0 ifTrue: [nSteps _ 1].     destY to: clipY-1 do:        [ :i |    "Advance increments if there was clipping in y"        pAx _ pAx + deltaP12x.        pAy _ pAy + deltaP12y.        pBx _ pBx + deltaP43x.        pBy _ pBy + deltaP43y].    1 to: bbH do:        [ :i |        "here is the vertical loop..."        xDelta _ self deltaFrom: pAx to: pBx nSteps: nSteps.         xDelta >= 0 ifTrue: [sx _ pAx] ifFalse: [sx _ pBx - (nSteps*xDelta)].        yDelta _ self deltaFrom: pAy to: pBy nSteps: nSteps.         yDelta >= 0 ifTrue: [sy _ pAy] ifFalse: [sy _ pBy - (nSteps*yDelta)].        destX to: clipX-1 do:            [:word |    "Advance increments if there was clipping in x"            sx _ sx + xDelta.            sy _ sy + yDelta].        noHalftone            ifTrue: [halftoneWord _ AllOnes]            ifFalse: [halftoneWord _ interpreterProxy longAt: (halftoneBase + (dy+i-1 \\ halftoneHeight * 4))].        destMask _ mask1.        "pick up first word"        bbW < startBits            ifTrue: [skewWord _ self warpSourcePixels: bbW                                    xDeltah: xDelta yDeltah: yDelta                                    xDeltav: deltaP12x yDeltav: deltaP12y                                    smoothing: smoothingCount sourceMap: sourceMapOop.                    self ifLittleEndianDo:[skewWord _ skewWord                            bitShift: (bbW - startBits "swapped for little-endian TPR")*destPixSize]                        elseDo:[skewWord _ skewWord                            bitShift: (startBits - bbW)*destPixSize]]            ifFalse: [skewWord _ self warpSourcePixels: startBits                                    xDeltah: xDelta yDeltah: yDelta                                    xDeltav: deltaP12x yDeltav: deltaP12y                                    smoothing: smoothingCount sourceMap: sourceMapOop].         1 to: nWords do:            [ :word |        "here is the inner horizontal loop..."            mergeWord _ self merge: (skewWord bitAnd: halftoneWord)                with: ((interpreterProxy longAt: destIndex) bitAnd: destMask).            interpreterProxy longAt: destIndex                put: ((destMask bitAnd: mergeWord)                    bitOr:                    (destMask bitInvert32 bitAnd: (interpreterProxy longAt: destIndex))).            destIndex _ destIndex + 4.            word >= (nWords - 1) ifTrue:                [word = nWords ifFalse:                    ["set mask for last word in this row"                    destMask _ mask2.                    skewWord _ self warpSourcePixels: pixPerWord                                    xDeltah: xDelta yDeltah: yDelta                                    xDeltav: deltaP12x yDeltav: deltaP12y                                    smoothing: smoothingCount sourceMap: sourceMapOop]]                ifFalse:                ["use fullword mask for inner loop"                destMask _ AllOnes.                skewWord _ self warpSourcePixels: pixPerWord                                    xDeltah: xDelta yDeltah: yDelta                                    xDeltav: deltaP12x yDeltav: deltaP12y                                    smoothing: smoothingCount sourceMap: sourceMapOop].            ].        pAx _ pAx + deltaP12x.        pAy _ pAy + deltaP12y.        pBx _ pBx + deltaP43x.        pBy _ pBy + deltaP43y.        destIndex _ destIndex + destDelta]! !!BitBltSimulation methodsFor: 'pixel mapping' stamp: 'TPR 9/30/97 23:20' prior: 33650603!pickSourcePixels: nPix srcMask: sourcePixMask destMask: destPixMask    "This version of pickSourcePixels is for sourcePixSize <= 8        and colorMap notNil"    "Pick nPix pixels from the source, mapped by the    color map, and right-justify them in the resulting destWord."    | sourceWord destWord sourcePix destPix  dstShift |    sourceWord _ (interpreterProxy longAt: sourceIndex).    destWord _ 0.    self ifLittleEndianDo:[dstShift _ 32 -(nPix * destPixSize)] elseDo:[].    1 to: nPix do:        [:i |        self ifLittleEndianDo:[sourcePix _ sourceWord >> ( srcBitIndex)                    bitAnd: sourcePixMask]                        elseDo:[sourcePix _ sourceWord >> ((32-sourcePixSize) - srcBitIndex)                    bitAnd: sourcePixMask].        "look up sourcePix in colorMap"        destPix _ (interpreterProxy fetchWord: sourcePix ofObject: colorMap) bitAnd: destPixMask.        self ifLittleEndianDo:[destWord _ destWord bitOr:( destPix << dstShift).                    dstShift _ dstShift + destPixSize]                elseDo:[destWord _ (destWord << destPixSize) bitOr: destPix].        (srcBitIndex _ srcBitIndex + sourcePixSize) > 31 ifTrue:            [srcBitIndex _ srcBitIndex - 32.            sourceIndex _ sourceIndex + 4.            sourceWord _ interpreterProxy longAt: sourceIndex]].    ^ destWord! !!BitBltSimulation methodsFor: 'pixel mapping' stamp: 'TPR 9/30/97 23:20' prior: 33651524!pickSourcePixelsNullMap: nPix srcMask: sourcePixMask destMask: destPixMask    "This version of pickSourcePixels is for colorMap==nil.        SourcePixelSize is also known to be 8 bits or less."    "With no color map, pixels are just masked or zero-filled."    | sourceWord destWord sourcePix dstShift|    sourceWord _ (interpreterProxy longAt: sourceIndex).    destWord _ 0.    self ifLittleEndianDo:[dstShift _ 32 -(nPix * destPixSize)] elseDo:[].    1 to: nPix do:        [:i |        self ifLittleEndianDo:[sourcePix _ sourceWord >> ( srcBitIndex)                    bitAnd: sourcePixMask.                destWord _ destWord bitOr: ((sourcePix bitAnd: destPixMask) << dstShift).                dstShift _ dstShift + destPixSize.]            elseDo:[sourcePix _ sourceWord >> ((32-sourcePixSize) - srcBitIndex)                    bitAnd: sourcePixMask.                destWord _ (destWord << destPixSize)  bitOr: (sourcePix bitAnd: destPixMask)].        (srcBitIndex _ srcBitIndex + sourcePixSize) > 31 ifTrue:            [srcBitIndex _ srcBitIndex - 32.            sourceIndex _ sourceIndex + 4.            sourceWord _ interpreterProxy longAt: sourceIndex]].    ^ destWord! !!BitBltSimulation methodsFor: 'pixel mapping' stamp: 'TPR 9/30/97 23:20' prior: 33652350!pickSourcePixelsRGB: nPix nullMap: nullMap srcMask: sourcePixMask destMask: destPixMask    "This version of pickSourcePixels is for destPixSize >= 16"    "Pick nPix pixels from the source, mapped by the    color map, and right-justify them in the resulting destWord.    Incoming pixels of 16 or 32 bits are first reduced to cmBitsPerColor.    With no color map, pixels are just masked or zero-filled or    if 16- or 32-bit pixels, the r, g, and b are so treated individually."    | sourceWord destWord sourcePix destPix dstShift|    sourceWord _ (interpreterProxy longAt: sourceIndex).    destWord _ 0.    self ifLittleEndianDo:[dstShift _ 32 -(nPix * destPixSize)] elseDo:[].    1 to: nPix do:        [:i |        self ifLittleEndianDo:[sourcePix _ sourceWord >> ( srcBitIndex)                    bitAnd: sourcePixMask]                elseDo:[sourcePix _ sourceWord >> ((32-sourcePixSize) - srcBitIndex)                    bitAnd: sourcePixMask.].        nullMap        ifTrue:            ["Map between RGB pixels"            sourcePixSize = 16                ifTrue: [destPix _ self rgbMap: sourcePix from: 5 to: 8]                ifFalse: [destPix _ self rgbMap: sourcePix from: 8 to: 5]]        ifFalse:            ["RGB pixels first get reduced to cmBitsPerColor"            sourcePixSize = 16                ifTrue: [sourcePix _ self rgbMap: sourcePix from: 5 to: cmBitsPerColor]                ifFalse: [sourcePix _ self rgbMap: sourcePix from: 8 to: cmBitsPerColor].            "Then look up sourcePix in colorMap"            destPix _ (interpreterProxy fetchWord: sourcePix ofObject: colorMap) bitAnd: destPixMask].        self ifLittleEndianDo:[destWord _ destWord bitOr: (destPix << dstShift).                dstShift _ dstShift + destPixSize]            elseDo:[destWord _ (destWord << destPixSize) bitOr: destPix].        (srcBitIndex _ srcBitIndex + sourcePixSize) > 31 ifTrue:            [srcBitIndex _ srcBitIndex - 32.            sourceIndex _ sourceIndex + 4.            sourceWord _ interpreterProxy longAt: sourceIndex]].    ^ destWord! !!BitBltSimulation methodsFor: 'pixel mapping' stamp: 'TPR 9/30/97 23:20' prior: 33657134!sourcePixAtX: x y: y pixPerWord: srcPixPerWord    | sourceWord index |    self inline: true.    (x < 0 or: [x >= srcWidth]) ifTrue: [^ 0].    (y < 0 or: [y >= srcHeight]) ifTrue: [^ 0].    index _ (y * sourceRaster + (x // srcPixPerWord) *4).                                                "4 = BaseHeaderSize"    sourceWord _ interpreterProxy longAt: sourceBits + 4 + index.    self ifLittleEndianDo:[^sourceWord >> (x\\srcPixPerWord*sourcePixSize)]                        elseDo:[^sourceWord >> ((32-sourcePixSize) - (x\\srcPixPerWord*sourcePixSize))]! !!BitBltSimulation methodsFor: 'pixel mapping' stamp: 'TPR 9/30/97 23:20' prior: 33657587!warpSourcePixels: nPix xDeltah: xDeltah yDeltah: yDeltah    xDeltav: xDeltav yDeltav: yDeltav    smoothing: n sourceMap: sourceMapOop    "Pick nPix pixels using these x- and y-incs, and map color if necess."    | destWord sourcePix sourcePixMask destPixMask srcPixPerWord destPix dstShift|    "Fix degenerate shift values 4/28/97 ar"    sourcePixSize = 32        ifTrue: [ sourcePixMask _ -1]        ifFalse: [ sourcePixMask _ (1 << sourcePixSize) - 1].    destPixSize = 32        ifTrue: [ destPixMask _ -1]        ifFalse: [ destPixMask _ (1 << destPixSize) - 1].    srcPixPerWord _ 32 // sourcePixSize.    destWord _ 0.    self ifLittleEndianDo:[dstShift _ 32 -(nPix * destPixSize)] elseDo:[].    1 to: nPix do:        [:i |        n > 1        ifTrue:            ["Average n pixels and compute dest pixel from color map"            destPix _ (self smoothPix: n atXf: sx yf: sy                dxh: xDeltah//n dyh: yDeltah//n dxv: xDeltav//n dyv: yDeltav//n                pixPerWord: srcPixPerWord pixelMask: sourcePixMask                sourceMap: sourceMapOop)                    bitAnd: destPixMask]        ifFalse:            ["No smoothing -- just pick pixel and map if difft depths or color map supplied"            sourcePix _ (self sourcePixAtX: sx >> BinaryPoint                                    y: sy >> BinaryPoint                                    pixPerWord: srcPixPerWord)                        bitAnd: sourcePixMask.            colorMap = interpreterProxy nilObject                ifTrue:                [destPixSize = sourcePixSize                ifTrue:                    [destPix _ sourcePix]                ifFalse:                    [sourcePixSize >= 16 ifTrue:                        ["Map between RGB pixels"                        sourcePixSize = 16                            ifTrue: [destPix _ self rgbMap: sourcePix from: 5 to: 8]                            ifFalse: [destPix _ self rgbMap: sourcePix from: 8 to: 5]]                    ifFalse: [destPix _ sourcePix bitAnd: destPixMask]]]            ifFalse:                [sourcePixSize >= 16 ifTrue:                    ["RGB pixels first get reduced to cmBitsPerColor"                    sourcePixSize = 16                        ifTrue: [sourcePix _ self rgbMap: sourcePix from: 5 to: cmBitsPerColor]                        ifFalse: [sourcePix _ self rgbMap: sourcePix from: 8 to: cmBitsPerColor]].                "Then look up sourcePix in colorMap"                destPix _ (interpreterProxy fetchWord: sourcePix ofObject: colorMap) bitAnd: destPixMask]].        self ifLittleEndianDo:[destWord _ destWord bitOr:( destPix << dstShift).                    dstShift _ dstShift + destPixSize]                elseDo:[destWord _ (destWord << destPixSize) bitOr: destPix].        sx _ sx + xDeltah.        sy _ sy + yDeltah.        ].    ^ destWord! !!CCodeGenerator methodsFor: 'C code generator' stamp: 'TPR 9/30/97 23:20' prior: 33747359!emitCHeaderForPrimitivesOn: aStream    "Write a C file header for compiled primitives onto the given stream."    aStream nextPutAll: '/* Automatically generated from Squeak on '.    aStream nextPutAll: Time dateAndTimeNow printString.    aStream nextPutAll: ' */'; cr; cr.    aStream nextPutAll: '#include "sq.h"'; cr; cr.    aStream nextPutAll: '/* Memory Access Macros */#define byteAt(i) (*((unsigned char *) (i)))#define byteAtput(i, val) (*((unsigned char *) (i)) = val)#define longAt(i) (*((int *) (i)))#define longAtput(i, val) (*((int *) (i)) = val)#ifdef LITTLE_ENDIAN#define ifLittleEndianDoelseDo( a, b) a#else#define ifLittleEndianDoelseDo( a, b) b#endif/*** Imported Variables ***/extern int stackPointer;extern int successFlag;'.    aStream cr.! !!CCodeGenerator methodsFor: 'C code generator' stamp: 'TPR 9/30/97 23:20' prior: 33748060!emitCHeaderOn: aStream    "Write a C file header onto the given stream."    aStream nextPutAll: '/* Automatically generated from Squeak on '.    aStream nextPutAll: Time dateAndTimeNow printString.    aStream nextPutAll: ' */'; cr; cr.    aStream nextPutAll: '#include "sq.h"'; cr; cr.    aStream nextPutAll: '/* memory access macros */#define byteAt(i) (*((unsigned char *) (i)))#define byteAtput(i, val) (*((unsigned char *) (i)) = val)#define longAt(i) (*((int *) (i)))#define longAtput(i, val) (*((int *) (i)) = val)#ifdef LITTLE_ENDIAN#define ifLittleEndianDoelseDo( a, b) a#else#define ifLittleEndianDoelseDo( a, b) b#endifint printCallStack(void);void error(char *s);void error(char *s) {    /* Print an error message and exit. */    static int printingStack = false;    printf("\n%s\n\n", s);    if (!!printingStack) {        /* flag prevents recursive error when trying to print a broken stack */        printingStack = true;        printCallStack();    }    exit(-1);}'.    aStream cr.! !!CCodeGenerator methodsFor: 'C translation' stamp: 'TPR 9/30/97 23:20'!generateIfLittleEndianDoelseDo: msgNode on: aStream indent: level    "Generate the C code for this message onto the given stream."    aStream nextPutAll: 'ifLittleEndianDoelseDo ('.    msgNode args first emitCCodeOn: aStream level: level + 1 generator: self.    level timesRepeat: [ aStream tab ].    aStream nextPutAll: ' , '; cr.    msgNode args last emitCCodeOn: aStream level: level + 1 generator: self.    level timesRepeat: [ aStream tab ].    aStream nextPutAll: ')'.! !!CCodeGenerator methodsFor: 'C translation' stamp: 'TPR 9/30/97 23:20' prior: 33767536!initializeCTranslationDictionary     "Initialize the dictionary mapping message names to actions for C code generation."    | pairs |    translationDict _ Dictionary new: 200.    pairs _ #(    #&                #generateAnd:on:indent:    #|                #generateOr:on:indent:    #and:            #generateSequentialAnd:on:indent:    #or:            #generateSequentialOr:on:indent:    #not            #generateNot:on:indent:    #+                #generatePlus:on:indent:    #-                #generateMinus:on:indent:    #*                #generateTimes:on:indent:    #//                #generateDivide:on:indent:    #\\                #generateModulo:on:indent:    #<<                #generateShiftLeft:on:indent:    #>>                #generateShiftRight:on:indent:    #min:            #generateMin:on:indent:    #max:            #generateMax:on:indent:    #bitAnd:        #generateBitAnd:on:indent:    #bitOr:            #generateBitOr:on:indent:    #bitXor:            #generateBitXor:on:indent:    #bitShift:        #generateBitShift:on:indent:    #bitInvert32    #generateBitInvert32:on:indent:    #<                #generateLessThan:on:indent:    #<=                #generateLessThanOrEqual:on:indent:    #=                #generateEqual:on:indent:    #>                #generateGreaterThan:on:indent:    #>=                #generateGreaterThanOrEqual:on:indent:    #~=                #generateNotEqual:on:indent:    #==                #generateEqual:on:indent:    #isNil            #generateIsNil:on:indent:    #notNil            #generateNotNil:on:indent:    #whileTrue:     #generateWhileTrue:on:indent:    #whileFalse:    #generateWhileFalse:on:indent:    #to:do:            #generateToDo:on:indent:    #to:by:do:        #generateToByDo:on:indent:    #ifTrue:        #generateIfTrue:on:indent:    #ifFalse:        #generateIfFalse:on:indent:    #ifTrue:ifFalse:    #generateIfTrueIfFalse:on:indent:    #ifFalse:ifTrue:    #generateIfFalseIfTrue:on:indent:    #at:                #generateAt:on:indent:    #at:put:            #generateAtPut:on:indent:    #integerValueOf:    #generateIntegerValueOf:on:indent:    #integerObjectOf:    #generateIntegerObjectOf:on:indent:    #isIntegerObject:     #generateIsIntegerObject:on:indent:    #cCode:                #generateInlineCCode:on:indent:    #cCoerce:to:            #generateCCoercion:on:indent:    #preIncrement        #generatePreIncrement:on:indent:    #preDecrement        #generatePreDecrement:on:indent:    #inline:                #generateInlineDirective:on:indent:    #sharedCodeNamed:inCase:    #generateSharedCodeDirective:on:indent:    #ifLittleEndianDo:elseDo:    #generateIfLittleEndianDoelseDo:on:indent:    ).    1 to: pairs size by: 2 do: [ :i |        translationDict at: (pairs at: i) put: (pairs at: i + 1).    ].! !!Form methodsFor: 'fileIn/Out' stamp: 'TPR 9/30/97 23:20' prior: 17612349!readFrom: aFile    "Reads the receiver from the file in the format:        depth, extent, offset, bits."    | offsetX offsetY |    depth _ aFile next.    (depth isPowerOfTwo and: [depth between: 1 and: 32])        ifFalse: [self halt  "invalid depth"].    width _ aFile nextWord.    height _ aFile nextWord.    offsetX  _ aFile nextWord.    offsetY _ aFile nextWord.    offsetX > 32767 ifTrue: [offsetX _ offsetX - 65536].    offsetY > 32767 ifTrue: [offsetY _ offsetY - 65536].    bits _ Bitmap newFromStream: aFile.    bits size = self bitsSize ifFalse: [self halt "incompatible bitmap size"].    Smalltalk isImageLittleEndian        ifTrue: [self pixelReverse].    ^ self! !!Form methodsFor: 'fileIn/Out' stamp: 'TPR 9/30/97 23:20' prior: 34097001!storeOn: aStream base: anInteger     "Store the receiver out in the form: Form newExtent:fromArray:#()offset:"    | rev|    aStream nextPut: $(.    aStream nextPutAll: self species name.    aStream crtab: 1.    aStream nextPutAll: 'extent: '.    self extent printOn: aStream.    aStream crtab: 1.     aStream nextPutAll: 'depth: '.    self depth printOn: aStream.    aStream crtab: 1.    aStream nextPutAll: 'fromArray: #('.    rev _ Smalltalk isImageLittleEndian.    1 to: bits size do:         [:index |         anInteger = 10            ifTrue: [aStream space]            ifFalse: [aStream crtab: 2].        (rev            ifTrue: [(bits at: index) reversePixelsOfDepth: depth]            ifFalse: [bits at: index]) printOn: aStream base: anInteger].    aStream nextPut: $).    aStream crtab: 1.    aStream nextPutAll: 'offset: '.    self offset printOn: aStream.    aStream nextPut: $)! !!Form methodsFor: 'private' stamp: 'TPR 9/30/97 23:20' prior: 34100792!initFromArray: array    "Fill the bitmap from array.  If the array is shorter,    then cycle around in its contents until the bitmap is filled."    | ax aSize array32 i j word16 revPixels |    ax _ 0.    aSize _ array size.    aSize > bits size ifTrue:        ["backward compatibility with old 16-bit bitmaps and their forms"        array32 _ Array new: height * (width + 31 // 32).        i _ j _ 0.        1 to: height do:            [:y | 1 to: width+15//16 do:                [:x16 | word16 _ array at: (i _ i + 1).                x16 odd ifTrue: [array32 at: (j _ j+1) put: (word16 bitShift: 16)]                        ifFalse: [array32 at: j put: ((array32 at: j) bitOr: word16)]]].        ^ self initFromArray: array32].    revPixels _ Smalltalk isImageLittleEndian.    1 to: bits size do:        [:index |        (ax _ ax + 1) > aSize ifTrue: [ax _ 1].        bits at: index put: (revPixels                            ifTrue: [(array at: ax) reversePixelsOfDepth: depth]                            ifFalse: [array at: ax])]! !!Form methodsFor: 'private' stamp: 'TPR 9/30/97 23:20'!pixelReverse"reverse the pixels in the Form to support little-endian machines"    | array |    array _self bits.    1 to: array size do: [ :i|        array at: i put: ((array at: i) reversePixelsOfDepth: depth)]! !!Form methodsFor: 'private' stamp: 'TPR 9/30/97 23:20'!setExtent: extent depth: anInteger offset: aPoint        "Create a virtual bit map with the givcen extent and offset."        ^ (self setExtent: extent depth: anInteger) offset: aPoint! !!DisplayScreen methodsFor: 'private' stamp: 'TPR 9/30/97 23:20'!pixelReverse"over-ride the reversal of the pixels in the Form to support little-endian machines, since I get redrawn anyway"! !!Form class methodsFor: 'miscellaneous' stamp: 'TPR 9/30/97 23:20'!startUp"perform system startup actions - in this case, pixel reverse all my instances and subclass instances"    self withAllSubclasses do:[:cl|    cl allInstancesDo:[:i| i pixelReverse]]! !!Integer methodsFor: 'bit manipulation' stamp: 'TPR 9/30/97 23:20'!reversePixelsOfDepth: pixDepth"treat the number as a word from a Form bitmap and pixel reverse it assuming the pixel bit depth is pixDepth"     <primitive: 120>    pixDepth = 32 ifTrue: [^self].    self primitiveFailed! !!Interpreter methodsFor: 'other primitives' stamp: 'TPR 9/30/97 23:20'!primitiveIsVMLittleEndian    "Return whether or not the VM is running on a little-endian machine."     |tigerLilly|     self push: 1.     (self byteAt: stackPointer) = 1 ifTrue: [tigerLilly _ trueObj] ifFalse: [tigerLilly _ falseObj].    self pop:2 thenPush: tigerLilly! !!Interpreter methodsFor: 'other primitives' stamp: 'TPR 9/30/97 23:20'!primitiveReverseForPixelOfDepth    | srcWord srcPix pixelDepth mask nPix dstWord |"Pixel reverse the receiver, which must be a 32bit number. If argument >= 32 or < 1 then fail. If arg = 32, we don't need to call this, so make the Smalltalk code smarter"    pixelDepth _ self popInteger.    "cant do more than 32bit pixels"    (pixelDepth >= 32 or:[ pixelDepth < 1])            ifTrue: [self unPop:1. ^self primitiveFail].    srcWord _ self popPos32BitInteger.    successFlag        ifTrue: [mask _ (1 << pixelDepth) -1.            dstWord _ 0.            nPix _ 32 // pixelDepth.            1 to: nPix do: [:i|                srcPix _ srcWord bitAnd: mask.                srcWord _ srcWord >> pixelDepth.                dstWord _ ((dstWord << pixelDepth) bitOr: srcPix)].            self push: (self positive32BitIntegerFor: dstWord)]        ifFalse: [self unPop: 2.  self primitiveFail]! !!Interpreter class methodsFor: 'initialization' stamp: 'TPR 9/30/97 23:19' prior: 34458662!initializePrimitiveTable    "Interpreter initializePrimitiveTable"    "This table generates a C switch statement."    "NOTE: The real limit here is 2047, but our C compiler currently barfs over 700"    MaxPrimitiveIndex _ 699.    PrimitiveTable _ Array new: MaxPrimitiveIndex+1.    self table: PrimitiveTable from:     #(        "Integer Primitives (0-19)"        (0 primitiveFail)        (1 primitiveAdd)        (2 primitiveSubtract)        (3 primitiveLessThan)        (4 primitiveGreaterThan)        (5 primitiveLessOrEqual)        (6 primitiveGreaterOrEqual)        (7 primitiveEqual)        (8 primitiveNotEqual)        (9 primitiveMultiply)        (10 primitiveDivide)        (11 primitiveMod)        (12 primitiveDiv)        (13 primitiveQuo)        (14 primitiveBitAnd)        (15 primitiveBitOr)        (16 primitiveBitXor)        (17 primitiveBitShift)        (18 primitiveMakePoint)        (19 primitiveFail)        "LargeInteger Primitives (20-39)"        "32-bit logic is aliased to Integer prims above"        (20 39 primitiveFail)        "Float Primitives (40-59)"        (40 primitiveAsFloat)        (41 primitiveFloatAdd)        (42 primitiveFloatSubtract)        (43 primitiveFloatLessThan)        (44 primitiveFloatGreaterThan)        (45 primitiveFloatLessOrEqual)        (46 primitiveFloatGreaterOrEqual)        (47 primitiveFloatEqual)        (48 primitiveFloatNotEqual)        (49 primitiveFloatMultiply)        (50 primitiveFloatDivide)        (51 primitiveTruncated)        (52 primitiveFractionalPart)        (53 primitiveExponent)        (54 primitiveTimesTwoPower)        (55 primitiveSquareRoot)        (56 primitiveSine)        (57 primitiveArctan)        (58 primitiveLogN)        (59 primitiveExp)        "Subscript and Stream Primitives (60-67)"        (60 primitiveAt)        (61 primitiveAtPut)        (62 primitiveSize)        (63 primitiveStringAt)        (64 primitiveStringAtPut)        (65 primitiveNext)        (66 primitiveNextPut)        (67 primitiveAtEnd)        "StorageManagement Primitives (68-79)"        (68 primitiveObjectAt)        (69 primitiveObjectAtPut)        (70 primitiveNew)        (71 primitiveNewWithArg)        (72 primitiveFail)                    "Blue Book: primitiveBecome"        (73 primitiveInstVarAt)        (74 primitiveInstVarAtPut)        (75 primitiveAsOop)        (76 primitiveFail)                    "Blue Book: primitiveAsObject"        (77 primitiveSomeInstance)        (78 primitiveNextInstance)        (79 primitiveNewMethod)        "Control Primitives (80-89)"        (80 primitiveFail)                       "Blue Book:  primitiveBlockCopy"        (81 primitiveValue)        (82 primitiveValueWithArgs)        (83 primitivePerform)        (84 primitivePerformWithArgs)        (85 primitiveSignal)        (86 primitiveWait)        (87 primitiveResume)        (88 primitiveSuspend)        (89 primitiveFlushCache)        "Input/Output Primitives (90-109)"        (90 primitiveMousePoint)        (91 primitiveFail)                    "Blue Book: primitiveCursorLocPut"        (92 primitiveFail)                    "Blue Book: primitiveCursorLink"        (93 primitiveInputSemaphore)        (94 primitiveFail)                    "Blue Book: primitiveSampleInterval"        (95 primitiveInputWord)        (96 primitiveCopyBits)        (97 primitiveSnapshot)        (98 primitiveFail)                    "Blue Book: primitiveTimeWordsInto"        (99 primitiveFail)                    "Blue Book: primitiveTickWordsInto"        (100 primitiveFail)                    "Blue Book: primitiveSignalAtTick"        (101 primitiveBeCursor)        (102 primitiveBeDisplay)        (103 primitiveScanCharacters)        (104 primitiveDrawLoop)        (105 primitiveStringReplace)        (106 primitiveScreenSize)        (107 primitiveMouseButtons)        (108 primitiveKbdNext)        (109 primitiveKbdPeek)        "System Primitives (110-119)"        (110 primitiveEquivalent)        (111 primitiveClass)        (112 primitiveBytesLeft)        (113 primitiveQuit)        (114 primitiveExitToDebugger)        (115 primitiveFail)                    "Blue Book: primitiveOopsLeft"        (116 primitiveIsVMLittleEndian)        "TPR is this machine little-endian? "        (117 primitiveFail)        (118 primitiveFail)        (119 primitiveFail)        "Miscellaneous Primitives (120-127)"        (120 primitiveReverseForPixelOfDepth) "TPR reverse pixel-bits to suit depth"        (121 primitiveImageName)        (122 primitiveNoop)                    "Blue Book: primitiveImageVolume"        (123 primitiveFail)        (124 primitiveLowSpaceSemaphore)        (125 primitiveSignalAtBytesLeft)        (126 primitiveFail)        (127 primitiveFail)        "Squeak Primitives Start Here"        "Squeak Miscellaneous Primitives (128-149)"        (128 primitiveArrayBecome)        (129 primitiveSpecialObjectsOop)        (130 primitiveFullGC)        (131 primitiveIncrementalGC)        (132 primitiveObjectPointsTo)        (133 primitiveSetInterruptKey)        (134 primitiveInterruptSemaphore)        (135 primitiveMillisecondClock)        (136 primitiveSignalAtMilliseconds)        (137 primitiveSecondsClock)        (138 primitiveSomeObject)        (139 primitiveNextObject)        (140 primitiveBeep)        (141 primitiveClipboardText)        (142 primitiveVMPath)        (143 primitiveShortAt)        (144 primitiveShortAtPut)        (145 primitiveConstantFill)        (146 primitiveReadJoystick)        (147 primitiveWarpBits)        (148 primitiveClone)        (149 primitiveGetAttribute)        "File Primitives (150-169)"        (150 primitiveFileAtEnd)        (151 primitiveFileClose)        (152 primitiveFileGetPosition)        (153 primitiveFileOpen)        (154 primitiveFileRead)        (155 primitiveFileSetPosition)        (156 primitiveFileDelete)        (157 primitiveFileSize)        (158 primitiveFileWrite)        (159 primitiveFileRename)        (160 primitiveDirectoryCreate)        (161 primitiveDirectoryDelimitor)        (162 primitiveDirectoryLookup)        (163 168 primitiveFail)        (169 primitiveDirectorySetMacTypeAndCreator)        "Sound Primitives (170-199)"        (170 primitiveSoundStart)        (171 primitiveSoundStartWithSemaphore)        (172 primitiveSoundStop)        (173 primitiveSoundAvailableSpace)        (174 primitiveSoundPlaySamples)        (175 primitiveSoundPlaySilence)        "obsolete; will be removed in the future"        (176 primWaveTableSoundmixSampleCountintostartingAtpan)        (177 primFMSoundmixSampleCountintostartingAtpan)        (178 primPluckedSoundmixSampleCountintostartingAtpan)        (179 primSampledSoundmixSampleCountintostartingAtpan)        (180 188 primitiveFail)        (189 primitiveSoundInsertSamples)        (190 primitiveSoundStartRecording)        (191 primitiveSoundStopRecording)        (192 primitiveSoundGetRecordingSampleRate)        (193 primitiveSoundRecordSamples)        (194 primitiveSoundSetRecordLevel)        (195 199 primitiveFail)        "Networking Primitives (200-229)"        (200 primitiveInitializeNetwork)        (201 primitiveResolverStartNameLookup)        (202 primitiveResolverNameLookupResult)        (203 primitiveResolverStartAddressLookup)        (204 primitiveResolverAddressLookupResult)        (205 primitiveResolverAbortLookup)        (206 primitiveResolverLocalAddress)        (207 primitiveResolverStatus)        (208 primitiveResolverError)        (209 primitiveSocketCreate)        (210 primitiveSocketDestroy)        (211 primitiveSocketConnectionStatus)        (212 primitiveSocketError)        (213 primitiveSocketLocalAddress)        (214 primitiveSocketLocalPort)        (215 primitiveSocketRemoteAddress)        (216 primitiveSocketRemotePort)        (217 primitiveSocketConnectToPort)        (218 primitiveSocketListenOnPort)        (219 primitiveSocketCloseConnection)        (220 primitiveSocketAbortConnection)        (221 primitiveSocketReceiveDataBufCount)        (222 primitiveSocketReceiveDataAvailable)        (223 primitiveSocketSendDataBufCount)        (224 primitiveSocketSendDone)        (225 229 primitiveFail)        "Other Primitives (230-249)"        (230 primitiveRelinquishProcessor)        (231 249 primitiveFail)        "VM Implementor Primitives (250-255)"        (250 clearProfile)        (251 dumpProfile)        (252 startProfiling)        (253 stopProfiling)        (254 primitiveVMParameter)        (255 primitiveFail)        "Quick Push Const Methods"        (256 primitivePushSelf)        (257 primitivePushTrue)        (258 primitivePushFalse)        (259 primitivePushNil)        (260 primitivePushMinusOne)        (261 primitivePushZero)        (262 primitivePushOne)        (263 primitivePushTwo)        "Quick Push Const Methods"        (264 519 primitiveLoadInstVar)        "Unassigned Primitives"        (520 primitiveBeep) "test of new primitive indices"        (521 699 primitiveFail)    ).! !!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'TPR 9/30/97 23:20'!isImageLittleEndian     ImageIsLittleEndian isNil        ifTrue: [ImageIsLittleEndian _ false]. "This should only happen the first time the code is installed, probably on a Mac"  ^ImageIsLittleEndian ! !!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'TPR 9/30/97 23:20'!isImageLittleEndian: aBoolean     ImageIsLittleEndian _ aBoolean! !!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'TPR 9/30/97 23:20'!isVMLittleEndian     <primitive: 116>     ^false "Assume big-endian if no prim, since we are probably installingthis code on a Mac" ! !!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'TPR 9/30/97 23:19' prior: 35511690!processStartUpList    "Call the startUp method on each object that needs to gracefully restart itself after a snapshot."    DisplayScreen startUp.    self isVMLittleEndian = self isImageLittleEndian        ifFalse: [ Form startUp.            self isImageLittleEndian: self isVMLittleEndian].    Cursor startUp.    Smalltalk installLowSpaceWatcher.    InputSensor startUp.    ProcessorScheduler startUp.    Delay startUp.    Smalltalk startUp.    ControlManager startUp.! !----SNAPSHOT----(12 October 1997 6:11:24 pm ) priorSource: 2192430!Interpreter translate: 'InterpTest.c' doInlining: true.        Smalltalk beep!InterpreterSupportCode writeMacSourceFiles!5000000 // (Time millisecondsToRun: [10 benchmark]) * 1000!| r t | t _ Time millisecondsToRun: [r _ 26 benchFib].            r//t*1000 !5000000 // (Time millisecondsToRun: [10 benchmark]) * 1000! | r t | t _ Time millisecondsToRun: [r _ 26 benchFib].            r//t*1000 !| socket unixHost |
 Socket initializeNetwork.
    unixHost := NetNameResolver addressFromString: '199.170.106.10'.
    socket _ Socket new connectTo: unixHost port: 79.
    socket waitForConnectionUntil: Socket standardDeadline.
    socket sendData: 'timjones' , (String with: Character cr with: Character
linefeed)!----SNAPSHOT----(14 October 1997 3:46:20 pm ) priorSource: 2252280!