'From Squeak 2.0 of May 22, 1998 on 22 May 1998 at 4:32:15 pm'! Object subclass: #AbstractScoreEvent instanceVariableNames: 'time ' classVariableNames: '' poolDictionaries: '' category: 'Music-Scores'! !AbstractScoreEvent commentStamp: 'di 5/22/1998 16:32' prior: 0! Abstract class for timed events in a MIDI score. ! !AbstractScoreEvent methodsFor: 'all' stamp: 'jm 12/31/97 11:46'! isNoteEvent ^ false ! ! !AbstractScoreEvent methodsFor: 'all' stamp: 'jm 12/31/97 11:46'! isTempoEvent ^ false ! ! !AbstractScoreEvent methodsFor: 'all' stamp: 'jm 12/31/97 11:43'! time ^ time ! ! !AbstractScoreEvent methodsFor: 'all' stamp: 'jm 12/31/97 11:43'! time: aNumber time _ aNumber. ! ! Object subclass: #AbstractSound instanceVariableNames: 'envelopes mSecsSinceStart samplesUntilNextControl scaledVol scaledVolIncr scaledVolLimit ' classVariableNames: 'MaxScaledValue ScaleFactor Sounds ' poolDictionaries: '' category: 'System-Sound'! !AbstractSound methodsFor: 'initialization' stamp: 'jm 12/9/97 11:31'! duration: seconds "Scale my envelopes to the given duration. Subclasses overriding this method should include a resend to super." envelopes do: [:e | e duration: seconds]. ! ! !AbstractSound methodsFor: 'initialization' stamp: 'jm 2/4/98 09:54'! initialize envelopes _ #(). mSecsSinceStart _ 0. samplesUntilNextControl _ 0. scaledVol _ (1.0 * ScaleFactor) rounded. scaledVolIncr _ 0. scaledVolLimit _ scaledVol. ! ! !AbstractSound methodsFor: 'initialization' stamp: 'jm 1/31/98 16:09'! setLoudness: vol "Initialize my volume envelopes and initial volume. Subclasses overriding this method should include a resend to super." envelopes do: [:e | (e isKindOf: VolumeEnvelope) ifTrue: [e scale: vol]]. self initialVolume: vol. ! ! !AbstractSound methodsFor: 'initialization' stamp: 'jm 1/31/98 15:26'! setPitch: p dur: d loudness: l "Initialize my envelopes for the given parameters. Subclasses overriding this method should include a resend to super." envelopes do: [:e | (e isKindOf: VolumeEnvelope) ifTrue: [e scale: l]. (e isKindOf: PitchEnvelope) ifTrue: [e centerPitch: p]. e duration: d]. self initialVolume: l. self duration: d. ! ! !AbstractSound methodsFor: 'envelopes' stamp: 'jm 12/17/97 22:23'! addEnvelope: anEnvelope "Add the given envelope to my envelopes list." anEnvelope target: self. envelopes _ envelopes copyWith: anEnvelope. ! ! !AbstractSound methodsFor: 'envelopes' stamp: 'jm 12/15/97 17:02'! envelopes "Return my collection of envelopes." ^ envelopes ! ! !AbstractSound methodsFor: 'envelopes' stamp: 'jm 12/15/97 17:02'! removeEnvelope: anEnvelope "Remove the given envelope from my envelopes list." envelopes _ envelopes copyWithout: anEnvelope. ! ! !AbstractSound methodsFor: 'volume' stamp: 'jm 2/4/98 06:49'! adjustVolumeTo: vol overMSecs: mSecs "Adjust the volume of this sound to the given volume, a number in the range [0.0..1.0], over the given number of milliseconds. The volume will be changed a little bit on each sample until the desired volume is reached." | newScaledVol | newScaledVol _ (32768.0 * vol) truncated. newScaledVol = scaledVol ifTrue: [^ self]. scaledVolLimit _ newScaledVol. scaledVolLimit > ScaleFactor ifTrue: [scaledVolLimit _ ScaleFactor]. scaledVolLimit < 0 ifTrue: [scaledVolLimit _ 0]. mSecs = 0 ifTrue: [ "change immediately" scaledVol _ scaledVolLimit. scaledVolIncr _ 0] ifFalse: [ scaledVolIncr _ ((scaledVolLimit - scaledVol) * 1000) // (self samplingRate * mSecs)]. ! ! !AbstractSound methodsFor: 'volume' stamp: 'jm 12/17/97 17:39'! initialVolume: vol "Set the initial volume of this sound to the given volume, a number in the range [0.0..1.0]." scaledVol _ (((vol asFloat min: 1.0) max: 0.0) * ScaleFactor) rounded. scaledVolLimit _ scaledVol. scaledVolIncr _ 0. ! ! !AbstractSound methodsFor: 'volume' stamp: 'di 1/31/98 15:55'! loudness "Return a suitable volume for initing" ^ scaledVol asFloat / ScaleFactor asFloat! ! !AbstractSound methodsFor: 'volume' stamp: 'jm 12/16/97 10:30'! volumeEnvelopeScaledTo: scalePoint "Return a collection of values representing my volume envelope scaled by the given point. The scale point's x component is pixels/second and its y component is the number of pixels for full volume." | env amp vScale cnt oldT newT totalCnt | self error: 'not yet implemented'. "old code:" totalCnt _ "initialCount" 1000. env _ Array new: (totalCnt * scalePoint x // self samplingRate min: 500). amp _ scaledVol asFloat / ScaleFactor. vScale _ scalePoint y asFloat / 1000.0. cnt _ totalCnt. oldT _ newT _ 0. "Time in units of scale x per second" [cnt > 0 and: [newT <= env size]] whileTrue: [env atAll: (oldT+1 to: newT) put: (amp*vScale) asInteger. oldT _ newT. "amp _ amp * decayRate." cnt _ cnt - samplesUntilNextControl. newT _ totalCnt - cnt * scalePoint x // self samplingRate]. env atAll: ((oldT+1 min: env size) to: env size) put: (amp*vScale) asInteger. ^ env ! ! !AbstractSound methodsFor: 'playing' stamp: 'jm 1/26/98 22:05'! computeSamplesForSeconds: seconds "Compute the samples of this sound without outputting them, and return the resulting buffer of samples." | buf | self reset. buf _ SoundBuffer newStereoSampleCount: (self samplingRate * seconds) asInteger. self playSampleCount: buf stereoSampleCount into: buf startingAt: 1. ^ buf ! ! !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'! play "Play this sound to the sound ouput port in real time." SoundPlayer playSound: self.! ! !AbstractSound methodsFor: 'playing' stamp: 'jm 12/9/97 10:46'! playAndWaitUntilDone "Play this sound to the sound ouput port in real time." SoundPlayer playSound: self. [self samplesRemaining > 0] whileTrue. ! ! !AbstractSound methodsFor: 'playing' stamp: 'jm 1/26/98 22:05'! playSampleCount: n into: aSoundBuffer startingAt: startIndex "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." | fullVol samplesBetweenControlUpdates pastEnd i remainingSamples count | fullVol _ AbstractSound scaleFactor. 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 leftVol: fullVol rightVol: fullVol. samplesUntilNextControl _ samplesUntilNextControl - count. samplesUntilNextControl <= 0 ifTrue: [ self doControl. samplesUntilNextControl _ samplesBetweenControlUpdates]. i _ i + count]. ! ! !AbstractSound methodsFor: 'playing' stamp: 'jm 1/26/98 22:05'! 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]. ! ! !AbstractSound methodsFor: 'playing' stamp: 'jm 1/26/98 22:06'! playSilentlyUntil: startTime "Compute the samples of this sound without outputting them. Used to fast foward to a particular starting time. The start time is given in seconds." | buf startSample nextSample samplesRemaining n | self reset. buf _ SoundBuffer newStereoSampleCount: (self samplingRate // 10). startSample _ (startTime * self samplingRate) asInteger. nextSample _ 1. [self samplesRemaining > 0] whileTrue: [ nextSample >= startSample ifTrue: [^ self]. samplesRemaining _ startSample - nextSample. samplesRemaining > buf stereoSampleCount ifTrue: [n _ buf stereoSampleCount] ifFalse: [n _ samplesRemaining]. self playSampleCount: n into: buf startingAt: 1. nextSample _ nextSample + n]. ! ! !AbstractSound methodsFor: 'playing' stamp: 'jm 3/4/98 13:16'! resumePlaying "Resume playing this sound from where it last stopped." SoundPlayer resumePlaying: self. ! ! !AbstractSound methodsFor: 'sound generation' stamp: 'jm 2/4/98 09:56'! doControl "Update the control parameters of this sound using its envelopes, if any." "Note: This is only called at a small fraction of the sampling rate." | pitchModOrRatioChange | mSecsSinceStart _ mSecsSinceStart + (1000 // self controlRate). envelopes size > 0 ifTrue: [ pitchModOrRatioChange _ false. 1 to: envelopes size do: [:i | ((envelopes at: i) updateTargetAt: mSecsSinceStart) ifTrue: [pitchModOrRatioChange _ true]]. pitchModOrRatioChange ifTrue: [self internalizeModulationAndRatio]]. ! ! !AbstractSound methodsFor: 'sound generation' stamp: 'jm 2/4/98 08:56'! internalizeModulationAndRatio "Overridden by FMSound. This default implementation does nothing." ! ! !AbstractSound methodsFor: 'sound generation' stamp: 'jm 11/24/97 16:00'! mixSampleCount: n into: aSoundBuffer startingAt: startIndex leftVol: leftVol rightVol: rightVol "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 leftVol and rightVol parameters determine the volume of the sound in each channel, where 0 is silence and 1000 is full volume." self subclassResponsibility. ! ! !AbstractSound methodsFor: 'sound generation' stamp: 'jm 2/4/98 18:59'! reset "Reset my internal state for a replay. Methods that override this method should do super reset." mSecsSinceStart _ 0. samplesUntilNextControl _ self samplingRate // self controlRate. envelopes size > 0 ifTrue: [ 1 to: envelopes size do: [:i | (envelopes at: i) reset]]. ! ! !AbstractSound methodsFor: 'sound generation' stamp: 'jm 12/17/97 17:57'! samplesRemaining "Answer the number of samples remaining until the end of this sound. A sound with an indefinite ending time should answer some large integer such as 1000000." ^ 1000000 ! ! !AbstractSound methodsFor: 'sound generation' stamp: 'jm 1/5/98 14:21'! storeSample: sample in: aSoundBuffer at: sliceIndex leftVol: leftVol rightVol: rightVol "This method is provided for documentation. To gain 10% more speed when running sound generation in Smalltalk, this method is hand-inlined into all sound generation methods that use it." | i s | leftVol > 0 ifTrue: [ i _ (2 * sliceIndex) - 1. s _ (aSoundBuffer at: i) + ((sample * leftVol) // ScaleFactor). s > 32767 ifTrue: [s _ 32767]. "clipping!!" s < -32767 ifTrue: [s _ -32767]. "clipping!!" aSoundBuffer at: i put: s]. rightVol > 0 ifTrue: [ i _ 2 * sliceIndex. s _ (aSoundBuffer at: i) + ((sample * rightVol) // ScaleFactor). s > 32767 ifTrue: [s _ 32767]. "clipping!!" s < -32767 ifTrue: [s _ -32767]. "clipping!!" aSoundBuffer at: i put: s]. ! ! !AbstractSound methodsFor: 'sound generation' stamp: 'jm 12/17/97 17:57'! updateVolume "Increment the volume envelope of this sound. To avoid clicks, the volume envelope must be interpolated at the sampling rate, rather than just at the control rate like other envelopes. At the control rate, the volume envelope computes the slope and next target volume volume for the current segment of the envelope (i.e., it sets the rate of change for the volume parameter). When that target volume is reached, incrementing is stopped until a new increment is set." "This method is provided for documentation. To gain 10% more speed when running sound generation in Smalltalk, it is hand-inlined into all sound generation methods that use it." scaledVolIncr ~= 0 ifTrue: [ scaledVol _ scaledVol + scaledVolIncr. ((scaledVolIncr > 0 and: [scaledVol >= scaledVolLimit]) or: [scaledVolIncr < 0 and: [scaledVol <= scaledVolLimit]]) ifTrue: [ "reached the limit; stop incrementing" scaledVol _ scaledVolLimit. scaledVolIncr _ 0]]. ! ! !AbstractSound methodsFor: 'composition'! + aSound "Return the mix of the receiver and the argument sound." ^ MixedSound new add: self; add: aSound ! ! !AbstractSound methodsFor: 'composition'! , aSound "Return the concatenation of the receiver and the argument sound." ^ SequentialSound new add: self; add: aSound ! ! !AbstractSound methodsFor: 'composition' stamp: 'jm 12/17/97 18:00'! delayedBy: seconds "Return a composite sound consisting of a rest for the given amount of time followed by the receiver." ^ (RestSound dur: seconds), self ! ! !AbstractSound methodsFor: 'sampling rates' stamp: 'jm 12/15/97 14:15'! controlRate "Answer the number of control changes per second." ^ 100 ! ! !AbstractSound methodsFor: 'sampling rates' stamp: 'jm 12/17/97 18:00'! samplingRate "Answer the sampling rate in samples per second." ^ SoundPlayer samplingRate ! ! !AbstractSound methodsFor: 'copying' stamp: 'jm 12/15/97 19:15'! copy "A sound should copy all of the state needed to play itself, allowing two copies of a sound to play at the same time. These semantics require a recursive copy but only down to the level of immutable data. For example, a SampledSound need not copy its sample buffer. Subclasses overriding this method should include a resend to super." ^ self clone copyEnvelopes ! ! !AbstractSound methodsFor: 'copying' stamp: 'jm 12/17/97 22:22'! copyEnvelopes "Private!! Support for copying. Copy my envelopes." envelopes _ envelopes collect: [:e | e copy target: self]. ! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AbstractSound class instanceVariableNames: ''! !AbstractSound class methodsFor: 'class initialization' stamp: 'di 2/2/98 14:39'! initialize "AbstractSound initialize" ScaleFactor _ 2 raisedTo: 15. MaxScaledValue _ ((2 raisedTo: 31) // ScaleFactor) - 1. "magnitude of largest scaled value in 32-bits"! ! !AbstractSound class methodsFor: 'class initialization' stamp: 'jm 1/5/98 13:51'! scaleFactor ^ ScaleFactor ! ! !AbstractSound class methodsFor: 'instance creation' stamp: 'jm 1/5/98 17:40'! default "Return a default sound prototype for this class, with envelopes if appropriate. (This is in contrast to new, which returns a raw instance without envelopes.)" ^ self new ! ! !AbstractSound class methodsFor: 'instance creation' stamp: 'jm 12/17/97 17:26'! dur: d "Return a rest of the given duration." ^ self basicNew setDur: d ! ! !AbstractSound class methodsFor: 'instance creation' stamp: 'jm 12/17/97 17:26'! new ^ self basicNew initialize ! ! !AbstractSound class methodsFor: 'instance creation' stamp: 'di 1/30/98 14:28'! noteSequenceOn: aSound from: anArray "Build a note sequence (i.e., a SequentialSound) from the given array using the given sound as the instrument. Elements are either (pitch, duration, loudness) triples or (#rest duration) pairs. Pitches can be given as names or as numbers." | score pitch | score _ SequentialSound new. anArray do: [:el | el size = 3 ifTrue: [ pitch _ el at: 1. pitch isNumber ifFalse: [pitch _ self pitchForName: pitch]. score add: ( aSound copy setPitch: pitch dur: (el at: 2) loudness: (el at: 3) / 1000.0)] ifFalse: [ score add: (RestSound dur: (el at: 2))]]. ^ score ! ! !AbstractSound class methodsFor: 'instance creation' stamp: 'jm 12/17/97 17:27'! pitch: p dur: d loudness: l "Return a new sound object for a note with the given parameters." ^ self new setPitch: p dur: d loudness: l ! ! !AbstractSound class methodsFor: 'instance creation'! pitchForName: aString "AbstractSound pitchForName: 'c2'" "#(c 'c#' d eb e f fs g 'g#' a bf b) collect: [ :s | AbstractSound pitchForName: s, '4']" | s modifier octave i j noteName p | s _ ReadStream on: aString. modifier _ $n. noteName _ s next. (s atEnd not and: [s peek isDigit]) ifFalse: [ modifier _ s next ]. s atEnd ifTrue: [ octave _ 4 ] ifFalse: [ octave _ Integer readFrom: s ]. octave < 0 ifTrue: [ self error: 'cannot use negative octave number' ]. i _ 'cdefgab' indexOf: noteName. i = 0 ifTrue: [ self error: 'bad note name: ', noteName asString ]. i _ #(2 4 6 7 9 11 13) at: i. j _ 's#fb' indexOf: modifier. j = 0 ifFalse: [ i _ i + (#(1 1 -1 -1) at: j) ]. "i is now in range: [1..14]" "Table generator: (1 to: 14) collect: [ :i | 16.3516 * (2.0 raisedTo: (i - 2) asFloat / 12.0)]" p _ #(15.4339 16.3516 17.3239 18.354 19.4454 20.6017 21.8268 23.1247 24.4997 25.9565 27.5 29.1352 30.8677 32.7032) at: i. octave timesRepeat: [ p _ 2.0 * p ]. ^ p ! ! !AbstractSound class methodsFor: 'examples' stamp: 'di 1/31/98 00:33'! chromaticPitchesFrom: aPitch | pitch halfStep | pitch _ aPitch isNumber ifTrue: [aPitch] ifFalse: [self pitchForName: aPitch]. halfStep _ self halfStep. pitch _ pitch / halfStep. ^ (0 to: 14) collect: [:i | pitch _ pitch * halfStep]! ! !AbstractSound class methodsFor: 'examples' stamp: 'jm 1/5/98 17:35'! chromaticScale "PluckedSound chromaticScale play" ^ self chromaticScaleOn: self default ! ! !AbstractSound class methodsFor: 'examples' stamp: 'jm 1/31/98 16:14'! chromaticScaleOn: aSound "PluckedSound chromaticScale play" ^ self noteSequenceOn: aSound from: (((self chromaticPitchesFrom: #c4) copyFrom: 1 to: 13) collect: [:pitch | Array with: pitch with: 0.5 with: 300]) ! ! !AbstractSound class methodsFor: 'examples' stamp: 'di 1/31/98 00:32'! halfStep ^ 2.0 raisedTo: 1.0/12.0! ! !AbstractSound class methodsFor: 'examples' stamp: 'jm 1/5/98 17:36'! hiMajorScale "FMSound hiMajorScale play" ^ self hiMajorScaleOn: self default ! ! !AbstractSound class methodsFor: 'examples' stamp: 'di 1/30/98 16:00'! hiMajorScaleOn: aSound "FMSound hiMajorScale play" ^ self majorScaleOn: aSound from: #c6! ! !AbstractSound class methodsFor: 'examples' stamp: 'jm 1/5/98 17:36'! lowMajorScale "PluckedSound lowMajorScale play" ^ self lowMajorScaleOn: self default ! ! !AbstractSound class methodsFor: 'examples' stamp: 'di 1/30/98 16:01'! lowMajorScaleOn: aSound "PluckedSound lowMajorScale play" ^ self majorScaleOn: aSound from: #c3! ! !AbstractSound class methodsFor: 'examples' stamp: 'di 1/30/98 16:04'! majorChord "FMSound majorChord play" ^ self majorChordOn: self default from: #c4! ! !AbstractSound class methodsFor: 'examples' stamp: 'jm 1/31/98 16:25'! majorChordOn: aSound from: aPitch "FMSound majorChord play" | score majorScale leadingRest pan note | majorScale _ self majorPitchesFrom: aPitch. score _ MixedSound new. leadingRest _ pan _ 0. #(1 3 5 8) do: [:noteIndex | note _ aSound copy setPitch: (majorScale at: noteIndex) dur: 2.0 - leadingRest loudness: 0.3. score add: (RestSound dur: leadingRest), note pan: pan. leadingRest _ leadingRest + 0.2. pan _ pan + 0.3]. ^ score ! ! !AbstractSound class methodsFor: 'examples' stamp: 'di 1/30/98 14:45'! majorPitchesFrom: aPitch | chromatic | chromatic _ self chromaticPitchesFrom: aPitch. ^ #(1 3 5 6 8 10 12 13 15 13 12 10 8 6 5 3 1) collect: [:i | chromatic at: i]. ! ! !AbstractSound class methodsFor: 'examples' stamp: 'jm 1/5/98 17:34'! majorScale "FMSound majorScale play" ^ self majorScaleOn: self default ! ! !AbstractSound class methodsFor: 'examples' stamp: 'di 1/30/98 16:00'! majorScaleOn: aSound "FMSound majorScale play" ^ self majorScaleOn: aSound from: #c5! ! !AbstractSound class methodsFor: 'examples' stamp: 'jm 1/31/98 16:14'! majorScaleOn: aSound from: aPitch "FMSound majorScale play" ^ self noteSequenceOn: aSound from: ((self majorPitchesFrom: aPitch) collect: [:pitch | Array with: pitch with: 0.25 with: 300]) ! ! !AbstractSound class methodsFor: 'examples' stamp: 'jm 1/5/98 17:32'! scaleTest "AbstractSound scaleTest play" ^ MixedSound new add: FMSound majorScale pan: 0; add: (PluckedSound lowMajorScale delayedBy: 0.5) pan: 1.0. ! ! !AbstractSound class methodsFor: 'examples' stamp: 'jm 12/17/97 21:25'! 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 mod mult | SoundPlayer startPlayerProcessBufferSize: 1100 rate: 11025 stereo: false. s _ FMSound pitch: 440.0 dur: 200.0 loudness: 0.2. SoundPlayer playSound: s. lastVal _ nil. [Sensor anyButtonPressed] whileFalse: [ mousePt _ Sensor cursorPoint. mousePt ~= lastVal ifTrue: [ mod _ mousePt x asFloat / 20.0. mult _ mousePt y asFloat / 20.0. s modulation: mod multiplier: mult. lastVal _ mousePt. status _ 'mod: ', mod printString, ' mult: ', mult printString. status asParagraph displayOn: Display at: 10@10]]. SoundPlayer shutDown. ! ! !AbstractSound class methodsFor: 'examples-bach fugue' stamp: 'jm 1/5/98 17:38'! bachFugue "Play a fugue by J. S. Bach using and instance of me as the sound for all four voices." "PluckedSound bachFugue play" ^ self bachFugueOn: self default ! ! !AbstractSound class methodsFor: 'examples-bach fugue' stamp: 'jm 1/5/98 18:27'! bachFugueOn: aSound "Play a fugue by J. S. Bach using the given sound as the sound for all four voices." "PluckedSound bachFugue play" ^ MixedSound new add: (self bachFugueVoice1On: aSound) pan: 1.0; add: (self bachFugueVoice2On: aSound) pan: 0.0; add: (self bachFugueVoice3On: aSound) pan: 1.0; add: (self bachFugueVoice4On: aSound) pan: 0.0. ! ! !AbstractSound class methodsFor: 'examples-bach fugue' stamp: 'jm 12/17/97 16:51'! bachFugueVoice1On: aSound "Voice one of a fugue by J. S. Bach." ^ self noteSequenceOn: aSound from: #( (1047 0.15 268) (988 0.15 268) (1047 0.30 268) (784 0.30 268) (831 0.30 268) (1047 0.15 268) (988 0.15 268) (1047 0.30 268) (1175 0.30 268) (784 0.30 268) (1047 0.15 268) (988 0.15 268) (1047 0.30 268) (1175 0.30 268) (698 0.15 268) (784 0.15 268) (831 0.60 268) (784 0.15 268) (698 0.15 268) (622 0.15 268) (1047 0.15 268) (988 0.15 268) (880 0.15 268) (784 0.15 268) (698 0.15 268) (622 0.15 268) (587 0.15 268) (523 0.30 268) (1245 0.30 268) (1175 0.30 268) (1047 0.30 268) (932 0.30 268) (880 0.30 268) (932 0.30 268) (1047 0.30 268) (740 0.30 268) (784 0.30 268) (880 0.30 268) (740 0.30 268) (784 0.60 268) (rest 0.15) (523 0.15 268) (587 0.15 268) (622 0.15 268) (698 0.15 268) (784 0.15 268) (831 0.45 268) (587 0.15 268) (622 0.15 268) (698 0.15 268) (784 0.15 268) (880 0.15 268) (932 0.45 268) (622 0.15 268) (698 0.15 268) (784 0.15 268) (831 0.15 268) (784 0.15 268) (698 0.15 268) (622 0.15 268) (587 0.30 268) (1047 0.15 268) (988 0.15 268) (1047 0.60 268) (rest 0.9) (1397 0.30 268) (1245 0.30 268) (1175 0.30 268) (rest 0.3) (831 0.30 268) (784 0.30 268) (698 0.30 268) (784 0.30 268) (698 0.15 268) (622 0.15 268) (698 0.30 268) (587 0.30 268) (784 0.60 268) (rest 0.3) (988 0.30 268) (1047 0.30 268) (1047 0.15 268) (988 0.15 268) (1047 0.30 268) (784 0.30 268) (831 0.60 268) (rest 0.3) (880 0.30 268) (932 0.30 268) (932 0.15 268) (880 0.15 268) (932 0.30 268) (698 0.30 268) (784 0.60 268) (rest 0.3) (784 0.30 268) (831 0.30 268) (831 0.30 268) (784 0.30 268) (698 0.30 268) (rest 0.3) (415 0.30 268) (466 0.30 268) (523 0.30 268) (rest 0.3) (415 0.15 268) (392 0.15 268) (415 0.30 268) (349 0.30 268) (466 0.30 268) (523 0.30 268) (466 0.30 268) (415 0.30 268) (466 0.30 268) (392 0.30 268) (349 0.30 268) (311 0.30 268) (349 0.30 268) (554 0.30 268) (523 0.30 268) (466 0.30 268) (523 0.30 268) (415 0.30 268) (392 0.30 268) (349 0.30 268) (392 0.30 268) (784 0.15 268) (740 0.15 268) (784 0.30 268) (523 0.30 268) (622 0.30 268) (784 0.15 268) (740 0.15 268) (784 0.30 268) (880 0.30 268) (587 0.30 268) (784 0.15 268) (740 0.15 268) (784 0.30 268) (880 0.30 268) (523 0.15 268) (587 0.15 268) (622 0.60 268) (587 0.15 268) (523 0.15 268) (466 0.30 346) (rest 0.45) (587 0.15 346) (659 0.15 346) (740 0.15 346) (784 0.15 346) (880 0.15 346) (932 0.45 346) (659 0.15 346) (698 0.15 346) (784 0.15 346) (880 0.15 346) (932 0.15 346) (1047 0.45 346) (740 0.15 346) (784 0.15 346) (880 0.15 346) (932 0.30 346) (622 0.15 346) (587 0.15 346) (622 0.30 346) (392 0.30 346) (415 0.30 346) (698 0.15 346) (622 0.15 346) (698 0.30 346) (440 0.30 346) (466 0.30 346) (784 0.15 346) (698 0.15 346) (784 0.30 346) (494 0.30 346) (523 0.15 346) (698 0.15 346) (622 0.15 346) (587 0.15 346) (523 0.15 346) (466 0.15 346) (440 0.15 346) (392 0.15 346) (349 0.30 346) (831 0.30 346) (784 0.30 346) (698 0.30 346) (622 0.30 346) (587 0.30 346) (622 0.30 346) (698 0.30 346) (494 0.30 346) (523 0.30 346) (587 0.30 346) (494 0.30 346) (523 0.60 346) (rest 0.3) (659 0.30 346) (698 0.30 346) (698 0.15 346) (659 0.15 346) (698 0.30 346) (523 0.30 346) (587 0.60 346) (rest 0.3) (587 0.30 346) (622 0.30 346) (622 0.15 346) (587 0.15 346) (622 0.30 346) (466 0.30 346) (523 1.20 346) (523 0.30 346) (587 0.15 346) (622 0.15 346) (698 0.15 346) (622 0.15 346) (698 0.15 346) (587 0.15 346) (494 0.30 457) (rest 0.6) (494 0.30 457) (523 0.30 457) (rest 0.6) (622 0.30 457) (587 0.30 457) (rest 0.6) (698 0.60 457) (rest 0.6) (698 0.30 457) (622 0.30 457) (831 0.30 457) (784 0.30 457) (698 0.30 457) (622 0.30 457) (587 0.30 457) (622 0.30 457) (698 0.30 457) (494 0.30 457) (523 0.30 457) (587 0.30 457) (494 0.30 457) (494 0.30 457) (523 0.30 457) (rest 0.3) (523 0.30 457) (698 0.15 457) (587 0.15 457) (622 0.15 457) (523 0.45 457) (494 0.30 457) (523 0.60 457) (rest 0.3) (659 0.30 268) (698 0.60 268) (rest 0.3) (698 0.30 268) (698 0.30 268) (622 0.15 268) (587 0.15 268) (622 0.30 268) (698 0.30 268) (587 0.40 268) (rest 0.4) (587 0.40 268) (rest 0.4) (523 1.60 268)).! ! !AbstractSound class methodsFor: 'examples-bach fugue' stamp: 'jm 12/17/97 16:52'! bachFugueVoice2On: aSound "Voice two of a fugue by J. S. Bach." ^ self noteSequenceOn: aSound from: #( (rest 4.8) (1568 0.15 346) (1480 0.15 346) (1568 0.30 346) (1047 0.30 346) (1245 0.30 346) (1568 0.15 346) (1480 0.15 346) (1568 0.30 346) (1760 0.30 346) (1175 0.30 346) (1568 0.15 346) (1480 0.15 346) (1568 0.30 346) (1760 0.30 346) (1047 0.15 346) (1175 0.15 346) (1245 0.60 346) (1175 0.15 346) (1047 0.15 346) (932 0.30 346) (1245 0.15 346) (1175 0.15 346) (1245 0.30 346) (784 0.30 346) (831 0.30 346) (1397 0.15 346) (1245 0.15 346) (1397 0.30 346) (880 0.30 346) (932 0.30 346) (1568 0.15 346) (1397 0.15 346) (1568 0.30 346) (988 0.30 346) (1047 0.30 346) (1175 0.15 346) (1245 0.15 346) (1397 0.90 346) (1245 0.15 346) (1175 0.15 346) (1047 0.15 346) (932 0.15 346) (831 0.15 346) (784 0.15 346) (698 0.30 346) (1661 0.30 346) (1568 0.30 346) (1397 0.30 346) (1245 0.30 346) (1175 0.30 346) (1245 0.30 346) (1397 0.30 346) (988 0.30 346) (1047 0.30 346) (1175 0.30 346) (988 0.30 346) (1047 0.30 457) (1568 0.15 457) (1480 0.15 457) (1568 0.30 457) (1175 0.30 457) (1245 0.60 457) (rest 0.3) (1319 0.30 457) (1397 0.30 457) (1397 0.15 457) (1319 0.15 457) (1397 0.30 457) (1047 0.30 457) (1175 0.60 457) (rest 0.3) (1175 0.30 457) (1245 0.30 457) (1245 0.15 457) (1175 0.15 457) (1245 0.30 457) (932 0.30 457) (1047 0.30 457) (1245 0.15 457) (1175 0.15 457) (1245 0.30 457) (1397 0.30 457) (932 0.30 457) (1245 0.15 457) (1175 0.15 457) (1245 0.30 457) (1397 0.30 457) (831 0.15 457) (932 0.15 457) (1047 0.60 457) (932 0.15 457) (831 0.15 457) (784 0.15 457) (622 0.15 457) (698 0.15 457) (784 0.15 457) (831 0.15 457) (932 0.15 457) (1047 0.15 457) (1175 0.15 457) (1245 0.15 457) (1175 0.15 457) (1047 0.15 457) (1175 0.15 457) (1245 0.15 457) (1397 0.15 457) (1568 0.15 457) (1760 0.15 457) (1865 0.15 457) (698 0.15 457) (784 0.15 457) (831 0.15 457) (932 0.15 457) (1047 0.15 457) (1175 0.15 457) (1319 0.15 457) (1397 0.15 457) (1245 0.15 457) (1175 0.15 457) (1245 0.15 457) (1397 0.15 457) (1568 0.15 457) (1760 0.15 457) (1976 0.15 457) (2093 0.30 457) (1976 0.15 457) (1760 0.15 457) (1568 0.15 457) (1397 0.15 457) (1245 0.15 457) (1175 0.15 457) (1047 0.30 457) (1245 0.30 457) (1175 0.30 457) (1047 0.30 457) (932 0.30 457) (880 0.30 457) (932 0.30 457) (1047 0.30 457) (740 0.30 457) (784 0.30 457) (880 0.30 457) (740 0.30 457) (784 0.30 457) (1175 0.15 457) (1047 0.15 457) (1175 0.30 457) (rest 0.6) (1319 0.15 457) (1175 0.15 457) (1319 0.30 457) (rest 0.6) (1480 0.15 457) (1319 0.15 457) (1480 0.30 457) (rest 0.6) (784 0.15 457) (698 0.15 457) (784 0.30 457) (rest 0.6) (880 0.15 457) (784 0.15 457) (880 0.30 457) (rest 0.6) (988 0.15 457) (880 0.15 457) (988 0.30 457) (rest 0.6) (1047 0.15 457) (988 0.15 457) (1047 0.30 457) (784 0.30 457) (831 0.30 457) (1047 0.15 457) (988 0.15 457) (1047 0.30 457) (1175 0.30 457) (784 0.30 457) (1047 0.15 457) (988 0.15 457) (1047 0.30 457) (1175 0.30 457) (698 0.15 457) (784 0.15 457) (831 0.60 457) (784 0.15 457) (698 0.15 457) (622 0.30 457) (1047 0.15 457) (988 0.15 457) (1047 0.30 457) (784 0.30 457) (831 0.60 457) (rest 0.3) (880 0.30 457) (932 0.30 457) (932 0.15 457) (880 0.15 457) (932 0.30 457) (698 0.30 457) (784 0.60 457) (rest 0.3) (784 0.60 457) (831 0.15 457) (932 0.15 457) (1047 0.15 457) (988 0.15 457) (1047 0.15 457) (831 0.15 457) (698 1.20 457) (698 0.30 591) (1175 0.15 591) (1047 0.15 591) (1175 0.30 591) (698 0.30 591) (622 0.30 591) (1245 0.15 591) (1175 0.15 591) (1245 0.30 591) (784 0.30 591) (698 0.30 591) (1397 0.15 591) (1245 0.15 591) (1397 0.30 591) (831 0.30 591) (784 0.15 591) (1397 0.15 591) (1245 0.15 591) (1175 0.15 591) (1047 0.15 591) (988 0.15 591) (880 0.15 591) (784 0.15 591) (1047 0.30 591) (1397 0.30 591) (1245 0.30 591) (1175 0.30 591) (rest 0.3) (831 0.30 591) (784 0.30 591) (698 0.30 591) (784 0.30 591) (698 0.15 591) (622 0.15 591) (698 0.30 591) (587 0.30 591) (831 0.30 591) (784 0.30 591) (rest 0.3) (880 0.30 591) (988 0.30 591) (1047 0.30 591) (698 0.15 591) (622 0.15 591) (587 0.15 591) (523 0.15 591) (523 0.30 591) (1047 0.15 346) (988 0.15 346) (1047 0.30 346) (784 0.30 346) (831 0.30 346) (1047 0.15 346) (988 0.15 346) (1047 0.30 346) (1175 0.30 346) (784 0.30 346) (1047 0.15 346) (988 0.15 346) (1047 0.30 346) (1175 0.30 346) (698 0.20 346) (784 0.20 346) (831 0.80 346) (784 0.20 346) (698 0.20 346) (659 1.60 346)). ! ! !AbstractSound class methodsFor: 'examples-bach fugue' stamp: 'jm 12/17/97 16:52'! bachFugueVoice3On: aSound "Voice three of a fugue by J. S. Bach." ^ self noteSequenceOn: aSound from: #( (rest 14.4) (523 0.15 457) (494 0.15 457) (523 0.30 457) (392 0.30 457) (415 0.30 457) (523 0.15 457) (494 0.15 457) (523 0.30 457) (587 0.30 457) (392 0.30 457) (523 0.15 457) (494 0.15 457) (523 0.30 457) (587 0.30 457) (349 0.15 457) (392 0.15 457) (415 0.60 457) (392 0.15 457) (349 0.15 457) (311 0.15 457) (523 0.15 457) (494 0.15 457) (440 0.15 457) (392 0.15 457) (349 0.15 457) (311 0.15 457) (294 0.15 457) (262 0.15 457) (294 0.15 457) (311 0.15 457) (294 0.15 457) (262 0.15 457) (233 0.15 457) (208 0.15 457) (196 0.15 457) (175 0.15 457) (466 0.15 457) (415 0.15 457) (392 0.15 457) (349 0.15 457) (311 0.15 457) (294 0.15 457) (262 0.15 457) (233 0.15 457) (262 0.15 457) (294 0.15 457) (262 0.15 457) (233 0.15 457) (208 0.15 457) (196 0.15 457) (175 0.15 457) (156 0.15 457) (415 0.15 457) (392 0.15 457) (349 0.15 457) (311 0.15 457) (277 0.15 457) (262 0.15 457) (233 0.15 457) (208 0.30 457) (523 0.30 457) (466 0.30 457) (415 0.30 457) (392 0.30 457) (349 0.30 457) (392 0.30 457) (415 0.30 457) (294 0.30 457) (311 0.30 457) (349 0.30 457) (294 0.30 457) (311 0.30 457) (415 0.30 457) (392 0.30 457) (349 0.30 457) (392 0.30 457) (311 0.30 457) (294 0.30 457) (262 0.30 457) (294 0.30 457) (466 0.30 457) (415 0.30 457) (392 0.30 457) (415 0.30 457) (349 0.30 457) (311 0.30 457) (294 0.30 457) (311 0.30 457) (rest 1.2) (262 0.30 457) (233 0.30 457) (220 0.30 457) (rest 0.3) (311 0.30 457) (294 0.30 457) (262 0.30 457) (294 0.30 457) (262 0.15 457) (233 0.15 457) (262 0.30 457) (294 0.30 457) (196 0.30 591) (466 0.15 591) (440 0.15 591) (466 0.30 591) (294 0.30 591) (311 0.30 591) (523 0.15 591) (466 0.15 591) (523 0.30 591) (330 0.30 591) (349 0.30 591) (587 0.15 591) (523 0.15 591) (587 0.30 591) (370 0.30 591) (392 0.60 591) (rest 0.15) (196 0.15 591) (220 0.15 591) (247 0.15 591) (262 0.15 591) (294 0.15 591) (311 0.45 591) (220 0.15 591) (233 0.15 591) (262 0.15 591) (294 0.15 591) (311 0.15 591) (349 0.45 591) (247 0.15 591) (262 0.15 591) (294 0.15 591) (311 0.30 591) (rest 0.6) (330 0.30 591) (349 0.30 591) (175 0.30 591) (156 0.30 591) (147 0.30 591) (rest 0.3) (208 0.30 591) (196 0.30 591) (175 0.30 591) (196 0.30 591) (175 0.15 591) (156 0.15 591) (175 0.30 591) (196 0.30 591) (262 0.15 591) (294 0.15 591) (311 0.15 591) (294 0.15 591) (262 0.15 591) (233 0.15 591) (208 0.15 591) (196 0.15 591) (175 0.15 591) (466 0.15 591) (415 0.15 591) (392 0.15 591) (349 0.15 591) (311 0.15 591) (294 0.15 591) (262 0.15 591) (233 0.15 591) (262 0.15 591) (294 0.15 591) (262 0.15 591) (233 0.15 591) (208 0.15 591) (196 0.15 591) (175 0.15 591) (156 0.15 591) (415 0.15 591) (392 0.15 591) (349 0.15 591) (311 0.15 591) (294 0.15 591) (262 0.15 591) (233 0.15 591) (208 0.15 591) (233 0.15 591) (262 0.15 591) (233 0.15 591) (208 0.15 591) (196 0.15 591) (175 0.15 591) (156 0.15 591) (147 0.15 591) (392 0.15 591) (349 0.15 591) (311 0.15 591) (294 0.15 591) (262 0.15 591) (247 0.15 591) (220 0.15 591) (196 0.60 772) (196 0.60 772) (rest 0.15) (196 0.15 772) (220 0.15 772) (247 0.15 772) (262 0.15 772) (294 0.15 772) (311 0.15 772) (349 0.15 772) (392 0.15 772) (349 0.15 772) (415 0.15 772) (392 0.15 772) (349 0.15 772) (311 0.15 772) (294 0.15 772) (262 0.15 772) (247 0.30 772) (262 0.15 772) (494 0.15 772) (262 0.30 772) (196 0.30 772) (208 0.30 772) (262 0.15 772) (247 0.15 772) (262 0.30 772) (294 0.30 772) (196 0.30 772) (262 0.15 772) (247 0.15 772) (262 0.30 772) (294 0.30 772) (175 0.15 772) (196 0.15 772) (208 0.60 772) (196 0.15 772) (175 0.15 772) (156 0.60 772) (rest 0.3) (311 0.30 772) (294 0.30 772) (262 0.30 772) (392 0.30 772) (196 0.30 772) (262 3.60 268) (494 0.40 268) (rest 0.4) (494 0.40 268) (rest 0.4) (392 1.60 268)). ! ! !AbstractSound class methodsFor: 'examples-bach fugue' stamp: 'jm 12/17/97 16:52'! bachFugueVoice4On: aSound "Voice four of a fugue by J. S. Bach." ^ self noteSequenceOn: aSound from: #( (rest 61.2) (131 0.15 500) (123 0.15 500) (131 0.30 500) (98 0.30 500) (104 0.30 500) (131 0.15 500) (123 0.15 500) (131 0.30 500) (147 0.30 500) (98 0.30 500) (131 0.15 500) (123 0.15 500) (131 0.30 500) (147 0.30 500) (87 0.15 500) (98 0.15 500) (104 0.60 500) (98 0.15 500) (87 0.15 500) (78 0.60 500) (rest 0.3) (156 0.30 500) (147 0.30 500) (131 0.30 500) (196 0.30 500) (98 0.30 500) (131 3.60 268) (131 3.20 205)). ! ! !AbstractSound class methodsFor: 'examples-bach fugue' stamp: 'jm 1/5/98 17:45'! stereoBachFugue "Play fugue by J. S. Bach in stereo using different timbres." "AbstractSound stereoBachFugue play" "(AbstractSound bachFugueVoice1On: FMSound flute1) play" "(AbstractSound bachFugueVoice1On: PluckedSound default) play" ^ MixedSound new add: (self bachFugueVoice1On: FMSound oboe1) pan: 0.2; add: (self bachFugueVoice2On: FMSound organ1) pan: 0.8; add: (self bachFugueVoice3On: PluckedSound default) pan: 0.4; add: (self bachFugueVoice4On: FMSound brass1) pan: 0.6. ! ! !AbstractSound class methodsFor: 'primitive generation' stamp: 'jm 1/21/98 17:08'! 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." "AbstractSound cCodeForSoundPrimitives" ^ CCodeGenerator new codeStringForPrimitives: #( (FMSound mixSampleCount:into:startingAt:leftVol:rightVol:) (PluckedSound mixSampleCount:into:startingAt:leftVol:rightVol:) (SampledSound mixSampleCount:into:startingAt:leftVol:rightVol:) (ReverbSound applyReverbTo:startingAt:count:) ). ! ! !AbstractSound class methodsFor: 'sounds' stamp: 'di 1/27/98 15:12'! initSounds "AbstractSound initSounds" Sounds _ Dictionary new. (FMSound class organization listAtCategoryNamed: #instruments) do: [:soundName | Sounds at: soundName asString put: (FMSound perform: soundName)]! ! !AbstractSound class methodsFor: 'sounds' stamp: 'di 1/27/98 15:13'! soundNamed: soundName ^ Sounds at: soundName! ! !AbstractSound class methodsFor: 'sounds' stamp: 'jm 3/4/98 10:29'! soundNamed: soundName ifAbsent: aBlock ^ Sounds at: soundName ifAbsent: aBlock ! ! !AbstractSound class methodsFor: 'sounds' stamp: 'jm 5/16/1998 09:54'! soundNamed: soundName put: aSound Sounds at: soundName put: aSound. Smalltalk at: #ScorePlayerMorph ifPresent: [:playerClass | playerClass allInstancesDo: [:player | player updateInstrumentsFromLibrary]]. ! ! !AbstractSound class methodsFor: 'sounds' stamp: 'di 1/27/98 15:13'! soundNames ^ Sounds keys! ! FileDirectory subclass: #AcornFileDirectory instanceVariableNames: '' classVariableNames: 'FormsAreLittleEndian ' poolDictionaries: '' category: 'System-Files'! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AcornFileDirectory class instanceVariableNames: ''! !AcornFileDirectory class methodsFor: 'platform specific' stamp: 'jm 3/27/98 09:24'! byteReverseForm: aForm "Byte-reverse the words of the given Form's bitmap. Supports porting a Squeak image to the Acorn." | bits w reversedW | bits _ aForm bits. 1 to: bits size do: [:i | w _ bits at: i. reversedW _ Integer byte1: (w digitAt: 4) byte2: (w digitAt: 3) byte3: (w digitAt: 2) byte4: (w digitAt: 1). bits at: i put: reversedW]. ! ! !AcornFileDirectory class methodsFor: 'platform specific' stamp: 'jm 3/27/98 06:44'! extensionDelimiter "Return the character used to delimit filename extensions. For the Acorn, use a slash, since that is what a dot gets converted to when loading files from foreign file systems." ^ $/ ! ! !AcornFileDirectory class methodsFor: 'platform specific' stamp: 'jm 3/27/98 06:41'! pathNameDelimiter ^ $. ! ! !AcornFileDirectory class methodsFor: 'platform specific' stamp: 'jm 3/27/98 09:25'! platformSpecificStartup "Do platform-specific startup. This is a hook for starting up a default Squeak image on an Acorn, whose BitBlt expects Forms to have little-endian byte ordering." FormsAreLittleEndian ifNil: [FormsAreLittleEndian _ false]. FormsAreLittleEndian ifTrue: [^ self]. "already converted" Form withAllSubclasses do: [:c | c allInstancesDo: [:f | "skip the Display, since it will be redrawn anyway" f == Display ifFalse: [self byteReverseForm: f]]]. FormsAreLittleEndian _ true. ! ! SwikiAction subclass: #ActiveSwikiAction instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'PluggableWebServer'! !ActiveSwikiAction methodsFor: 'as yet unclassified' stamp: 'ls 5/1/98 11:29'! browse: pageRef from: request "Just reply with a page in HTML format" | formattedPage liveText| liveText _ HTMLformatter evalEmbedded: (pageRef text) with: request unlessContains: (self dangerSet). formattedPage _ pageRef copy. "Make a copy, then format the text." formattedPage formatted: (HTMLformatter swikify: liveText linkhandler: [:link | urlmap linkFor: link from: request peerName storingTo: OrderedCollection new]). request reply: ((self formatterFor: 'page') format: formattedPage). ! ! !ActiveSwikiAction methodsFor: 'as yet unclassified' stamp: 'tk 2/4/98 12:52'! dangerSet ^#('Smalltalk' 'view' 'open' 'perform:' 'FileStream' 'FileDirectory' 'fileIn' 'Compiler' 'halt' 'PWS' 'Swiki') ! ! !ActiveSwikiAction methodsFor: 'as yet unclassified' stamp: 'tk 1/31/98 16:44'! inputFrom: request "Take user's input and respond with a searchresult or store the edit" | coreRef page | coreRef _ request message size < 2 ifTrue: ['1'] ifFalse: [request message at: 2]. coreRef = 'searchresult' ifTrue: [ "If contains search string, do search" request reply: PWS crlf, (HTMLformatter evalEmbedded: (self fileContents: source, 'results.html') with: (urlmap searchFor: (request fields at: 'searchFor' ifAbsent: ['nothing']))). ^ #return]. (request fields includesKey: 'text') ifTrue: ["It's a response from an edit, so store the page" page _ urlmap storeID: coreRef text: (request fields at: 'text' ifAbsent: ['blank text']) from: request peerName. page user: request userID. ^ self]. "return self means do serve the edited page afterwards" "oops, a new kind!! -- but don't complain!! Could be for ActivePage!!" " Transcript show: 'Unknown data from client. '; show: request fields printString; cr."! ! SketchMorph subclass: #ActorDroneMorph instanceVariableNames: 'running clan ' classVariableNames: 'ClanCache OnTicksSelectorCache ' poolDictionaries: '' category: 'Experimental-Miscellaneous'! !ActorDroneMorph commentStamp: 'di 5/22/1998 16:32' prior: 0! ActorDroneMorph comment: 'I am a class of ActorMorphs that all share the same behavior methods. OnTicks defined for one of me is used for all of me as long as we are of the same clan. Clan is a symbol that is our name.'! !ActorDroneMorph methodsFor: 'all' stamp: 'tk 8/20/97 09:07'! clan ^ clan! ! !ActorDroneMorph methodsFor: 'all' stamp: 'sw 8/17/97 23:00'! clan: aSymbol clan _ aSymbol! ! !ActorDroneMorph methodsFor: 'all' stamp: 'sw 8/17/97 22:59'! nameInModel ^ clan! ! !ActorDroneMorph methodsFor: 'all' stamp: 'tk 8/21/97 13:22'! onTicksSelector "Cache the interned symbol. Should intern: do this?" clan = ClanCache ifTrue: [^ OnTicksSelectorCache]. ClanCache _ clan. ^ OnTicksSelectorCache _ (self nameInModel, 'OnTicks:') asSymbol ! ! !ActorDroneMorph methodsFor: 'all' stamp: 'sw 8/18/97 13:41'! step running ifTrue: [ self world model perform: self onTicksSelector with: self]. ! ! !ActorDroneMorph methodsFor: 'all' stamp: 'tk 8/27/97 23:46'! stepTime ^ 0! ! Object subclass: #ActorState instanceVariableNames: 'owningPlayer penDown penSize penColor fractionalPosition instantiatedUserScriptsDictionary ' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Scripting-Support'! !ActorState commentStamp: 'di 5/22/1998 16:32' prior: 0! Holds a record of data representing actor-like slots in the Morph, on behalf of an associated Player. Presently also holds onto the scriptInstantion objects that represent active scripts in an instance, but this will probably change soon.! !ActorState methodsFor: 'initialization' stamp: 'sw 4/30/1998 22:32'! copyWithPlayerReferenceNilled "Answer a copy of the receiver in which all the items referring to the corresponding Player object are nilled out, for the purpose of being set up with fresh values, after the copy, by the caller" | holdPlayer holdScriptDict copy copyScriptDict | holdPlayer _ owningPlayer. owningPlayer _ nil. holdScriptDict _ self instantiatedUserScriptsDictionary. instantiatedUserScriptsDictionary _ nil. copy _ self deepCopy. owningPlayer _ holdPlayer. instantiatedUserScriptsDictionary _ holdScriptDict. holdScriptDict ifNotNil: [copyScriptDict _ IdentityDictionary new. holdScriptDict associationsDo: [:assoc | copyScriptDict add: (assoc key -> (assoc value copyWithPlayerObliterated))]. copy instantiatedUserScriptsDictionary: copyScriptDict]. ^ copy ! ! !ActorState methodsFor: 'initialization' stamp: 'sw 5/13/1998 16:37'! initializeFor: aPlayer | aNewDictionary | owningPlayer _ aPlayer. instantiatedUserScriptsDictionary ifNil: [^ self]. aNewDictionary _ IdentityDictionary new. instantiatedUserScriptsDictionary associationsDo: [:assoc | aNewDictionary at: assoc key put: (assoc value shallowCopy player: aPlayer)]. instantiatedUserScriptsDictionary _ aNewDictionary.! ! !ActorState methodsFor: 'pen' stamp: 'sw 4/22/1998 13:51'! choosePenColor: evt evt hand changeColorTarget: owningPlayer costume selector: #penColor:. ! ! !ActorState methodsFor: 'pen' stamp: 'sw 4/22/1998 13:44'! choosePenSize | menu sz | menu _ CustomMenu new. 1 to: 10 do: [:w | menu add: w printString action: w]. sz _ menu startUp. sz ifNotNil: [penSize _ sz]! ! !ActorState methodsFor: 'pen' stamp: 'sw 2/4/98 15:16'! defaultPenColor ^ Color blue! ! !ActorState methodsFor: 'pen' stamp: 'sw 2/4/98 15:03'! defaultPenSize ^ 1! ! !ActorState methodsFor: 'pen' stamp: 'sw 4/22/1998 13:35'! getPenColor penColor ifNil: [penColor _ self defaultPenColor]. ^ penColor! ! !ActorState methodsFor: 'pen' stamp: 'sw 4/22/1998 13:40'! getPenDown ^ penDown == true! ! !ActorState methodsFor: 'pen' stamp: 'sw 4/22/1998 13:43'! getPenSize penSize ifNil: [penSize _ self defaultPenSize]. ^ penSize! ! !ActorState methodsFor: 'pen' stamp: 'sw 2/4/98 18:07'! liftPen penDown _ false! ! !ActorState methodsFor: 'pen' stamp: 'sw 2/4/98 14:58'! lowerPen penDown _ true! ! !ActorState methodsFor: 'pen' stamp: 'sw 2/4/98 18:03'! penColor: aColor penColor _ aColor! ! !ActorState methodsFor: 'pen' stamp: 'sw 4/22/1998 13:51'! setPenColor: aColor penColor _ aColor ! ! !ActorState methodsFor: 'pen' stamp: 'sw 4/22/1998 13:47'! setPenDown: aBoolean penDown _ aBoolean! ! !ActorState methodsFor: 'pen' stamp: 'sw 4/22/1998 13:45'! setPenSize: aNumber penSize _ aNumber! ! !ActorState methodsFor: 'position' stamp: 'jm 4/24/1998 21:34'! fractionalPosition "Return my player's costume's position including the fractional part. This allows the precise position to be retained to avoid cummulative rounding errors, while letting Morphic do all its calculations with integer pixel coordinates. See the implementation of forward:." ^ fractionalPosition ! ! !ActorState methodsFor: 'position' stamp: 'jm 4/24/1998 21:31'! fractionalPosition: aPoint fractionalPosition _ aPoint asFloatPoint. ! ! !ActorState methodsFor: 'script instantiations' stamp: 'sw 4/9/98 22:35'! instantiatedUserScriptsDictionary instantiatedUserScriptsDictionary ifNil: [instantiatedUserScriptsDictionary _ IdentityDictionary new]. ^ instantiatedUserScriptsDictionary! ! !ActorState methodsFor: 'script instantiations' stamp: 'sw 4/30/1998 21:51'! instantiatedUserScriptsDictionary: aDict "Used for copying code only" instantiatedUserScriptsDictionary _ aDict! ! !ActorState methodsFor: 'other' stamp: 'sw 4/22/1998 17:02'! addPlayerMenuItemsTo: aMenu hand: aHandMorph self getPenDown ifTrue: [aMenu add: 'pen up' action: #liftPen] ifFalse: [aMenu add: 'pen down' action: #lowerPen]. aMenu add: 'pen size' action: #choosePenSize. aMenu add: 'pen color' action: #choosePenColor:.! ! !ActorState methodsFor: 'other' stamp: 'sw 4/13/1998 19:36'! costume ^ owningPlayer costume! ! !ActorState methodsFor: 'other' stamp: 'sw 5/12/1998 23:35'! printOn: aStream aStream nextPutAll: 'ActorState for ', owningPlayer externalName, ' '. penDown ifNotNil: [aStream cr; nextPutAll: 'penDown ', penDown printString]. penColor ifNotNil: [aStream cr; nextPutAll: 'penColor ', penColor printString]. penSize ifNotNil: [aStream cr; nextPutAll: 'penSize ', penSize printString]. instantiatedUserScriptsDictionary ifNotNil: [aStream cr; nextPutAll: '+ ', instantiatedUserScriptsDictionary size printString, ' user scripts']. ! ! RectangleMorph subclass: #AlignmentMorph instanceVariableNames: 'orientation centering hResizing vResizing inset minCellSize openToDragNDrop layoutNeeded ' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Basic'! !AlignmentMorph methodsFor: 'initialization' stamp: 'sw 9/10/97 14:47'! initialize super initialize. borderWidth _ 0. orientation _ #horizontal. "#horizontal or #vertical or #free" 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. ! ! !AlignmentMorph methodsFor: 'classification' stamp: 'sw 5/13/1998 14:50'! demandsBoolean "unique to the TEST frame inside a CompoundTileMorph" ^ self hasProperty: #demandsBoolean! ! !AlignmentMorph methodsFor: 'classification' stamp: 'di 5/7/1998 01:20'! isAlignmentMorph ^ true ! ! !AlignmentMorph methodsFor: 'accessing'! centering ^ centering ! ! !AlignmentMorph methodsFor: 'accessing'! centering: aSymbol "Set the minor dimension alignment to #topLeft, #center, or #bottomRight." centering _ aSymbol. ! ! !AlignmentMorph methodsFor: 'accessing' stamp: 'sw 2/13/98 16:15'! chooseOrientation | aMenu emphases reply | emphases _ #(vertical horizontal). aMenu _ EmphasizedMenu selections: emphases. aMenu onlyBoldItem: (emphases indexOf: orientation). reply _ aMenu startUpWithCaption: 'Choose orientation'. (reply == nil or: [reply == orientation]) ifTrue: [^ self]. self orientation: reply. self layoutChanged! ! !AlignmentMorph methodsFor: 'accessing' stamp: 'sw 10/19/97 23:39'! configureForKids self openToDragNDrop: false. super configureForKids ! ! !AlignmentMorph methodsFor: 'accessing'! hResizing ^ hResizing ! ! !AlignmentMorph methodsFor: 'accessing'! hResizing: aSymbol "Set the horizontal resizing style to #spaceFill, #shrinkWrap, or #rigid." hResizing _ aSymbol. ! ! !AlignmentMorph methodsFor: 'accessing'! inset ^ inset ! ! !AlignmentMorph methodsFor: 'accessing'! inset: anInteger "Set the amount of padding within my bounds to the given amount." inset _ anInteger. ! ! !AlignmentMorph methodsFor: 'accessing'! minCellSize ^ minCellSize ! ! !AlignmentMorph methodsFor: 'accessing'! minCellSize: anInteger "Set the minium space per submorph to the given size. Useful for making tables." minCellSize _ anInteger. ! ! !AlignmentMorph methodsFor: 'accessing'! openCloseDragNDrop "Toggle this morph's ability to add and remove morphs via drag-n-drop." openToDragNDrop _ openToDragNDrop not. ! ! !AlignmentMorph methodsFor: 'accessing'! openToDragNDrop ^ openToDragNDrop ! ! !AlignmentMorph methodsFor: 'accessing'! openToDragNDrop: aBoolean "Set this morph's ability to add and remove morphs via drag-n-drop." openToDragNDrop _ aBoolean. ! ! !AlignmentMorph methodsFor: 'accessing'! orientation ^ orientation ! ! !AlignmentMorph methodsFor: 'accessing' stamp: 'sw 9/10/97 14:55'! orientation: aSymbol "Set the major layout dimension to #horizontal or #vertical or #free" orientation _ aSymbol. ! ! !AlignmentMorph methodsFor: 'accessing'! vResizing ^ vResizing ! ! !AlignmentMorph methodsFor: 'accessing'! vResizing: aSymbol "Set the vertical resizing style to #spaceFill, #shrinkWrap, or #rigid." vResizing _ aSymbol. ! ! !AlignmentMorph methodsFor: 'geometry' stamp: 'jm 7/8/97 08:26'! layoutChanged "invalidate old fullBounds in case we shrink" fullBounds ifNotNil: [self invalidRect: fullBounds]. super layoutChanged. layoutNeeded _ true. ! ! !AlignmentMorph methodsFor: 'dropping/grabbing' stamp: 'sw 10/18/97 18:03'! 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. ! ! !AlignmentMorph methodsFor: 'dropping/grabbing'! allowSubmorphExtraction ^ openToDragNDrop ! ! !AlignmentMorph methodsFor: 'dropping/grabbing' stamp: 'sw 10/18/97 18:19'! rootForGrabOf: aMorph | root | openToDragNDrop ifFalse: [^ super rootForGrabOf: aMorph]. root _ aMorph. [root == self] whileFalse: [root owner = self ifTrue: [^ root]. root _ root owner]. ^ super rootForGrabOf: aMorph ! ! !AlignmentMorph methodsFor: 'dropping/grabbing'! wantsDroppedMorph: aMorph event: evt "Supports adding morphs by dropping." ^ openToDragNDrop! ! !AlignmentMorph 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 ! ! !AlignmentMorph methodsFor: 'layout' stamp: 'sw 2/13/98 16:15'! maxWidth "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)]]. orientation == #vertical ifTrue: [minW _ 0. submorphs do: [:m | minW _ minW max: m minWidth]. spaceNeeded _ minW + (2 * (inset + borderWidth))]. ^ spaceNeeded! ! !AlignmentMorph methodsFor: 'layout' stamp: 'sw 2/13/98 16:15'! 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))]. orientation == #vertical ifTrue: [spaceNeeded _ 2 * (inset + borderWidth). submorphs do: [:m | spaceNeeded _ spaceNeeded + (m minHeight max: minCellSize)]]. ^ spaceNeeded ! ! !AlignmentMorph methodsFor: 'layout' stamp: 'jm 1/29/98 19:43'! minHeightWhenEmpty ^ 2 ! ! !AlignmentMorph methodsFor: 'layout' stamp: 'sw 2/13/98 16:15'! 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)]]. orientation == #vertical ifTrue: [minW _ 0. submorphs do: [:m | minW _ minW max: m minWidth]. spaceNeeded _ minW + (2 * (inset + borderWidth))]. ^ spaceNeeded! ! !AlignmentMorph methodsFor: 'layout' stamp: 'jm 1/29/98 19:43'! minWidthWhenEmpty ^ 2 ! ! !AlignmentMorph methodsFor: 'menu' stamp: 'sw 9/11/97 16:07'! addCustomMenuItems: aCustomMenu hand: aHandMorph super addCustomMenuItems: aCustomMenu hand: aHandMorph. aCustomMenu add: 'orientation...' action: #chooseOrientation. aCustomMenu add: (openToDragNDrop ifTrue: ['close'] ifFalse: ['open']) , ' dragNdrop' action: #openCloseDragNDrop. ! ! !AlignmentMorph methodsFor: 'private' stamp: 'di 5/7/1998 01:21'! extraSpacePerMorph | spaceFillingMorphs spaceNeeded extra | spaceFillingMorphs _ 0. spaceNeeded _ 2 * (inset + borderWidth). orientation = #horizontal ifTrue: [ submorphs do: [:m | spaceNeeded _ spaceNeeded + (m minWidth max: minCellSize). (m isAlignmentMorph 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 isAlignmentMorph and: [m vResizing = #spaceFill]) ifTrue: [spaceFillingMorphs _ spaceFillingMorphs + 1]]. extra _ (bounds height - spaceNeeded) max: 0]. (submorphs size <= 1 or: [spaceFillingMorphs <= 1]) ifTrue: [^ extra]. ^ extra // spaceFillingMorphs ! ! !AlignmentMorph methodsFor: 'private' stamp: 'sw 2/13/98 16:15'! 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]. ! ! !AlignmentMorph methodsFor: 'private' stamp: 'sw 9/10/97 14:54'! 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]]]. orientation == #vertical ifTrue: [submorphs doWithIndex: [:m :i | newCenter y < m fullBounds center y ifTrue: [^ i]]]. ^ submorphs size + 1 "insert after the last submorph" ! ! !AlignmentMorph 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]. ! ! !AlignmentMorph methodsFor: 'private' stamp: 'di 5/7/1998 01:21'! placeAndSize: m at: nextPlace padding: padding | space totalInset fullBnds left top | totalInset _ inset + borderWidth. orientation = #horizontal ifTrue: [ space _ m minWidth max: minCellSize. m isAlignmentMorph ifTrue: [ (m hResizing = #spaceFill) ifTrue: [space _ space + padding]. m layoutInWidth: space height: (bounds height - (2 * totalInset))]. ] ifFalse: [ space _ m minHeight max: minCellSize. m isAlignmentMorph 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 ! ! !AlignmentMorph methodsFor: 'private' stamp: 'di 5/7/1998 01:21'! 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 isAlignmentMorph 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]. ! ! !AlignmentMorph methodsFor: 'private' stamp: 'sw 5/6/1998 15:58'! wantsKeyboardFocusFor: aSubmorph aSubmorph wouldAcceptKeyboardFocus ifTrue: [^ true]. ^ super wantsKeyboardFocusFor: aSubmorph! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AlignmentMorph class instanceVariableNames: ''! !AlignmentMorph class methodsFor: 'instance creation'! newColumn ^ self new orientation: #vertical; hResizing: #spaceFill; vResizing: #spaceFill ! ! !AlignmentMorph class methodsFor: 'instance creation'! newRow ^ self new orientation: #horizontal; hResizing: #spaceFill; vResizing: #spaceFill; borderWidth: 0 ! ! !AlignmentMorph class methodsFor: 'instance creation' stamp: 'jm 5/4/1998 12:18'! newSpacer: aColor "Answer a space-filling instance of me of the given color." ^ self new hResizing: #spaceFill; vResizing: #spaceFill; inset: 0; borderWidth: 0; color: aColor. ! ! Path subclass: #Arc instanceVariableNames: 'quadrant radius center ' classVariableNames: '' poolDictionaries: '' category: 'Graphics-Paths'! !Arc commentStamp: 'di 5/22/1998 16:32' prior: 0! Arc comment: 'Arcs are an unusual implementation of splines due to Ted Kaehler. Imagine two lines that meet at a corner. Now imagine two moving points; one moves from the corner to the end on one line, the other moves from the end of the other line in to the corner. Now imagine a series of lines drawn between those moving points at each step along the way (they form a sort of spider web pattern). By connecting segments of the intersecting lines, a smooth curve is achieved that is tangent to both of the original lines. Voila.'! !Arc methodsFor: 'accessing'! center "Answer the point at the center of the receiver." ^center! ! !Arc methodsFor: 'accessing'! center: aPoint "Set aPoint to be the receiver's center." center _ aPoint! ! !Arc methodsFor: 'accessing'! center: aPoint radius: anInteger "The receiver is defined by a point at the center and a radius. The quadrant is not reset." center _ aPoint. radius _ anInteger! ! !Arc methodsFor: 'accessing'! center: aPoint radius: anInteger quadrant: section "Set the receiver's quadrant to be the argument, section. The size of the receiver is defined by the center and its radius." center _ aPoint. radius _ anInteger. quadrant _ section! ! !Arc methodsFor: 'accessing'! quadrant "Answer the part of the circle represented by the receiver." ^quadrant! ! !Arc methodsFor: 'accessing'! quadrant: section "Set the part of the circle represented by the receiver to be the argument, section." quadrant _ section! ! !Arc methodsFor: 'accessing'! radius "Answer the receiver's radius." ^radius! ! !Arc methodsFor: 'accessing'! radius: anInteger "Set the receiver's radius to be the argument, anInteger." radius _ anInteger! ! !Arc methodsFor: 'display box access'! computeBoundingBox | aRectangle aPoint | aRectangle _ center - radius + form offset extent: form extent + (radius * 2) asPoint. aPoint _ center + form extent. quadrant = 1 ifTrue: [^ aRectangle encompass: center x @ aPoint y]. quadrant = 2 ifTrue: [^ aRectangle encompass: aPoint x @ aPoint y]. quadrant = 3 ifTrue: [^ aRectangle encompass: aPoint x @ center y]. quadrant = 4 ifTrue: [^ aRectangle encompass: center x @ center y]! ! !Arc methodsFor: 'displaying'! displayOn: aDisplayMedium at: aPoint clippingBox: clipRect rule: anInteger fillColor: aForm | nSegments line angle sin cos xn yn xn1 yn1 | nSegments _ 12.0. line _ Line new. line form: self form. angle _ 90.0 / nSegments. sin _ (angle * (2 * Float pi / 360.0)) sin. cos _ (angle * (2 * Float pi / 360.0)) cos. quadrant = 1 ifTrue: [xn _ radius asFloat. yn _ 0.0]. quadrant = 2 ifTrue: [xn _ 0.0. yn _ 0.0 - radius asFloat]. quadrant = 3 ifTrue: [xn _ 0.0 - radius asFloat. yn _ 0.0]. quadrant = 4 ifTrue: [xn _ 0.0. yn _ radius asFloat]. nSegments asInteger timesRepeat: [xn1 _ xn * cos + (yn * sin). yn1 _ yn * cos - (xn * sin). line beginPoint: center + (xn asInteger @ yn asInteger). line endPoint: center + (xn1 asInteger @ yn1 asInteger). line displayOn: aDisplayMedium at: aPoint clippingBox: clipRect rule: anInteger fillColor: aForm. xn _ xn1. yn _ yn1]! ! !Arc methodsFor: 'displaying'! displayOn: aDisplayMedium transformation: aTransformation clippingBox: clipRect rule: anInteger fillColor: aForm | newArc tempCenter | newArc _ Arc new. tempCenter _ aTransformation applyTo: self center. newArc center: tempCenter x asInteger @ tempCenter y asInteger. newArc quadrant: self quadrant. newArc radius: (self radius * aTransformation scale x) asInteger. newArc form: self form. newArc displayOn: aDisplayMedium at: 0 @ 0 clippingBox: clipRect rule: anInteger fillColor: aForm! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Arc class instanceVariableNames: ''! !Arc class methodsFor: 'examples'! example "Click the button somewhere on the screen. The designated point will be the center of an Arc with radius 50 in the 4th quadrant." | anArc aForm | aForm _ Form extent: 1 @ 30. "make a long thin Form for display" aForm fillBlack. "turn it black" anArc _ Arc new. anArc form: aForm. "set the form for display" anArc radius: 50.0. anArc center: Sensor waitButton. anArc quadrant: 4. anArc displayOn: Display. Sensor waitButton "Arc example"! ! ArrayedCollection variableSubclass: #Array instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Collections-Arrayed'! !Array commentStamp: 'di 5/22/1998 16:32' prior: 0! Array comment: 'I present an ArrayedCollection whose elements are objects.'! !Array methodsFor: 'comparing'! hash "Make sure that equal (=) arrays hash equally." self size = 0 ifTrue: [^17171]. ^(self at: 1) hash + (self at: self size) hash! ! !Array methodsFor: 'comparing'! hashMappedBy: map "Answer what my hash would be if oops changed according to map." self size = 0 ifTrue: [^self hash]. ^(self first hashMappedBy: map) + (self last hashMappedBy: map)! ! !Array methodsFor: 'converting'! asArray "Answer with the receiver itself." ^self! ! !Array methodsFor: 'converting'! elementsExchangeIdentityWith: otherArray self primitiveFailed! ! !Array methodsFor: 'converting'! evalStrings "Allows you to construct literal arrays. #(true false nil '5@6' 'Set new' '''text string''') evalStrings gives an array with true, false, nil, a Point, a Set, and a String instead of just a bunch of Symbols" | it | ^ self collect: [:each | it _ each. each == #true ifTrue: [it _ true]. each == #false ifTrue: [it _ false]. each == #nil ifTrue: [it _ nil]. each class == String ifTrue: [ it _ Compiler evaluate: each]. each class == Array ifTrue: [it _ it evalStrings]. it]! ! !Array methodsFor: 'printing'! isLiteral self detect: [:element | element isLiteral not] ifNone: [^true]. ^false! ! !Array methodsFor: 'printing' stamp: 'di 6/20/97 09:09'! printOn: aStream aStream nextPut: $(. self do: [:element | element printOn: aStream. aStream space]. aStream nextPut: $)! ! !Array methodsFor: 'printing'! storeOn: aStream "Use the literal form if possible." self isLiteral ifTrue: [aStream nextPut: $#; nextPut: $(. self do: [:element | element printOn: aStream. aStream space]. aStream nextPut: $)] ifFalse: [super storeOn: aStream]! ! !Array methodsFor: 'private' stamp: 'di 8/15/97 09:55'! hasLiteralSuchThat: litBlock "Answer true if litBlock returns true for any literal in this array, even if imbedded in further array structure. This method is only intended for private use by CompiledMethod hasLiteralSuchThat:" | lit | 1 to: self size do: [:index | lit _ self at: index. (litBlock value: lit) ifTrue: [^ true]. (lit class == Array and: [lit hasLiteralSuchThat: litBlock]) ifTrue: [^ true]]. ^false! ! !Array methodsFor: 'private'! replaceFrom: start to: stop with: replacement startingAt: repStart "Primitive. This destructively replaces elements from start to stop in the receiver starting at index, repStart, in the collection, replacement. Answer the receiver. Range checks are performed in the primitive only. Optional. See Object documentation whatIsAPrimitive." super replaceFrom: start to: stop with: replacement startingAt: repStart! ! ArrayedCollection subclass: #Array2D instanceVariableNames: 'width contents ' classVariableNames: '' poolDictionaries: '' category: 'Collections-Arrayed'! !Array2D methodsFor: 'access'! at: i at: j "return the element" (i < 1) | (i > width) ifTrue: [ ^ self error: 'first index out of bounds']. "second index bounds check is automatic, since contents array will get a bounds error." ^ contents at: (j - 1) * width + i! ! !Array2D methodsFor: 'access'! at: i at: j add: value "add value to the element" | index | (i < 1) | (i > width) ifTrue: [ ^ self error: 'first index out of bounds']. "second index bounds check is automatic, since contents array will get a bounds error." index _ (j - 1) * width + i. ^ contents at: index put: (contents at: index) + value! ! !Array2D methodsFor: 'access'! at: i at: j put: value "return the element" (i < 1) | (i > width) ifTrue: [ ^ self error: 'first index out of bounds']. "second index bounds check is automatic, since contents array will get a bounds error." ^ contents at: (j - 1) * width + i put: value! ! !Array2D methodsFor: 'access'! atAllPut: value "Initialize" contents atAllPut: value! ! !Array2D methodsFor: 'access'! atCol: i "Fetch a whole column. 6/20/96 tk" | ans | ans _ contents class new: self height. 1 to: self height do: [:ind | ans at: ind put: (self at: i at: ind)]. ^ ans! ! !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 "Fetch a whole row. 6/20/96 tk" ^ contents copyFrom: (j - 1) * width + 1 to: (j) * width! ! !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].! ! !Array2D methodsFor: 'access'! do: aBlock "Iterate with X varying most quickly. 6/20/96 tk" ^ contents do: aBlock! ! !Array2D methodsFor: 'access'! extent ^ width @ self height! ! !Array2D methodsFor: 'access'! extent: extent fromArray: anArray "Load this 2-D array up from a 1-D array. X varies most quickly. 6/20/96 tk" extent x * extent y = anArray size ifFalse: [ ^ self error: 'dimensions don''t match']. width _ extent x. contents _ anArray.! ! !Array2D methodsFor: 'access'! height "second dimension" "no need to save it" ^ contents size // width! ! !Array2D methodsFor: 'access'! width "first dimension" ^ width! ! !Array2D methodsFor: 'access'! width: x height: y type: class "Set the number of elements in the first and second dimensions. class can be Array or String or ByteArray." contents == nil ifFalse: [self error: 'No runtime size change yet']. "later move all the elements to the new sized array" width _ x. contents _ class new: width*y.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Array2D class instanceVariableNames: ''! !Array2D class methodsFor: 'as yet unclassified'! new "Override ArrayedCollection. 6/20/96 tk" ^ self basicNew! ! !Array2D class methodsFor: 'as yet unclassified'! new: size "Use (self new width: x height: y type: Array) 6/20/96 tk" ^ self shouldNotImplement! ! SequenceableCollection subclass: #ArrayedCollection instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Collections-Abstract'! !ArrayedCollection commentStamp: 'di 5/22/1998 16:32' prior: 0! ArrayedCollection comment: 'I am an abstract collection of elements with a fixed range of integers (from 1 to n>=1) as external keys.'! !ArrayedCollection methodsFor: 'accessing'! size "Primitive. Answer the number of indexable fields in the receiver. This value is the same as the largest legal subscript. Primitive is specified here to override SequenceableCollection size. Essential. See Object documentation whatIsAPrimitive. " ^self basicSize! ! !ArrayedCollection methodsFor: 'adding'! add: newObject self shouldNotImplement! ! !ArrayedCollection methodsFor: 'printing'! storeOn: aStream aStream nextPutAll: '(('. aStream nextPutAll: self class name. aStream nextPutAll: ' new: '. aStream store: self size. aStream nextPut: $). (self storeElementsFrom: 1 to: self size on: aStream) ifFalse: [aStream nextPutAll: '; yourself']. aStream nextPut: $)! ! !ArrayedCollection methodsFor: 'private'! defaultElement ^nil! ! !ArrayedCollection methodsFor: 'private'! fill: numElements fromStack: aContext "Fill me with numElements elements, popped in reverse order from the stack of aContext. Do not call directly: this is called indirectly by {1. 2. 3} constructs." aContext pop: numElements toIndexable: self! ! !ArrayedCollection methodsFor: 'private'! storeElementsFrom: firstIndex to: lastIndex on: aStream | noneYet defaultElement arrayElement | noneYet _ true. defaultElement _ self defaultElement. firstIndex to: lastIndex do: [:index | arrayElement _ self at: index. arrayElement = defaultElement ifFalse: [noneYet ifTrue: [noneYet _ false] ifFalse: [aStream nextPut: $;]. aStream nextPutAll: ' at: '. aStream store: index. aStream nextPutAll: ' put: '. aStream store: arrayElement]]. ^noneYet! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ArrayedCollection class instanceVariableNames: ''! !ArrayedCollection class methodsFor: 'instance creation'! fromBraceStack: itsSize "Answer an instance of me with itsSize elements, popped in reverse order from the stack of thisContext sender. Do not call directly: this is called by {1. 2. 3} constructs." ^ (self new: itsSize) fill: itsSize fromStack: thisContext sender! ! !ArrayedCollection class methodsFor: 'instance creation'! new "Answer a new instance of me, with size = 0." ^self new: 0! ! !ArrayedCollection class methodsFor: 'instance creation'! new: size withAll: value "Answer an instance of me, with number of elements equal to size, each of which refers to the argument, value." ^(self new: size) atAllPut: value! ! !ArrayedCollection class methodsFor: 'instance creation'! newFrom: aCollection "Answer an instance of me containing the same elements as aCollection." | newArray | newArray _ self new: aCollection size. 1 to: aCollection size do: [:i | newArray at: i put: (aCollection at: i)]. ^ newArray " Array newFrom: {1. 2. 3} {1. 2. 3} as: Array {1. 2. 3} as: ByteArray {$c. $h. $r} as: String {$c. $h. $r} as: Text "! ! !ArrayedCollection class methodsFor: 'instance creation'! with: anObject "Answer a new instance of me, containing only anObject." | newCollection | newCollection _ self new: 1. newCollection at: 1 put: anObject. ^newCollection! ! !ArrayedCollection class methodsFor: 'instance creation'! with: firstObject with: secondObject "Answer a new instance of me, containing firstObject and secondObject." | newCollection | newCollection _ self new: 2. newCollection at: 1 put: firstObject. newCollection at: 2 put: secondObject. ^newCollection! ! !ArrayedCollection class methodsFor: 'instance creation'! with: firstObject with: secondObject with: thirdObject "Answer a new instance of me, containing only the three arguments as elements." | newCollection | newCollection _ self new: 3. newCollection at: 1 put: firstObject. newCollection at: 2 put: secondObject. newCollection at: 3 put: thirdObject. ^newCollection! ! !ArrayedCollection class methodsFor: 'instance creation'! with: firstObject with: secondObject with: thirdObject with: fourthObject "Answer a new instance of me, containing only the three arguments as elements." | newCollection | newCollection _ self new: 4. newCollection at: 1 put: firstObject. newCollection at: 2 put: secondObject. newCollection at: 3 put: thirdObject. newCollection at: 4 put: fourthObject. ^newCollection! ! !ArrayedCollection class methodsFor: 'instance creation'! with: firstObject with: secondObject with: thirdObject with: fourthObject with: fifthObject "Answer a new instance of me, containing only the five arguments as elements." | newCollection | newCollection _ self new: 5. newCollection at: 1 put: firstObject. newCollection at: 2 put: secondObject. newCollection at: 3 put: thirdObject. newCollection at: 4 put: fourthObject. newCollection at: 5 put: fifthObject. ^newCollection! ! ParseNode subclass: #AssignmentNode instanceVariableNames: 'variable value ' classVariableNames: '' poolDictionaries: '' category: 'System-Compiler'! !AssignmentNode commentStamp: 'di 5/22/1998 16:32' prior: 0! AssignmentNode comment: 'I represent a (var_expr) construct.'! !AssignmentNode methodsFor: 'initialize-release'! toDoIncrement: var var = variable ifFalse: [^ nil]. (value isMemberOf: MessageNode) ifTrue: [^ value toDoIncrement: var] ifFalse: [^ nil]! ! !AssignmentNode methodsFor: 'initialize-release'! value ^ value! ! !AssignmentNode methodsFor: 'initialize-release'! variable: aVariable value: expression variable _ aVariable. value _ expression! ! !AssignmentNode methodsFor: 'initialize-release'! variable: aVariable value: expression from: encoder (aVariable isMemberOf: MessageNode) ifTrue: [^aVariable store: expression from: encoder]. variable _ aVariable. value _ expression! ! !AssignmentNode methodsFor: 'code generation'! emitForEffect: stack on: aStream value emitForValue: stack on: aStream. variable emitStorePop: stack on: aStream! ! !AssignmentNode methodsFor: 'code generation'! emitForValue: stack on: aStream value emitForValue: stack on: aStream. variable emitStore: stack on: aStream! ! !AssignmentNode methodsFor: 'code generation'! sizeForEffect: encoder ^(value sizeForValue: encoder) + (variable sizeForStorePop: encoder)! ! !AssignmentNode methodsFor: 'code generation'! sizeForValue: encoder ^(value sizeForValue: encoder) + (variable sizeForStore: encoder)! ! !AssignmentNode methodsFor: 'printing'! printOn: aStream indent: level variable printOn: aStream indent: level. aStream nextPutAll: ' _ '. value printOn: aStream indent: level + 2! ! !AssignmentNode methodsFor: 'printing'! printOn: aStream indent: level precedence: p p < 4 ifTrue: [aStream nextPutAll: '(']. self printOn: aStream indent: level. p < 4 ifTrue: [aStream nextPutAll: ')']! ! !AssignmentNode methodsFor: 'equation translation'! variable ^variable! ! !AssignmentNode methodsFor: 'C translation'! asTranslatorNode ^TAssignmentNode new setVariable: variable asTranslatorNode expression: value asTranslatorNode! ! TileMorph subclass: #AssignmentTileMorph instanceVariableNames: 'assignmentRoot assignmentSuffix dataType ' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Scripting-Tiles'! !AssignmentTileMorph methodsFor: 'all' stamp: 'sw 12/12/97 01:24'! arrowAction: delta | index aList | owner ifNil: [^ self]. operatorOrExpression ifNotNil: [aList _ #(: Incr: Decr: Mult:). index _ aList indexOf: assignmentSuffix asSymbol. index > 0 ifTrue: [self setAssignmentSuffix: (aList atWrap: index + delta). self acceptNewLiteral]]! ! !AssignmentTileMorph methodsFor: 'all' stamp: 'sw 5/2/1998 15:00'! computeOperatorOrExpression | aSuffix | operatorOrExpression _ (assignmentRoot, assignmentSuffix) asSymbol. aSuffix _ ScriptingSystem wordingForAssignmentSuffix: assignmentSuffix. operatorReadoutString _ assignmentRoot, ' ', aSuffix. self line1: operatorReadoutString. dataType == #number ifTrue: [self addArrows] ! ! !AssignmentTileMorph methodsFor: 'all' stamp: 'sw 11/17/97 14:36'! initialize super initialize. type _ #operator. assignmentSuffix _ ':'! ! !AssignmentTileMorph methodsFor: 'all' stamp: 'sw 5/2/1998 15:00'! setAssignmentSuffix: aString assignmentSuffix _ aString. self computeOperatorOrExpression. type _ #operator. self line1: (ScriptingSystem wordingForOperator: operatorOrExpression). self addArrows; updateLiteralLabel! ! !AssignmentTileMorph methodsFor: 'all' stamp: 'sw 2/16/98 01:12'! setRoot: aString dataType: aSymbol assignmentRoot _ aString. assignmentSuffix _ ':'. dataType _ aSymbol. self updateLiteralLabel! ! !AssignmentTileMorph methodsFor: 'all' stamp: 'sw 1/31/98 00:42'! storeCodeOn: aStream aStream nextPutAll: ' assign', (assignmentSuffix copyWithout: $:), 'Getter: #'. aStream nextPutAll: (Utilities getterSelectorFor: assignmentRoot). aStream nextPutAll: ' setter: #'. aStream nextPutAll: (Utilities setterSelectorFor: assignmentRoot). aStream nextPutAll: ' amt: '! ! !AssignmentTileMorph methodsFor: 'all' stamp: 'sw 1/31/98 00:42'! updateLiteralLabel self computeOperatorOrExpression. super updateLiteralLabel! ! LookupKey subclass: #Association instanceVariableNames: 'value ' classVariableNames: '' poolDictionaries: '' category: 'Collections-Support'! !Association commentStamp: 'di 5/22/1998 16:32' prior: 0! Association comment: 'I represent a pair of associated objects--a key and a value. My instances can serve as entries in a dictionary.'! !Association methodsFor: 'accessing'! key: aKey value: anObject "Store the arguments as the variables of the receiver." key _ aKey. value _ anObject! ! !Association methodsFor: 'accessing'! value "Answer the value of the receiver." ^value! ! !Association methodsFor: 'accessing'! value: anObject "Store the argument, anObject, as the value of the receiver." value _ anObject! ! !Association methodsFor: 'printing'! printOn: aStream super printOn: aStream. aStream nextPutAll: '->'. value printOn: aStream! ! !Association methodsFor: 'printing'! storeOn: aStream "Store in the format (key->value)" aStream nextPut: $(. key storeOn: aStream. aStream nextPutAll: '->'. value storeOn: aStream. aStream nextPut: $)! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Association class instanceVariableNames: ''! !Association class methodsFor: 'instance creation'! key: newKey value: newValue "Answer an instance of me with the arguments as the key and value of the association." ^(super key: newKey) value: newValue! ! EllipseMorph subclass: #AtomMorph instanceVariableNames: 'velocity ' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Demo'! !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 instanceVariableNames: ''! !AtomMorph class methodsFor: 'all' stamp: 'di 6/22/97 09:07'! includeInNewMorphMenu "Not to be instantiated from the menu" ^ false! ! EmbeddedServerAction subclass: #AuthorizedServerAction instanceVariableNames: 'authorizer ' classVariableNames: '' poolDictionaries: '' category: 'PluggableWebServer'! !AuthorizedServerAction commentStamp: 'di 5/22/1998 16:32' prior: 0! An EmbeddedServerAction that also has an Authorizer to verify username and password.! !AuthorizedServerAction methodsFor: 'URL processing' stamp: 'mjg 11/17/97 11:20'! authorizer ^authorizer! ! !AuthorizedServerAction methodsFor: 'URL processing' stamp: 'mjg 11/17/97 11:20'! authorizer: anAuthorizer authorizer _ anAuthorizer ! ! !AuthorizedServerAction methodsFor: 'URL processing' stamp: 'mjg 11/17/97 13:09'! checkAuthorization: request ^authorizer user: request userID. ! ! !AuthorizedServerAction methodsFor: 'URL processing' stamp: 'tk 5/21/1998 16:46'! mapName: nameString password: pwdString to: aPerson "Insert/remove the username:password combination into/from the users Dictionary. *** Use this method to add or delete users!! If you ask for the authorizer and talk to it, the change will not be recorded on the disk!! *** We use encoding per RFC1421." authorizer mapName: nameString password: pwdString to: aPerson. self authorizer: authorizer. "force it to be written to the disk" "*** Authorizer not saved to disk yet for this class ***"! ! SwikiAction subclass: #AuthorizedSwikiAction instanceVariableNames: 'authorizer ' classVariableNames: '' poolDictionaries: '' category: 'PluggableWebServer'! !AuthorizedSwikiAction commentStamp: 'di 5/22/1998 16:32' prior: 0! A Server with a login name and password for the entire Swiki area. Can be multiple users each with a different password. Each sees and can modify the whole Swiki area. To restart an existing Authorized Swiki: AuthorizedSwikiAction new restore: 'SWSecure'. The front page URL is: http://serverMachine:80/SWSecure.1 To make a completely new one: | a s | a := Authorizer new. a realm: 'SwikiArea'. a mapName: 'viki' password: 'hard2guess' to: 'viki'. AuthorizedSwikiAction setUp: 'SWSecure'. s := AuthorizedSwikiAction new restore: 'SWSecure'. s authorizer: a. ! !AuthorizedSwikiAction methodsFor: 'URL processing' stamp: 'rp 4/29/98 16:57'! authorizer ^authorizer! ! !AuthorizedSwikiAction methodsFor: 'URL processing' stamp: 'tk 5/22/1998 07:46'! authorizer: anAuthorizer "Smash all old name/password pairs with this new set. Overwrites the file on the disk" | fName refStream | authorizer _ anAuthorizer. fName _ ServerAction serverDirectory, name, (ServerAction pathSeparator), 'authorizer'. refStream _ SmartRefStream fileNamed: fName. refStream nextPut: authorizer; close. ! ! !AuthorizedSwikiAction methodsFor: 'URL processing' stamp: 'rp 4/29/98 16:58'! checkAuthorization: request ^authorizer user: request userID. ! ! !AuthorizedSwikiAction methodsFor: 'URL processing' stamp: 'tk 5/21/1998 16:30'! mapName: nameString password: pwdString to: aPerson "Insert/remove the username:password combination into/from the users Dictionary. *** Use this method to add or delete users!! If you ask for the authorizer and talk to it, the change will not be recorded on the disk!! *** We use encoding per RFC1421." authorizer mapName: nameString password: pwdString to: aPerson. self authorizer: authorizer. "force it to be written to the disk"! ! !AuthorizedSwikiAction methodsFor: 'URL processing' stamp: 'rp 4/29/98 17:02'! process: request self checkAuthorization: request. ^(super process: request).! ! !AuthorizedSwikiAction methodsFor: 'URL processing' stamp: 'tk 5/22/1998 10:21'! restore: nameOfSwiki "Read all files in the directory 'nameOfSwiki'. Reconstruct the url map." | fName | super restore: nameOfSwiki. fName _ ServerAction serverDirectory, name, (ServerAction pathSeparator), 'authorizer'. authorizer _ (FileStream oldFileNamed: fName) fileInObjectAndCode. ! ! Object subclass: #Authorizer instanceVariableNames: 'users realm ' classVariableNames: '' poolDictionaries: '' category: 'PluggableWebServer'! !Authorizer commentStamp: 'di 5/22/1998 16:32' prior: 0! The Authorizer does user authorization checking. Each instance of authorizer keeps track of the realm that it is authorizing for, and the table of authorized users. An authorizer can be asked to return the user name/symbol associated with a userID (which concatenates the username and password from the HTTP request) with the user: method. ! !Authorizer methodsFor: 'realms' stamp: 'mjg 11/3/97 12:33'! realm ^realm! ! !Authorizer methodsFor: 'realms' stamp: 'mjg 11/3/97 12:33'! realm: aString realm := aString ! ! !Authorizer methodsFor: 'authentication' stamp: 'mjg 11/3/97 13:01'! encode: nameString password: pwdString "Encode per RFC1421 of the username:password combination." | clear code clearSize idx map | clear := (nameString, ':', pwdString) asByteArray. clearSize := clear size. [ clear size \\ 3 ~= 0 ] whileTrue: [ clear := clear, #(0) ]. idx := 1. map := 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/'. code := WriteStream on: ''. [ idx < clear size ] whileTrue: [ code nextPut: (map at: (clear at: idx) // 4 + 1); nextPut: (map at: (clear at: idx) \\ 4 * 16 + ((clear at: idx + 1) // 16) + 1); nextPut: (map at: (clear at: idx + 1) \\ 16 * 4 + ((clear at: idx + 2) // 64) + 1); nextPut: (map at: (clear at: idx + 2) \\ 64 + 1). idx := idx + 3 ]. code := code contents. idx := code size. clear size - clearSize timesRepeat: [ code at: idx put: $=. idx := idx - 1]. ^code! ! !Authorizer methodsFor: 'authentication' stamp: 'mjg 11/3/97 12:31'! mapFrom: aKey to: aPerson "Establish a mapping from a RFC 1421 key to a user." users isNil ifTrue: [ users := Dictionary new ]. aPerson isNil ifTrue: [ users removeKey: aKey ] ifFalse: [ users removeKey: (users keyAtValue: aPerson ifAbsent: []) ifAbsent: []. users at: aKey put: aPerson ] ! ! !Authorizer methodsFor: 'authentication' stamp: 'tk 5/21/1998 16:32'! mapName: nameString password: pwdString to: aPerson "Insert/remove the encoding per RFC1421 of the username:password combination into/from the UserMap. DO NOT call this directly, use mapName:password:to: in your ServerAction class. Only it knows how to record the change on the disk!!" self mapFrom: (self encode: nameString password: pwdString) to: aPerson ! ! !Authorizer methodsFor: 'authentication' stamp: 'mjg 11/17/97 13:07'! user: userId "Return the requesting user." ^users at: userId ifAbsent: [ self error: (PWS unauthorizedFor: realm) ]! ! Morph subclass: #BackgroundMorph instanceVariableNames: 'image offset delta running ' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Widgets'! !BackgroundMorph commentStamp: 'di 5/22/1998 16:32' prior: 0! 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: 'di 11/4/97 09:01'! addCustomMenuItems: aCustomMenu hand: aHandMorph super 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 instanceVariableNames: ''! !BackgroundMorph class methodsFor: 'all'! test ^ self new image: Form fromUser! ! Collection subclass: #Bag instanceVariableNames: 'contents ' classVariableNames: '' poolDictionaries: '' category: 'Collections-Unordered'! !Bag commentStamp: 'di 5/22/1998 16:32' prior: 0! Bag comment: 'I represent an unordered collection of possibly duplicate elements. I store these elements in a dictionary, tallying up occurrences of equal objects. Because I store an occurrence only once, my clients should beware that objects they store will not necessarily be retrieved such that == is true. If the client cares, a subclass of me should be created.'! !Bag methodsFor: 'accessing'! at: index self errorNotKeyed! ! !Bag methodsFor: 'accessing'! at: index put: anObject self errorNotKeyed! ! !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]! ! !Bag methodsFor: 'accessing'! size | tally | tally _ 0. contents do: [:each | tally _ tally + each]. ^tally! ! !Bag methodsFor: 'accessing'! sortedCounts "Answer with a collection of counts with elements, sorted by decreasing count." | counts | counts _ SortedCollection sortBlock: [:x :y | x >= y]. contents associationsDo: [:assn | counts add: (Association key: assn value value: assn key)]. ^counts! ! !Bag methodsFor: 'accessing'! sortedElements "Answer with a collection of elements with counts, sorted by element." | elements | elements _ SortedCollection new. contents associationsDo: [:assn | elements add: assn]. ^elements! ! !Bag methodsFor: 'testing'! includes: anObject "Refer to the comment in Collection|includes:." ^contents includesKey: anObject! ! !Bag methodsFor: 'testing'! occurrencesOf: anObject "Refer to the comment in Collection|occurrencesOf:." (self includes: anObject) ifTrue: [^contents at: anObject] ifFalse: [^0]! ! !Bag methodsFor: 'adding'! add: newObject "Refer to the comment in Collection|add:." ^self add: newObject withOccurrences: 1! ! !Bag methodsFor: 'adding'! add: newObject withOccurrences: anInteger "Add the element newObject to the receiver. Do so as though the element were added anInteger number of times. Answer newObject." (self includes: newObject) ifTrue: [contents at: newObject put: anInteger + (contents at: newObject)] ifFalse: [contents at: newObject put: anInteger]. ^newObject! ! !Bag methodsFor: 'removing'! remove: oldObject ifAbsent: exceptionBlock "Refer to the comment in Collection|remove:ifAbsent:." | count | (self includes: oldObject) ifTrue: [(count _ contents at: oldObject) = 1 ifTrue: [contents removeKey: oldObject] ifFalse: [contents at: oldObject put: count - 1]] ifFalse: [^exceptionBlock value]. ^oldObject! ! !Bag methodsFor: 'enumerating' stamp: 'SqR 11/4/97 19:58'! asSet "Answer a set with the elements of the receiver" ^contents keys! ! !Bag methodsFor: 'enumerating'! do: aBlock "Refer to the comment in Collection|do:." contents associationsDo: [:assoc | assoc value timesRepeat: [aBlock value: assoc key]]! ! !Bag methodsFor: 'private'! setDictionary contents _ Dictionary new! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Bag class instanceVariableNames: ''! !Bag class methodsFor: 'instance creation'! new ^super new setDictionary! ! !Bag class methodsFor: 'instance creation'! newFrom: aCollection "Answer an instance of me containing the same elements as aCollection." | newCollection | newCollection _ self new. newCollection addAll: aCollection. ^newCollection " Bag newFrom: {1. 2. 3} {1. 2. 3} as: Bag "! ! CurveMorph subclass: #BalloonMorph instanceVariableNames: 'target offsetFromTarget ' classVariableNames: 'BalloonFont ' poolDictionaries: '' category: 'Morphic-Widgets'! !BalloonMorph commentStamp: 'di 5/22/1998 16:32' prior: 0! BalloonMorph comment: 'A balloon with text used for the display of explanatory information. Balloon help is integrated into Morphic as follows: If a Morph has the property #balloonText, then it will respond to #showBalloon by adding a text balloon to the world, and to #deleteBalloon by removing the balloon. Moreover, if mouseOverEnabled is true (see class msg), then the Hand will arrange to cause display of the balloon after the mouse has lingered over the morph for a while, and removal of the balloon when the mouse leaves the bounds of that morph. In any case, the Hand will attempt to remove any such balloons before handling mouseDown events, or displaying other balloons.'! !BalloonMorph methodsFor: 'all' stamp: 'di 9/17/97 19:26'! setTarget: aMorph target _ aMorph. offsetFromTarget _ self position - target position! ! !BalloonMorph methodsFor: 'all' stamp: 'di 9/17/97 19:27'! step self position: target position + offsetFromTarget! ! !BalloonMorph methodsFor: 'all' stamp: 'di 9/18/97 10:10'! stepTime ^ 0 "every cycle"! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! BalloonMorph class instanceVariableNames: ''! !BalloonMorph class methodsFor: 'all' stamp: 'di 10/20/97 20:10'! chooseBalloonFont | sizes reply | sizes _ #(9 10 12 14). reply _ (SelectionMenu labelList: (sizes collect: [:s | s printString]) selections: sizes) startUp. reply ifNotNil: [BalloonFont _ (TextStyle named: #ComicPlain) fontAt: (sizes indexOf: reply)]! ! !BalloonMorph class methodsFor: 'all' stamp: 'jm 5/20/1998 20:16'! string: str for: morph corner: cornerName "Make up and return a balloon for morph. Find the quadrant that clips the text the least, using cornerName as a tie-breaker. tk 9/12/97" | txt tm corners p1 p2 vertices c r maxArea aa verts mp dir mbc pref rectCorner morphPoint | BalloonFont ifNil: [txt _ str] ifNotNil: [txt _ Text string: str attribute: (TextFontReference toFont: BalloonFont)]. tm _ (TextMorph new contents: txt) centered. "Construct vertices for a balloon below and to left of anchor" corners _ tm bounds corners atAll: #(1 4 3 2). p1 _ (corners at: 1) + ((0 - tm width//3)@0). p2 _ (corners at: 1) + ((0 - tm width//6)@(tm height//2)). vertices _ (Array with: p1 with: p2) , corners. r _ p1 rect: (corners at: 3). corners _ #(bottomRight bottomLeft topLeft topRight). pref _ corners indexOf: cornerName. c _ tm center. maxArea _ 0. (0 to: 3) do: [:i | "Try four rel locations of the balloon for greatest unclipped area" rectCorner _ corners atWrap: i+pref+2. morphPoint _ (#(bottomRight bottomLeft) includes: rectCorner) ifTrue: [#topCenter] ifFalse: [#bottomCenter]. aa _ ((r align: (r perform: rectCorner) with: (mbc _ morph fullBoundsInWorld perform: morphPoint)) intersect: (0@0 extent: morph world viewBox extent)) area. aa > maxArea ifTrue: [verts _ vertices. maxArea _ aa. mp _ mbc]. dir _ (i+pref) odd ifTrue: [#horizontal] ifFalse: [#vertical]. vertices _ vertices collect: [:p | p flipBy: dir centerAt: c]]. ^ self new color: (Color r: 1.0 g: 1.0 b: 0.6); setBorderWidth: 1 borderColor: Color black; setVertices: verts; addMorph: tm; align: verts first with: mp; setTarget: morph! ! Object subclass: #Base64MimeConverter instanceVariableNames: 'dataStream mimeStream data ' classVariableNames: 'FromCharTable ToCharTable ' poolDictionaries: '' category: 'Collections-Streams'! !Base64MimeConverter commentStamp: 'di 5/22/1998 16:32' prior: 0! This class encodes and decodes data in Base64 format. This is MIME encoding. We translate a whole stream at once, taking a Stream as input and giving one as output. Returns a whole stream for the caller to use. 0 A 17 R 34 i 51 z 1 B 18 S 35 j 52 0 2 C 19 T 36 k 53 1 3 D 20 U 37 l 54 2 4 E 21 V 38 m 55 3 5 F 22 W 39 n 56 4 6 G 23 X 40 o 57 5 7 H 24 Y 41 p 58 6 8 I 25 Z 42 q 59 7 9 J 26 a 43 r 60 8 10 K 27 b 44 s 61 9 11 L 28 c 45 t 62 + 12 M 29 d 46 u 63 / 13 N 30 e 47 v 14 O 31 f 48 w (pad) = 15 P 32 g 49 x 16 Q 33 h 50 y Outbound: bytes are broken into 6 bit chunks, and the 0-63 value is converted to a character. 3 data bytes go into 4 characters. Inbound: Characters are translated in to 0-63 values and shifted into 8 bit bytes. (See: N. Borenstein, Bellcore, N. Freed, Innosoft, Network Working Group, Request for Comments: RFC 1521, September 1993, MIME (Multipurpose Internet Mail Extensions) Part One: Mechanisms for Specifying and Describing the Format of Internet Message Bodies. Sec 6.2) By Ted Kaehler, based on Tim Olson's Base64Filter.! !Base64MimeConverter methodsFor: 'accessing' stamp: 'tk 12/9/97 13:55'! dataStream ^dataStream! ! !Base64MimeConverter methodsFor: 'accessing' stamp: 'tk 12/9/97 13:51'! dataStream: anObject dataStream _ anObject! ! !Base64MimeConverter methodsFor: 'accessing' stamp: 'tk 12/9/97 13:53'! mimeStream ^mimeStream! ! !Base64MimeConverter methodsFor: 'accessing' stamp: 'tk 12/9/97 13:51'! mimeStream: anObject mimeStream _ anObject! ! !Base64MimeConverter methodsFor: 'conversion' stamp: 'tk 12/9/97 13:34'! mimeDecode "Convert a stream in base 64 with only a-z,A-Z,0-9,+,/ to a full byte stream of characters. Reutrn a whole stream for the user to read." | nibA nibB nibC nibD | [mimeStream atEnd] whileFalse: [ (nibA _ self nextValue) ifNil: [^ dataStream]. (nibB _ self nextValue) ifNil: [^ dataStream]. dataStream nextPut: ((nibA bitShift: 2) + (nibB bitShift: -4)) asCharacter. nibB _ nibB bitAnd: 16rF. (nibC _ self nextValue) ifNil: [^ dataStream]. dataStream nextPut: ((nibB bitShift: 4) + (nibC bitShift: -2)) asCharacter. nibC _ nibC bitAnd: 16r3. (nibD _ self nextValue) ifNil: [^ dataStream]. dataStream nextPut: ((nibC bitShift: 6) + nibD) asCharacter. ]. ^ dataStream! ! !Base64MimeConverter methodsFor: 'conversion' stamp: 'tk 12/9/97 13:39'! mimeDecodeToByteArray "Convert a stream in base 64 with only a-z,A-Z,0-9,+,/ to a full ByteArray of 0-255 values. Reutrn a whole stream for the user to read." | nibA nibB nibC nibD | [mimeStream atEnd] whileFalse: [ (nibA _ self nextValue) ifNil: [^ dataStream]. (nibB _ self nextValue) ifNil: [^ dataStream]. dataStream nextPut: ((nibA bitShift: 2) + (nibB bitShift: -4)). nibB _ nibB bitAnd: 16rF. (nibC _ self nextValue) ifNil: [^ dataStream]. dataStream nextPut: ((nibB bitShift: 4) + (nibC bitShift: -2)). nibC _ nibC bitAnd: 16r3. (nibD _ self nextValue) ifNil: [^ dataStream]. dataStream nextPut: ((nibC bitShift: 6) + nibD). ]. ^ dataStream! ! !Base64MimeConverter methodsFor: 'conversion' stamp: 'tk 12/9/97 12:57'! mimeEncode "Convert from data to 6 bit characters." | phase1 phase2 raw nib | phase1 _ phase2 _ false. [dataStream atEnd] whileFalse: [ data _ raw _ dataStream next asInteger. nib _ (data bitAnd: 16rFC) bitShift: -2. mimeStream nextPut: (ToCharTable at: nib+1). (raw _ dataStream next) ifNil: [raw _ 0. phase1 _ true]. data _ ((data bitAnd: 3) bitShift: 8) + raw asInteger. nib _ (data bitAnd: 16r3F0) bitShift: -4. mimeStream nextPut: (ToCharTable at: nib+1). (raw _ dataStream next) ifNil: [raw _ 0. phase2 _ true]. data _ ((data bitAnd: 16rF) bitShift: 8) + (raw asInteger). nib _ (data bitAnd: 16rFC0) bitShift: -6. mimeStream nextPut: (ToCharTable at: nib+1). nib _ (data bitAnd: 16r3F). mimeStream nextPut: (ToCharTable at: nib+1)]. phase1 ifTrue: [mimeStream skip: -2; nextPut: $=; nextPut: $=. ^ mimeStream]. phase2 ifTrue: [mimeStream skip: -1; nextPut: $=. ^ mimeStream]. ! ! !Base64MimeConverter methodsFor: 'conversion' stamp: 'tk 12/9/97 13:21'! nextValue "The next six bits of data char from the mimeStream, or nil. Skip all other chars" | raw num | [raw _ mimeStream next. raw ifNil: [^ nil]. "end of stream" raw == $= ifTrue: [^ nil]. num _ FromCharTable at: raw asciiValue + 1. num ifNotNil: [^ num]. "else ignore space, return, tab, ..." true] whileTrue.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Base64MimeConverter class instanceVariableNames: ''! !Base64MimeConverter class methodsFor: 'as yet unclassified' stamp: 'tk 12/9/97 14:29'! example "Base64MimeConverter example" | ss bb | ss _ ReadWriteStream on: (String new: 10). ss nextPutAll: 'Hi There!!'. bb _ Base64MimeConverter mimeEncode: ss. "bb contents 'SGkgVGhlcmUh'" ^ (Base64MimeConverter mimeDecodeToChars: bb) contents ! ! !Base64MimeConverter class methodsFor: 'as yet unclassified' stamp: 'tk 12/9/97 13:53'! initialize FromCharTable _ Array new: 256. "nils" ToCharTable _ Array new: 64. ($A asciiValue to: $Z asciiValue) doWithIndex: [:val :ind | FromCharTable at: val+1 put: ind-1. ToCharTable at: ind put: val asCharacter]. ($a asciiValue to: $z asciiValue) doWithIndex: [:val :ind | FromCharTable at: val+1 put: ind+25. ToCharTable at: ind+26 put: val asCharacter]. ($0 asciiValue to: $9 asciiValue) doWithIndex: [:val :ind | FromCharTable at: val+1 put: ind+25+26. ToCharTable at: ind+26+26 put: val asCharacter]. FromCharTable at: $+ asciiValue + 1 put: 62. ToCharTable at: 63 put: $+. FromCharTable at: $/ asciiValue + 1 put: 63. ToCharTable at: 64 put: $/. ! ! !Base64MimeConverter class methodsFor: 'as yet unclassified' stamp: 'tk 12/12/97 11:41'! mimeDecodeToBytes: aStream "Return a RWBinaryOrTextStream of the original ByteArray. aStream has only 65 innocuous character values. aStream is not binary. (See class comment). 4 bytes in aStream goes to 3 bytes in output." | me | aStream position: 0. me _ self new mimeStream: aStream. me dataStream: (RWBinaryOrTextStream on: (ByteArray new: aStream size * 3 // 4)). me mimeDecodeToByteArray. me dataStream position: 0. ^ me dataStream! ! !Base64MimeConverter class methodsFor: 'as yet unclassified' stamp: 'tk 12/9/97 13:01'! mimeDecodeToChars: aStream "Return a ReadWriteStream of the original String. aStream has only 65 innocuous character values. It is not binary. (See class comment). 4 bytes in aStream goes to 3 bytes in output." | me | aStream position: 0. me _ self new mimeStream: aStream. me dataStream: (ReadWriteStream on: (String new: aStream size * 3 // 4)). me mimeDecode. me dataStream position: 0. ^ me dataStream! ! !Base64MimeConverter class methodsFor: 'as yet unclassified' stamp: 'tk 12/9/97 12:28'! mimeEncode: aStream "Return a ReadWriteStream of characters. The data of aStream is encoded as 65 innocuous characters. (See class comment). 3 bytes in aStream goes to 4 bytes in output." | me | aStream position: 0. me _ self new dataStream: aStream. me mimeStream: (ReadWriteStream on: (String new: aStream size + 20 * 4 // 3)). me mimeEncode. me mimeStream position: 0. ^ me mimeStream! ! Object subclass: #Behavior instanceVariableNames: 'superclass methodDict format subclasses ' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Classes'! !Behavior commentStamp: 'di 5/22/1998 16:32' prior: 0! Behavior comment: 'My instances describe the behavior of other objects. I provide the minimum state necessary for compiling methods, and creating and running instances. Most objects are created as instances of the more fully supported subclass, Class, but I am a good starting point for providing instance-specific behavior (as in Metaclass).'! !Behavior methodsFor: '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'! compilerClass "Answer a compiler class appropriate for source methods of this class." ^Compiler! ! !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 it Remove, then browse senders Don''t remove, but show me those senders Forget 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: 'accessing'! decompilerClass "Answer a decompiler class appropriate for compiled methods of this class." ^Decompiler! ! !Behavior methodsFor: 'accessing'! evaluatorClass "Answer an evaluator class appropriate for evaluating expressions in the context of this class." ^Compiler! ! !Behavior methodsFor: 'accessing'! format "Answer an Integer that encodes the kinds and numbers of variables of instances of the receiver." ^format! ! !Behavior methodsFor: 'accessing'! parserClass "Answer a parser class to use for parsing method headers." ^self compilerClass parserClass! ! !Behavior methodsFor: 'accessing'! sourceCodeTemplate "Answer an expression to be edited and evaluated in order to define methods in this class." ^'message selector and argument names "comment stating purpose of message" | temporary variable names | statements'! ! !Behavior methodsFor: 'accessing'! subclassDefinerClass "Answer an evaluator class appropriate for evaluating definitions of new subclasses of this class." ^Compiler! ! !Behavior methodsFor: 'testing'! instSize "Answer the number of named instance variables (as opposed to indexed variables) of the receiver." self flag: #instSizeChange. "Smalltalk browseAllCallsOn: #instSizeChange" " NOTE: This code supports the backward-compatible extension to 8 bits of instSize. When we revise the image format, it should become... ^ ((format bitShift: -1) bitAnd: 16rFF) - 1 Note also that every other method in this category will require 2 bits more of right shift after the change. " ^ ((format bitShift: -10) bitAnd: 16rC0) + ((format bitShift: -1) bitAnd: 16r3F) - 1! ! !Behavior methodsFor: 'testing'! instSpec ^ (format bitShift: -7) bitAnd: 16rF! ! !Behavior methodsFor: 'testing'! isBits "Answer whether the receiver contains just bits (not pointers)." ^ self instSpec >= 6! ! !Behavior methodsFor: 'testing'! isBytes "Answer whether the receiver has 8-bit instance variables." ^ self instSpec >= 8! ! !Behavior methodsFor: 'testing'! isFixed "Answer whether the receiver does not have a variable (indexable) part." ^self isVariable not! ! !Behavior methodsFor: 'testing'! isPointers "Answer whether the receiver contains just pointers (not bits)." ^self isBits not! ! !Behavior methodsFor: 'testing'! isVariable "Answer whether the receiver has indexable variables." ^ self instSpec >= 2! ! !Behavior methodsFor: 'testing'! isWords "Answer whether the receiver has 16-bit instance variables." ^self isBytes not! ! !Behavior methodsFor: 'copying'! copy "Answer a copy of the receiver without a list of subclasses." | myCopy savedSubclasses | savedSubclasses _ subclasses. subclasses _ nil. myCopy _ self shallowCopy. subclasses _ savedSubclasses. ^myCopy methodDictionary: methodDict copy! ! !Behavior methodsFor: 'printing' stamp: 'sw 2/16/98 01:30'! defaultNameStemForInstances "Answer a basis for names of default instances of the receiver" ^ self name! ! !Behavior methodsFor: 'printing'! literalScannedAs: scannedLiteral notifying: requestor "Postprocesses a literal scanned by Scanner scanToken (esp. xLitQuote). If scannedLiteral is not an association, answer it. Else, if it is of the form: nil->#NameOfMetaclass answer nil->theMetaclass, if any has that name, else report an error. Else, if it is of the form: #NameOfGlobalVariable->anythiEng answer the global, class, or pool association with that nameE, if any, else add it to Undeclared a answer the new Association." | key value | (scannedLiteral isMemberOf: Association) ifFalse: [^ scannedLiteral]. key _ scannedLiteral key. value _ scannedLiteral value. key isNil ifTrue: "###" [self scopeHas: value ifTrue: [:assoc | (assoc value isKindOf: Behavior) ifTrue: [^ nil->assoc value class]]. requestor notify: 'No such metaclass'. ^false]. (key isMemberOf: Symbol) ifTrue: "##" [(self scopeHas: key ifTrue: [:assoc | ^assoc]) ifFalse: [Undeclared at: key put: nil. ^ Undeclared associationAt: key]]. requestor notify: '## must be followed by a non-local variable name'. ^false " Form literalScannedAs: 14 notifying: nil 14 Form literalScannedAs: #OneBitForm notiEfying: nil OneBitForm Form literalScannedAs: ##OneBitForm notifying: nil OneBitForm->a Form Form literalScannedAs: ##Form notifying: nil Form->Form Form literalScannedAs: ###Form notifying: nil nilE->Form class "! ! !Behavior methodsFor: 'printing'! printHierarchy "Answer a description containing the names and instance variable names of all of the subclasses and superclasses of the receiver." | aStream index | index _ 0. aStream _ WriteStream on: (String new: 16). self allSuperclasses reverseDo: [:aClass | aStream crtab: index. index _ index + 1. aStream nextPutAll: aClass name. aStream space. aStream print: aClass instVarNames]. aStream cr. self printSubclassesOn: aStream level: index. ^aStream contents! ! !Behavior methodsFor: 'printing'! printOn: aStream "Refer to the comment in Object|printOn:." aStream nextPutAll: 'a descendent of '. superclass printOn: aStream! ! !Behavior methodsFor: 'printing'! storeLiteral: aCodeLiteral on: aStream "Store aCodeLiteral on aStream, changing an Association to ##GlobalName or ###MetaclassSoleInstanceName format if appropriate" | key value | (aCodeLiteral isMemberOf: Association) ifFalse: [aCodeLiteral storeOn: aStream. ^self]. key _ aCodeLiteral key. (key isNil and: [(value _ aCodeLiteral value) isMemberOf: Metaclass]) ifTrue: [aStream nextPutAll: '###'; nextPutAll: value soleInstance name. ^self]. ((key isMemberOf: Symbol) and: [self scopeHas: key ifTrue: [:ignore]]) ifTrue: [aStream nextPutAll: '##'; nextPutAll: key. ^self]. aCodeLiteral storeOn: aStream! ! !Behavior methodsFor: 'creating class hierarchy'! addSubclass: aSubclass "Make the argument, aSubclass, be one of the subclasses of the receiver. Create an error notification if the argument's superclass is not the receiver." aSubclass superclass ~~ self ifTrue: [self error: aSubclass name , ' is not my subclass'] ifFalse: [subclasses == nil ifTrue: [subclasses _ Set with: aSubclass] ifFalse: [subclasses add: aSubclass]]! ! !Behavior methodsFor: 'creating class hierarchy' stamp: 'tk 3/19/98 10:16'! removeSubclass: aSubclass "If the argument, aSubclass, is one of the receiver's subclasses, remove it." subclasses == nil ifFalse: [subclasses remove: aSubclass ifAbsent: []. subclasses isEmpty ifTrue: [subclasses _ nil]]. Object flushCache. ! ! !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' stamp: 'di 12/26/97 11:04'! addSelector: selector withMethod: compiledMethod "Add the message selector with the corresponding compiled method to the receiver's method dictionary." methodDict at: selector put: compiledMethod. selector flushCache! ! !Behavior methodsFor: 'creating method dictionary'! compile: code "Compile the argument, code, as source code in the context of the receiver. Create an error notification if the code can not be compiled. The argument is either a string or an object that converts to a string or a PositionableStream on an object that converts to a string." ^self compile: code notifying: nil! ! !Behavior methodsFor: 'creating method dictionary' stamp: 'tk 12/6/97 21:33'! 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 "a Text" notifying: requestor trailer: #(0 0 0 0) ifFail: [^nil] elseSetSelectorAndNode: [:sel :parseNode | selector _ sel. methodNode _ parseNode]. method putSource: code "a Text" fromParseNode: methodNode inFile: 2 withPreamble: [:f | f cr; nextPut: $!!; nextChunkPut: 'Behavior method'; cr]. ^selector! ! !Behavior methodsFor: 'creating method dictionary'! compileAll ^ self compileAllFrom: self! ! !Behavior methodsFor: 'creating method dictionary'! compileAllFrom: oldClass "Compile all the methods in the receiver's method dictionary. This validates sourceCode and variable references and forces all methods to use the current bytecode set" self selectorsDo: [:sel | self recompile: sel from: oldClass]! ! !Behavior methodsFor: 'creating method dictionary'! compress "Compact the method dictionary of the receiver." methodDict rehash! ! !Behavior methodsFor: 'creating method dictionary'! decompile: selector "Find the compiled code associated with the argument, selector, as a message selector in the receiver's method dictionary and decompile it. Answer the resulting source code as a string. Create an error notification if the selector is not in the receiver's method dictionary." ^self decompilerClass new decompile: selector in: self! ! !Behavior methodsFor: 'creating method dictionary'! defaultSelectorForMethod: aMethod "Given a method, invent and answer an appropriate message selector (a Symbol), that is, one that will parse with the correct number of arguments." | aStream | aStream _ WriteStream on: (String new: 16). aStream nextPutAll: 'DoIt'. 1 to: aMethod numArgs do: [:i | aStream nextPutAll: 'with:']. ^aStream contents asSymbol! ! !Behavior methodsFor: 'creating method dictionary'! methodDictionary: aDictionary "Store the argument, aDictionary, as the method dictionary of the receiver." methodDict _ aDictionary! ! !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: 'creating method dictionary'! recompileChanges "Compile all the methods that are in the changes file. This validates sourceCode and variable references and forces methods to use the current bytecode set" self selectorsDo: [:sel | (self compiledMethodAt: sel) fileIndex > 1 ifTrue: [self recompile: sel from: self]]! ! !Behavior methodsFor: 'creating method dictionary' stamp: 'di 12/26/97 11:08'! removeSelector: selector "Assuming that the argument, selector (a Symbol), is a message selector in the receiver's method dictionary, remove it. If the selector is not in the method dictionary, create an error notification." methodDict removeKey: selector. selector flushCache! ! !Behavior methodsFor: 'instance creation'! basicNew "Primitive. Answer an instance of the receiver (which is a class) with no indexable variables. Fail if the class is indexable. Essential. See Object documentation whatIsAPrimitive." self isVariable ifTrue: [ ^ self basicNew: 0 ]. "space must be low" Smalltalk signalLowSpace. ^ self basicNew "retry if user proceeds" ! ! !Behavior methodsFor: 'instance creation'! basicNew: 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." (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: '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." 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." (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'! allSubclasses "Answer a Set of the receiver's and the receiver's descendent's subclasses." | aSet | aSet _ Set new. aSet addAll: self subclasses. self subclasses do: [:eachSubclass | aSet addAll: eachSubclass allSubclasses]. ^aSet! ! !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 class hierarchy'! allSuperclasses "Answer an OrderedCollection of the receiver's and the receiver's ancestor's superclasses. The first element is the receiver's immediate superclass, followed by its superclass; the last element is Object." | temp | superclass == nil ifTrue: [^OrderedCollection new] ifFalse: [temp _ superclass allSuperclasses. temp addFirst: superclass. ^temp]! ! !Behavior methodsFor: 'accessing class hierarchy'! subclasses "Answer a Set containing the receiver's subclasses." subclasses == nil ifTrue: [^Set new] ifFalse: [^subclasses copy]! ! !Behavior methodsFor: 'accessing class hierarchy'! superclass "Answer the receiver's superclass, a Class." ^superclass! ! !Behavior methodsFor: 'accessing class hierarchy'! withAllSubclasses "Answer a Set of the receiver, the receiver's descendent's, and the receiver's descendent's subclasses." | aSet | aSet _ Set with: self. aSet addAll: self subclasses. self subclasses do: [:eachSubclass | aSet addAll: eachSubclass allSubclasses]. ^aSet! ! !Behavior methodsFor: 'accessing class hierarchy'! withAllSuperclasses "Answer an OrderedCollection of the receiver and the receiver's superclasses. The first element is the receiver, followed by its superclass; the last element is Object." | temp | temp _ self allSuperclasses. temp addFirst: self. ^ temp! ! !Behavior methodsFor: 'accessing method dictionary'! allSelectors "Answer a Set of all the message selectors that instances of the receiver can understand." | temp | superclass == nil ifTrue: [^self selectors] ifFalse: [temp _ superclass allSelectors. temp addAll: self selectors. ^temp] "Point allSelectors"! ! !Behavior methodsFor: 'accessing method dictionary'! changeRecordsAt: selector "Return a list of ChangeRecords for all versions of the method at selector. Source code can be retrieved by sending string to any one" "(Pen changeRecordsAt: #go:) collect: [:cRec | cRec string]" ^ (ChangeList new scanVersionsOf: (self compiledMethodAt: selector) class: self meta: self isMeta category: (self whichCategoryIncludesSelector: selector) selector: selector) changeList! ! !Behavior methodsFor: 'accessing method dictionary'! compiledMethodAt: selector "Answer the compiled method associated with the argument, selector (a Symbol), a message selector in the receiver's method dictionary. If the selector is not in the dictionary, create an error notification." ^methodDict at: selector! ! !Behavior methodsFor: 'accessing method dictionary' stamp: 'sw 1/15/98 19:34'! compiledMethodAt: selector ifAbsent: aBlock "Answer the compiled method associated with the argument, selector (a Symbol), a message selector in the receiver's method dictionary. If the selector is not in the dictionary, return the value of aBlock" ^ methodDict at: selector ifAbsent: [aBlock value]! ! !Behavior methodsFor: 'accessing method dictionary' stamp: 'tk 1/7/98 10:31'! compressedSourceCodeAt: selector "(Paragraph compressedSourceCodeAt: #displayLines:affectedRectangle:) size 721 1921 Paragraph selectors inject: 0 into: [:tot :sel | tot + (Paragraph compressedSourceCodeAt: sel) size] 13606 31450" | rawText parse | rawText _ (self sourceCodeAt: selector) asString. parse _ self compilerClass new parse: rawText in: self notifying: nil. ^ rawText compressWithTable: ((selector keywords , parse tempNames , self instVarNames , #(self super ifTrue: ifFalse:) , ((0 to: 7) collect: [:i | String streamContents: [:s | s cr. i timesRepeat: [s tab]]]) , (self compiledMethodAt: selector) literalStrings) asSortedCollection: [:a :b | a size > b size])! ! !Behavior methodsFor: 'accessing method dictionary'! firstCommentAt: selector "Answer a string representing the first comment in the method associated with selector. Return an empty string if the relevant source file is not available, or if the method's source code does not contain a comment. Not smart enough to bypass quotes in string constants, but ""clever"" enough to map doubled quotes into a single quote. 5/1/96 sw" "Behavior firstCommentAt: #firstCommentAt:" | sourceString commentStart pos nextQuotePos | sourceString _ self sourceCodeAt: selector. sourceString size == 0 ifTrue: [^ '']. commentStart _ sourceString findString: '"' startingAt: 1. commentStart == 0 ifTrue: [^ '']. pos _ commentStart + 1. [(nextQuotePos _ sourceString findString: '"' startingAt: pos) == (sourceString findString: '""' startingAt: pos)] whileTrue: [pos _ nextQuotePos + 2]. ^ (sourceString copyFrom: commentStart + 1 to: nextQuotePos - 1) copyReplaceAll: '""' with: '"'! ! !Behavior methodsFor: 'accessing method dictionary'! selectorAtMethod: method setClass: classResultBlock "Answer both the message selector associated with the compiled method and the class in which that selector is defined." | sel | sel _ methodDict keyAtValue: method ifAbsent: [superclass == nil ifTrue: [classResultBlock value: self. ^self defaultSelectorForMethod: method]. sel _ superclass selectorAtMethod: method setClass: classResultBlock. "Set class to be self, rather than that returned from superclass. " sel == (self defaultSelectorForMethod: method) ifTrue: [classResultBlock value: self]. ^sel]. classResultBlock value: self. ^sel! ! !Behavior methodsFor: 'accessing method dictionary'! selectors "Answer a Set of all the message selectors specified in the receiver's method dictionary." ^methodDict keys "Point selectors."! ! !Behavior methodsFor: 'accessing method dictionary'! selectorsDo: selectorBlock "Evaluate selectorBlock for all the message selectors in my method dictionary." ^methodDict keysDo: selectorBlock! ! !Behavior methodsFor: 'accessing method dictionary' stamp: 'di 1/13/98 17:34'! sourceCodeAt: selector ^ (methodDict at: selector) getSourceFor: selector in: self! ! !Behavior methodsFor: 'accessing method dictionary' stamp: 'sw 11/3/97 00:09'! sourceCodeAt: selector ifAbsent: aBlock ^ (methodDict at: selector ifAbsent: [^ aBlock value]) getSourceFor: selector in: self! ! !Behavior methodsFor: 'accessing method dictionary'! sourceMethodAt: selector "Answer the paragraph corresponding to the source code for the argument." ^(self sourceCodeAt: selector) asText makeSelectorBoldIn: self! ! !Behavior methodsFor: 'accessing method dictionary' stamp: 'sw 11/3/97 00:10'! sourceMethodAt: selector ifAbsent: aBlock "Answer the paragraph corresponding to the source code for the argument." ^ (self sourceCodeAt: selector ifAbsent: [^ aBlock value]) asText makeSelectorBoldIn: self! ! !Behavior methodsFor: 'accessing instances and variables'! allClassVarNames "Answer a Set of the names of the receiver's and the receiver's ancestor's class variables." ^superclass allClassVarNames! ! !Behavior methodsFor: 'accessing instances and variables' stamp: 'jm 5/20/1998 15:53'! allInstances "Answer a collection of all current instances of the receiver." | all | all _ OrderedCollection new. self allInstancesDo: [:x | x == all ifFalse: [all add: x]]. ^ all asArray ! ! !Behavior methodsFor: 'accessing instances and variables'! allInstVarNames "Answer an Array of the names of the receiver's instance variables. The Array ordering is the order in which the variables are stored and accessed by the interpreter." | vars | superclass == nil ifTrue: [vars _ self instVarNames copy] "Guarantee a copy is answered." ifFalse: [vars _ superclass allInstVarNames , self instVarNames]. ^vars! ! !Behavior methodsFor: 'accessing instances and variables'! allSharedPools "Answer a Set of the names of the pools (Dictionaries) that the receiver and the receiver's ancestors share." ^superclass allSharedPools! ! !Behavior methodsFor: 'accessing instances and variables' stamp: 'di 6/20/97 10:51'! allSubInstances "Answer a list of all current instances of the receiver and all of its subclasses." | aCollection | aCollection _ OrderedCollection new. self allSubInstancesDo: [:x | x == aCollection ifFalse: [aCollection add: x]]. ^ aCollection! ! !Behavior methodsFor: 'accessing instances and variables'! classVarNames "Answer a Set of the receiver's class variable names." ^Set new! ! !Behavior methodsFor: 'accessing instances and variables'! inspectAllInstances "Inpsect all instances of the receiver. 1/26/96 sw" | all allSize prefix | all _ self allInstances. (allSize _ all size) == 0 ifTrue: [^ self notify: 'There are no instances of ', self name]. prefix _ allSize == 1 ifTrue: ['The lone instance'] ifFalse: ['The ', allSize printString, ' instances']. all asArray inspectWithLabel: (prefix, ' of ', self name)! ! !Behavior methodsFor: 'accessing instances and variables'! inspectSubInstances "Inspect all instances of the receiver and all its subclasses. CAUTION - don't do this for something as generic as Object!! 1/26/96 sw" | all allSize prefix | all _ self allSubInstances. (allSize _ all size) == 0 ifTrue: [^ self notify: 'There are no instances of ', self name, ' or any of its subclasses']. prefix _ allSize == 1 ifTrue: ['The lone instance'] ifFalse: ['The ', allSize printString, ' instances']. all asArray inspectWithLabel: (prefix, ' of ', self name, ' & its subclasses')! ! !Behavior methodsFor: 'accessing instances and variables'! instanceCount "Answer the number of instances of the receiver that are currently in use." | count | count _ 0. self allInstancesDo: [:x | count _ count + 1]. ^count! ! !Behavior methodsFor: 'accessing instances and variables'! instVarNames "Answer an Array of the instance variable names. Behaviors must make up fake local instance variable names because Behaviors have instance variables for the purpose of compiling methods, but these are not named instance variables." | mySize superSize | mySize _ self instSize. superSize _ superclass == nil ifTrue: [0] ifFalse: [superclass instSize]. mySize = superSize ifTrue: [^#()]. ^(superSize + 1 to: mySize) collect: [:i | 'inst' , i printString]! ! !Behavior methodsFor: 'accessing instances and variables'! sharedPools "Answer a Set of the names of the pools (Dictionaries) that the receiver shares. 9/12/96 tk sharedPools have an order now" ^ OrderedCollection new! ! !Behavior methodsFor: 'accessing instances and variables'! someInstance "Primitive. Answer the first instance in the enumeration of all instances of the receiver. Fails if there are none. Essential. See Object documentation whatIsAPrimitive." ^nil! ! !Behavior methodsFor: 'accessing instances and variables'! subclassInstVarNames "Answer a Set of the names of the receiver's subclasses' instance variables." | vars | vars _ Set new. self allSubclasses do: [:aSubclass | vars addAll: aSubclass instVarNames]. ^vars! ! !Behavior methodsFor: 'testing class hierarchy'! inheritsFrom: aClass "Answer whether the argument, aClass, is on the receiver's superclass chain." | aSuperclass | aSuperclass _ superclass. [aSuperclass == nil] whileFalse: [aSuperclass == aClass ifTrue: [^true]. aSuperclass _ aSuperclass superclass]. ^false! ! !Behavior methodsFor: 'testing class hierarchy'! kindOfSubclass "Answer a String that is the keyword that describes the receiver's kind of subclass, either a regular subclass, a variableSubclass, a variableByteSubclass, or a variableWordSubclass." self isVariable ifTrue: [self isBits ifTrue: [self isBytes ifTrue: [^' variableByteSubclass: '] ifFalse: [^' variableWordSubclass: ']] ifFalse: [^' variableSubclass: ']] ifFalse: [^' subclass: ']! ! !Behavior methodsFor: 'testing method dictionary'! allUnsentMessages "Answer an array of all the messages defined by the receiver that are not sent anywhere in the system. 5/8/96 sw" ^ Smalltalk allUnSentMessagesIn: self selectors! ! !Behavior methodsFor: 'testing method dictionary'! canUnderstand: selector "Answer whether the receiver can respond to the message whose selector is the argument. The selector can be in the method dictionary of the receiver's class or any of its superclasses." (self includesSelector: selector) ifTrue: [^true]. superclass == nil ifTrue: [^false]. ^superclass canUnderstand: selector! ! !Behavior methodsFor: 'testing method dictionary' stamp: 'tk 9/13/97 09:53'! classThatUnderstands: selector "Answer the class that can respond to the message whose selector is the argument. The selector can be in the method dictionary of the receiver's class or any of its superclasses." (self includesSelector: selector) ifTrue: [^ self]. superclass == nil ifTrue: [^ nil]. ^ superclass classThatUnderstands: selector! ! !Behavior methodsFor: 'testing method dictionary'! hasMethods "Answer whether the receiver has any methods in its method dictionary." ^methodDict size > 0! ! !Behavior methodsFor: 'testing method dictionary'! includesSelector: aSymbol "Answer whether the message whose selector is the argument is in the method dictionary of the receiver's class." ^methodDict includesKey: aSymbol! ! !Behavior methodsFor: 'testing method dictionary'! scopeHas: name ifTrue: assocBlock "If the argument name is a variable known to the receiver, then evaluate the second argument, assocBlock." ^superclass scopeHas: name ifTrue: assocBlock! ! !Behavior methodsFor: 'testing method dictionary' stamp: 'di 9/5/97 16:16'! thoroughWhichSelectorsReferTo: literal special: specialFlag byte: specialByte "Answer a set of selectors whose methods access the argument as a literal. Dives into the compact literal notation, making it slow but thorough" | who method | who _ Set new. methodDict associationsDo: [:assn | method _ assn value. ((method hasLiteralSuchThat: [:lit | lit == literal]) or: [specialFlag and: [method scanFor: specialByte]]) ifTrue: [((literal isMemberOf: Association) not or: [method sendsToSuper not or: [method literals allButLast includes: literal]]) ifTrue: [who add: assn key]]]. ^ who! ! !Behavior methodsFor: 'testing method dictionary'! whichClassIncludesSelector: aSymbol "Answer the class on the receiver's superclass chain where the argument, aSymbol (a message selector), will be found. Answer nil if none found." (methodDict includesKey: aSymbol) ifTrue: [^self]. superclass == nil ifTrue: [^nil]. ^superclass whichClassIncludesSelector: aSymbol "Rectangle whichClassIncludesSelector: #inspect."! ! !Behavior methodsFor: 'testing method dictionary'! whichSelectorsAccess: instVarName "Answer a Set of selectors whose methods access the argument, instVarName, as a named instance variable." | instVarIndex | instVarIndex _ self allInstVarNames indexOf: instVarName ifAbsent: [^Set new]. ^methodDict keys select: [:sel | ((methodDict at: sel) readsField: instVarIndex) or: [(methodDict at: sel) writesField: instVarIndex]] "Point whichSelectorsAccess: 'x'."! ! !Behavior methodsFor: 'testing method dictionary'! whichSelectorsReferTo: literal "Answer a Set of selectors whose methods access the argument as a literal." | special | special _ Smalltalk hasSpecialSelector: literal ifTrueSetByte: [:byte ]. ^self whichSelectorsReferTo: literal special: special byte: byte "Rectangle whichSelectorsReferTo: #+."! ! !Behavior methodsFor: 'testing method dictionary' stamp: 'di 10/17/97 22:39'! 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 hasLiteral: literal) or: [specialFlag and: [method scanFor: specialByte]]) ifTrue: [((literal isMemberOf: Association) not or: [method sendsToSuper not or: [method literals allButLast includes: literal]]) ifTrue: [who add: assn key]]]. ^who! ! !Behavior methodsFor: 'testing method dictionary'! whichSelectorsStoreInto: instVarName "Answer a Set of selectors whose methods access the argument, instVarName, as a named instance variable." | instVarIndex | instVarIndex _ self allInstVarNames indexOf: instVarName ifAbsent: [^Set new]. ^ methodDict keys select: [:sel | (methodDict at: sel) writesField: instVarIndex] "Point whichSelectorsStoreInto: 'x'."! ! !Behavior methodsFor: 'enumerating'! allInstancesDo: aBlock "Evaluate the argument, aBlock, for each of the current instances of the receiver." | inst next | self == UndefinedObject ifTrue: [^ aBlock value: nil]. inst _ self someInstance. [inst == nil] whileFalse: [aBlock value: inst. inst _ inst nextInstance]! ! !Behavior methodsFor: 'enumerating'! allSubclassesDo: aBlock "Evaluate the argument, aBlock, for each of the receiver's subclasses." self subclassesDo: [:cl | aBlock value: cl. cl allSubclassesDo: aBlock]! ! !Behavior methodsFor: 'enumerating' stamp: 'di 6/20/97 10:50'! allSubInstancesDo: aBlock "Evaluate the argument, aBlock, for each of the current instances of the receiver and all its subclasses." self allInstancesDo: aBlock. self allSubclassesDo: [:sub | sub allInstancesDo: aBlock]! ! !Behavior methodsFor: 'enumerating'! allSuperclassesDo: aBlock "Evaluate the argument, aBlock, for each of the receiver's superclasses." superclass == nil ifFalse: [aBlock value: superclass. superclass allSuperclassesDo: aBlock]! ! !Behavior methodsFor: 'enumerating'! selectSubclasses: aBlock "Evaluate the argument, aBlock, with each of the receiver's (next level) subclasses as its argument. Collect into a Set only those subclasses for which aBlock evaluates to true. In addition, evaluate aBlock for the subclasses of each of these successful subclasses and collect into the set those for which aBlock evaluates true. Answer the resulting set." | aSet | aSet _ Set new. self allSubclasses do: [:aSubclass | (aBlock value: aSubclass) ifTrue: [aSet add: aSubclass]]. ^aSet! ! !Behavior methodsFor: 'enumerating'! selectSuperclasses: aBlock "Evaluate the argument, aBlock, with the receiver's superclasses as the argument. Collect into an OrderedCollection only those superclasses for which aBlock evaluates to true. In addition, evaluate aBlock for the superclasses of each of these successful superclasses and collect into the OrderedCollection ones for which aBlock evaluates to true. Answer the resulting OrderedCollection." | aSet | aSet _ Set new. self allSuperclasses do: [:aSuperclass | (aBlock value: aSuperclass) ifTrue: [aSet add: aSuperclass]]. ^aSet! ! !Behavior methodsFor: 'enumerating'! subclassesDo: aBlock "Evaluate the argument, aBlock, for each of the receiver's immediate subclasses." subclasses == nil ifFalse: [subclasses do: [:cl | aBlock value: cl]]! ! !Behavior methodsFor: 'enumerating'! withAllSubclassesDo: aBlock "Evaluate the argument, aBlock, for the receiver and each of its subclasses." aBlock value: self. self allSubclassesDo: aBlock! ! !Behavior methodsFor: 'user interface' stamp: 'sw 8/12/97 20:18'! allCallsOn: aSymbol "Answer a SortedCollection of all the methods that call on aSymbol." | aSortedCollection special | aSortedCollection _ SortedCollection new. special _ Smalltalk hasSpecialSelector: aSymbol ifTrueSetByte: [:byte ]. self withAllSubclassesDo: [:class | (class whichSelectorsReferTo: aSymbol special: special byte: byte) do: [:sel | sel ~~ #DoIt ifTrue: [aSortedCollection add: class name , ' ' , sel]]]. ^aSortedCollection! ! !Behavior methodsFor: 'user interface' stamp: 'sw 2/23/98 00:48'! browse Browser newOnClass: self! ! !Behavior methodsFor: 'user interface'! browseAllAccessesTo: instVarName "Collection browseAllAccessesTo: 'contents'." "Create and schedule a Message Set browser for all the receiver's methods or any methods of a subclass that refer to the instance variable name." | coll | coll _ OrderedCollection new. Cursor wait showWhile: [self withAllSubclasses do: [:class | (class whichSelectorsAccess: instVarName) do: [:sel | sel ~~ #DoIt ifTrue: [coll add: class name , ' ' , sel]]]. self allSuperclasses do: [:class | (class whichSelectorsAccess: instVarName) do: [:sel | sel ~~ #DoIt ifTrue: [coll add: class name , ' ' , sel]]]]. ^ Smalltalk browseMessageList: coll name: 'Accesses to ' , instVarName autoSelect: instVarName! ! !Behavior methodsFor: 'user interface'! browseAllCallsOn: aSymbol "Create and schedule a Message Set browser for all the methods that call on aSymbol." | key label | (aSymbol isKindOf: LookupKey) ifTrue: [label _ 'Users of ' , (key _ aSymbol key)] ifFalse: [label _ 'Senders of ' , (key _ aSymbol)]. ^ Smalltalk browseMessageList: (self allCallsOn: aSymbol) asSortedCollection name: label autoSelect: key "Number browseAllCallsOn: #/."! ! !Behavior methodsFor: 'user interface'! browseAllStoresInto: instVarName "Collection browseAllStoresInto: 'contents'." "Create and schedule a Message Set browser for all the receiver's methods or any methods of a subclass that refer to the instance variable name." | coll | coll _ OrderedCollection new. Cursor wait showWhile: [self withAllSubclasses do: [:class | (class whichSelectorsStoreInto: instVarName) do: [:sel | sel ~~ #DoIt ifTrue: [coll add: class name , ' ' , sel]]]. self allSuperclasses do: [:class | (class whichSelectorsStoreInto: instVarName) do: [:sel | sel ~~ #DoIt ifTrue: [coll add: class name , ' ' , sel]]]]. ^ Smalltalk browseMessageList: coll name: 'Stores into ' , instVarName autoSelect: instVarName! ! !Behavior methodsFor: 'user interface'! crossReference "Answer an Array of arrays of size 2 whose first element is a message selector in the receiver's method dictionary and whose second element is a set of all message selectors in the method dictionary whose methods send a message with that selector. Subclasses are not included." ^self selectors asSortedCollection asArray collect: [:x | Array with: (String with: Character cr), x with: (self whichSelectorsReferTo: x)] "Point crossReference."! ! !Behavior methodsFor: 'user interface' stamp: 'sw 2/4/98 15:21'! removeUninstantiatedSubclassesSilently "Remove the classes of any subclasses that have neither instances nor subclasses. Answer the number of bytes reclaimed" "Player removeUninstantiatedSubclassesSilently" | candidatesForRemoval oldFree | oldFree _ Smalltalk garbageCollect. candidatesForRemoval _ self subclasses select: [:c | (c instanceCount = 0) and: [c subclasses size = 0]]. candidatesForRemoval do: [:c | c removeFromSystem]. ^ Smalltalk garbageCollect - oldFree! ! !Behavior methodsFor: 'user interface'! unreferencedInstanceVariables "Return a list of the instance variables defined in the receiver which are not referenced in the receiver or any of its subclasses. 2/26/96 sw" | any | ^ self instVarNames copy reject: [:ivn | any _ false. self withAllSubclasses do: [:class | (class whichSelectorsAccess: ivn) do: [:sel | sel ~~ #DoIt ifTrue: [any _ true]]]. any] "Ob unreferencedInstanceVariables"! ! !Behavior methodsFor: 'private'! becomeCompact | cct index | cct _ Smalltalk compactClassesArray. (self indexIfCompact > 0 or: [cct includes: self]) ifTrue: [^ self halt: self name , 'is already compact']. index _ cct indexOf: nil ifAbsent: [^ self halt: 'compact class table is full']. "Install this class in the compact class table" cct at: index put: self. "Update instspec so future instances will be compact" format _ format + (index bitShift: 11). "Make up new instances and become old ones into them" self updateInstancesFrom: self. "Purge any old instances" Smalltalk garbageCollect.! ! !Behavior methodsFor: 'private'! becomeUncompact | cct index | cct _ Smalltalk compactClassesArray. (index _ self indexIfCompact) = 0 ifTrue: [^ self]. (cct includes: self) ifFalse: [^ self halt "inconsistent state"]. "Update instspec so future instances will not be compact" format _ format - (index bitShift: 11). "Make up new instances and become old ones into them" self updateInstancesFrom: self. "Make sure there are no compact ones left around" Smalltalk garbageCollect. "Remove this class from the compact class table" cct at: index put: nil. ! ! !Behavior methodsFor: 'private'! flushCache "Tell the interpreter to remove the contents of its method lookup cache, if it has one. Essential. See Object documentation whatIsAPrimitive." self primitiveFailed! ! !Behavior methodsFor: 'private'! 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" ! ! !Behavior methodsFor: 'private'! indexIfCompact "If these 5 bits are non-zero, then instances of this class will be compact. It is crucial that there be an entry in Smalltalk compactClassesArray for any class so optimized. See the msgs becomeCompact and becomeUncompact." ^ (format bitShift: -11) bitAnd: 16r1F " Smalltalk compactClassesArray doWithIndex: [:c :i | c == nil ifFalse: [c indexIfCompact = i ifFalse: [self halt]]] "! ! !Behavior methodsFor: 'private'! printSubclassesOn: aStream level: level "As part of the algorithm for printing a description of the receiver, print the subclass on the file stream, aStream, indenting level times." | subclassNames subclass | aStream crtab: level. aStream nextPutAll: self name. aStream space; print: self instVarNames. self == Class ifTrue: [aStream crtab: level + 1; nextPutAll: '[ ... all the Metaclasses ... ]'. ^self]. subclassNames _ self subclasses collect: [:subC | subC name]. "Print subclasses in alphabetical order" subclassNames asSortedCollection do: [:name | subclass _ self subclasses detect: [:subC | subC name = name]. subclass printSubclassesOn: aStream level: level + 1]! ! !Behavior methodsFor: 'private' stamp: 'di 12/26/97 11:07'! removeSelectorSimply: selector "Remove the message selector from the receiver's method dictionary. Internal access from compiler." methodDict removeKey: selector ifAbsent: [^self]. selector flushCache! ! Object subclass: #BitBlt instanceVariableNames: 'destForm sourceForm halftoneForm combinationRule destX destY width height sourceX sourceY clipX clipY clipWidth clipHeight colorMap ' classVariableNames: '' poolDictionaries: '' category: 'Graphics-Support'! !BitBlt commentStamp: 'di 5/22/1998 16:32' prior: 0! 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'! clipHeight: anInteger "Set the receiver's clipping area height to be the argument, anInteger." clipHeight _ anInteger! ! !BitBlt methodsFor: 'accessing'! clipRect "Answer the receiver's clipping area rectangle." ^clipX @ clipY extent: clipWidth @ clipHeight! ! !BitBlt methodsFor: 'accessing'! clipRect: aRectangle "Set the receiver's clipping area rectangle to be the argument, aRectangle." clipX _ aRectangle left. clipY _ aRectangle top. clipWidth _ aRectangle width. clipHeight _ aRectangle height! ! !BitBlt methodsFor: 'accessing'! clipWidth: anInteger "Set the receiver's clipping area width to be the argument, anInteger." clipWidth _ anInteger! ! !BitBlt methodsFor: 'accessing'! clipX: anInteger "Set the receiver's clipping area top left x coordinate to be the argument, anInteger." clipX _ anInteger! ! !BitBlt methodsFor: 'accessing'! clipY: anInteger "Set the receiver's clipping area top left y coordinate to be the argument, anInteger." clipY _ anInteger! ! !BitBlt methodsFor: 'accessing'! colorMap ^ colorMap! ! !BitBlt methodsFor: 'accessing'! colorMap: map "See last part of BitBlt comment. 6/18/96 tk" colorMap _ map! ! !BitBlt methodsFor: 'accessing'! combinationRule: anInteger "Set the receiver's combination rule to be the argument, anInteger, a number in the range 0-15." combinationRule _ anInteger! ! !BitBlt methodsFor: 'accessing'! destForm ^ destForm! ! !BitBlt methodsFor: 'accessing'! destOrigin: aPoint "Set the receiver's destination top left coordinates to be those of the argument, aPoint." destX _ aPoint x. destY _ aPoint y! ! !BitBlt methodsFor: 'accessing' stamp: 'tk 3/19/97'! destRect "The rectangle we are about to blit to or just blitted to. " ^ destX @ destY extent: width @ height! ! !BitBlt methodsFor: 'accessing'! destRect: aRectangle "Set the receiver's destination form top left coordinates to be the origin of the argument, aRectangle, and set the width and height of the receiver's destination form to be the width and height of aRectangle." destX _ aRectangle left. destY _ aRectangle top. width _ aRectangle width. height _ aRectangle height! ! !BitBlt methodsFor: 'accessing'! destX: anInteger "Set the top left x coordinate of the receiver's destination form to be the argument, anInteger." destX _ anInteger! ! !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'! destY: anInteger "Set the top left y coordinate of the receiver's destination form to be the argument, anInteger." destY _ anInteger! ! !BitBlt methodsFor: 'accessing'! fillColor ^ halftoneForm! ! !BitBlt methodsFor: 'accessing'! fillColor: aColorOrPattern "The destForm will be filled with this color or pattern of colors. May be an old Color, a new type Color, a Bitmap (see BitBlt comment), a Pattern, or a Form. 6/18/96 tk" aColorOrPattern == nil ifTrue: [halftoneForm _ nil. ^ self]. destForm == nil ifTrue: [self error: 'Must set destForm first']. halftoneForm _ aColorOrPattern bitPatternForDepth: destForm depth! ! !BitBlt methodsFor: 'accessing'! height: anInteger "Set the receiver's destination form height to be the argument, anInteger." height _ anInteger! ! !BitBlt methodsFor: 'accessing'! sourceForm ^ sourceForm! ! !BitBlt methodsFor: 'accessing'! sourceForm: aForm "Set the receiver's source form to be the argument, aForm." sourceForm _ aForm! ! !BitBlt methodsFor: 'accessing'! sourceOrigin: aPoint "Set the receiver's source form coordinates to be those of the argument, aPoint." sourceX _ aPoint x. sourceY _ aPoint y! ! !BitBlt methodsFor: 'accessing'! sourceRect: aRectangle "Set the receiver's source form top left x and y, width and height to be the top left coordinate and extent of the argument, aRectangle." sourceX _ aRectangle left. sourceY _ aRectangle top. width _ aRectangle width. height _ aRectangle height! ! !BitBlt methodsFor: 'accessing'! sourceX: anInteger "Set the receiver's source form top left x to be the argument, anInteger." sourceX _ anInteger! ! !BitBlt methodsFor: 'accessing'! sourceY: anInteger "Set the receiver's source form top left y to be the argument, anInteger." sourceY _ anInteger! ! !BitBlt methodsFor: 'accessing'! width: anInteger "Set the receiver's destination form width to be the argument, anInteger." width _ anInteger! ! !BitBlt methodsFor: 'copying'! copy: destRectangle from: sourcePt in: srcForm | destOrigin | sourceForm _ srcForm. halftoneForm _ nil. combinationRule _ 3. "store" destOrigin _ destRectangle origin. destX _ destOrigin x. destY _ destOrigin y. sourceX _ sourcePt x. sourceY _ sourcePt y. width _ destRectangle width. height _ destRectangle height. self copyBits! ! !BitBlt methodsFor: 'copying'! copy: destRectangle from: sourcePt in: srcForm fillColor: hf rule: rule "Specify a Color to fill, not a Form. 6/18/96 tk" | destOrigin | sourceForm _ srcForm. self fillColor: hf. "sets halftoneForm" combinationRule _ rule. destOrigin _ destRectangle origin. destX _ destOrigin x. destY _ destOrigin y. sourceX _ sourcePt x. sourceY _ sourcePt y. width _ destRectangle width. height _ destRectangle height. ^ self copyBits! ! !BitBlt methodsFor: 'copying'! copy: destRectangle from: sourcePt in: srcForm halftoneForm: hf rule: rule | destOrigin | sourceForm _ srcForm. self fillColor: hf. "sets halftoneForm" combinationRule _ rule. destOrigin _ destRectangle origin. destX _ destOrigin x. destY _ destOrigin y. sourceX _ sourcePt x. sourceY _ sourcePt y. width _ destRectangle width. height _ destRectangle height. self copyBits! ! !BitBlt methodsFor: 'copying' stamp: 'di 3/2/98 14:06'! copyBits "Primitive. Perform the movement of bits from the source form to the destination form. Fail if any variables are not of the right type (Integer, Float, or Form) or if the combination rule is not implemented. In addition to the original 16 combination rules, this BitBlt supports 16 fail (to simulate paint) 17 fail (to simulate mask) 18 sourceWord + destinationWord 19 sourceWord - destinationWord 20 rgbAdd: sourceWord with: destinationWord 21 rgbSub: sourceWord with: destinationWord 22 rgbDiff: sourceWord with: destinationWord 23 tallyIntoMap: destinationWord 24 alphaBlend: sourceWord with: destinationWord 25 pixPaint: sourceWord with: destinationWord 26 pixMask: sourceWord with: destinationWord 27 rgbMax: sourceWord with: destinationWord 28 rgbMin: sourceWord with: destinationWord 29 rgbMin: sourceWord bitInvert32 with: destinationWord " "Check for compressed source, destination or halftone forms" ((sourceForm isKindOf: Form) and: [sourceForm unhibernate]) ifTrue: [^ self copyBits]. ((destForm isKindOf: Form) and: [destForm unhibernate]) ifTrue: [^ self copyBits]. ((halftoneForm isKindOf: Form) and: [halftoneForm unhibernate]) ifTrue: [^ self copyBits]. "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'! copyForm: srcForm to: destPt rule: rule color: color sourceForm _ srcForm. halftoneForm _ color. combinationRule _ rule. destX _ destPt x + sourceForm offset x. destY _ destPt y + sourceForm offset y. sourceX _ 0. sourceY _ 0. width _ sourceForm width. height _ sourceForm height. self copyBits! ! !BitBlt methodsFor: 'copying' stamp: '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'! copyForm: srcForm to: destPt rule: rule fillColor: color sourceForm _ srcForm. self fillColor: color. "sets halftoneForm" combinationRule _ rule. destX _ destPt x + sourceForm offset x. destY _ destPt y + sourceForm offset y. sourceX _ 0. sourceY _ 0. width _ sourceForm width. height _ sourceForm height. self copyBits! ! !BitBlt methodsFor: 'copying' stamp: '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'! fill: destRect fillColor: grayForm rule: rule "Fill with a Color, not a Form. 6/18/96 tk" sourceForm _ nil. self fillColor: grayForm. "sets halftoneForm" combinationRule _ rule. destX _ destRect left. destY _ destRect top. sourceX _ 0. sourceY _ 0. width _ destRect width. height _ destRect height. self copyBits! ! !BitBlt methodsFor: 'copying'! 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. ^ destForm bits at: 1! ! !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 | 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'! copyBitsAgain "Primitive. See BitBlt|copyBits, also a Primitive. Essential. See Object documentation whatIsAPrimitive." self primitiveFailed! ! !BitBlt methodsFor: 'private'! eraseBits "Perform the erase operation, which puts 0's in the destination wherever the source (which is assumed to be just 1 bit deep) has a 1. This requires the colorMap to be set in order to AND all 1's into the destFrom pixels regardless of their size." | oldMask oldMap | oldMask _ halftoneForm. halftoneForm _ nil. oldMap _ colorMap. self colorMap: (Bitmap with: 0 with: 16rFFFFFFFF). combinationRule _ Form erase. self copyBits. "Erase the dest wherever the source is 1" halftoneForm _ oldMask. "already converted to a Bitmap" colorMap _ oldMap! ! !BitBlt methodsFor: 'private'! 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 | bb | bb _ df boundingBox. destForm _ df. clipX _ bb left. clipY _ bb top. clipWidth _ bb width. clipHeight _ bb height! ! !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 instanceVariableNames: ''! !BitBlt class methodsFor: 'instance creation' stamp: 'di 3/2/98 12:53'! bitPeekerFromForm: sourceForm "Answer an instance to be used extract individual pixels from the given Form. The destination for a 1x1 copyBits will be the low order bits of (bits at: 1)." | pixPerWord | pixPerWord _ 32 // sourceForm depth. sourceForm unhibernate. ^ self destForm: (Form extent: pixPerWord@1 depth: sourceForm depth) sourceForm: sourceForm halftoneForm: nil combinationRule: Form over destOrigin: (pixPerWord - 1)@0 sourceOrigin: 0@0 extent: 1@1 clipRect: (0@0 extent: pixPerWord@1) ! ! !BitBlt class methodsFor: 'instance creation' stamp: 'di 3/2/98 12:53'! bitPokerToForm: destForm "Answer an instance to be used for valueAt: aPoint put: pixValue. The source for a 1x1 copyBits will be the low order of (bits at: 1)" | pixPerWord | pixPerWord _ 32//destForm depth. destForm unhibernate. ^ self destForm: destForm sourceForm: (Form extent: pixPerWord@1 depth: destForm depth) halftoneForm: nil combinationRule: Form over destOrigin: 0@0 sourceOrigin: (pixPerWord-1)@0 extent: 1@1 clipRect: (0@0 extent: destForm extent) ! ! !BitBlt class methodsFor: 'instance creation'! destForm: df sourceForm: sf fillColor: hf combinationRule: cr destOrigin: destOrigin sourceOrigin: sourceOrigin extent: extent clipRect: clipRect "Answer an instance of me with values set according to the arguments." ^ self new setDestForm: df sourceForm: sf fillColor: hf combinationRule: cr destOrigin: destOrigin sourceOrigin: sourceOrigin extent: extent clipRect: clipRect! ! !BitBlt class methodsFor: 'instance creation'! destForm: df sourceForm: sf halftoneForm: hf combinationRule: cr destOrigin: destOrigin sourceOrigin: sourceOrigin extent: extent clipRect: clipRect "Answer an instance of me with values set according to the arguments." ^ self new setDestForm: df sourceForm: sf fillColor: hf combinationRule: cr destOrigin: destOrigin sourceOrigin: sourceOrigin extent: extent clipRect: clipRect! ! !BitBlt class methodsFor: 'instance creation'! toForm: aForm ^ self new setDestForm: aForm! ! !BitBlt class methodsFor: 'examples' stamp: 'di 12/1/97 12:08'! 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 dist: prevP) > buffSize ifTrue: ["Stroke too long to fit in buffer -- clip to buffer, and next time through will do more of it" theta _ (p-prevP) theta. p _ ((theta cos@theta sin) * buffSize asFloat + prevP) truncated]. brushRect _ p extent: brush extent. (buffRect containsRect: brushRect) ifFalse: ["Brush is out of buffer region. Scroll the buffer, and fill vacated regions from the display" delta _ brushRect amountToTranslateWithin: buffRect. buffToBuff copyFrom: buff boundingBox in: buff to: delta. newBuffRect _ buffRect translateBy: delta negated. (newBuffRect areasOutside: buffRect) do: [:r | dispToBuff copyFrom: r in: Display to: r origin - newBuffRect origin]. buffRect _ newBuffRect]. "Interpolate from prevP to p..." brushToBuff drawFrom: prevP - buffRect origin to: p - buffRect origin withFirstPoint: false. "Update (only) the altered pixels of the destination" updateRect _ (p min: prevP) corner: (p max: prevP) + brush extent. buffToDisplay copy: updateRect from: updateRect origin - buffRect origin in: buff. prevP _ p]]]! ! !BitBlt class methodsFor: 'examples' stamp: 'di 12/1/97 12:09'! 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 dist: prevP) > (buffSize-1) ifTrue: ["Stroke too long to fit in buffer -- clip to buffer, and next time through will do more of it" theta _ (p-prevP) theta. p _ ((theta cos@theta sin) * (buffSize-2) asFloat + prevP) truncated]. brushRect _ p extent: brush extent. ((buff boundingBox insetBy: scale) containsRect: brushRect) ifFalse: ["Brush is out of buffer region. Scroll the buffer, and fill vacated regions from the display" delta _ (brushRect amountToTranslateWithin: (buff boundingBox insetBy: scale)) // scale. buffToBuff copyFrom: buff boundingBox in: buff to: delta*scale. newBuffRect _ buffRect translateBy: delta negated. p _ p translateBy: delta*scale. prevP _ prevP translateBy: delta*scale. (newBuffRect areasOutside: buffRect) do: [:r | dispToBuff copyQuad: r innerCorners toRect: (r origin - newBuffRect origin*scale extent: r extent*scale)]. buffRect _ newBuffRect]. "Interpolate from prevP to p..." brushToBuff drawFrom: prevP to: p withFirstPoint: false. buff displayAt: 0@0. "** remove to hide sliding buffer **" "Update (only) the altered pixels of the destination" updateRect _ (p min: prevP) corner: (p max: prevP) + brush extent. updateRect _ updateRect origin // scale * scale corner: updateRect corner + scale // scale * scale. buffToDisplay copyQuad: updateRect innerCorners toRect: (updateRect origin // scale + buffRect origin extent: updateRect extent // scale). prevP _ p]]]! ! !BitBlt class methodsFor: 'examples'! 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: 'examples'! exampleTwo "This is to test painting with a gray tone. It also tests that the seaming with gray patterns is correct in the microcode. Lets you paint for a while and then automatically stops." | f aBitBlt | "create a small black Form source as a brush. " f _ Form extent: 20 @ 20. f fillBlack. "create a BitBlt which will OR gray into the display. " aBitBlt _ BitBlt destForm: Display sourceForm: f fillColor: Color gray combinationRule: Form under destOrigin: Sensor cursorPoint sourceOrigin: 0 @ 0 extent: f extent clipRect: Display computeBoundingBox. "paint the gray Form on the screen for a while. " [Sensor anyButtonPressed] whileFalse: [aBitBlt destOrigin: Sensor cursorPoint. aBitBlt copyBits] "BitBlt exampleTwo"! ! !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"! ! Object subclass: #BitBltSimulation instanceVariableNames: 'destForm sourceForm halftoneForm combinationRule destX destY width height sourceX sourceY clipX clipY clipWidth clipHeight sourceBits sourceRaster sourcePixSize destBits destRaster destPixSize pixPerWord bitCount skew mask1 mask2 preload nWords hDir vDir sourceIndex sourceDelta destIndex destDelta sx sy dx dy bbW bbH srcWidth srcHeight halftoneHeight noSource noHalftone halftoneBase colorMap cmBitsPerColor srcBitIndex scanStart scanStop scanString scanRightX scanStopArray scanDisplayFlag scanXTable stopCode bitBltOop affectedL affectedR affectedT affectedB interpreterProxy opTable ' classVariableNames: 'AllOnes BBClipHeightIndex BBClipWidthIndex BBClipXIndex BBClipYIndex BBColorMapIndex BBDestFormIndex BBDestXIndex BBDestYIndex BBHalftoneFormIndex BBHeightIndex BBLastIndex BBRuleIndex BBSourceFormIndex BBSourceXIndex BBSourceYIndex BBWarpBase BBWidthIndex BBXTableIndex BinaryPoint CrossedX EndOfRun FixedPt1 FormBitsIndex FormDepthIndex FormHeightIndex FormWidthIndex OpTable OpTableSize ' poolDictionaries: '' category: 'Squeak-Interpreter'! !BitBltSimulation commentStamp: 'di 5/22/1998 16:32' prior: 0! 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: destinationWord This 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' stamp: 'di 12/30/97 14:42'! copyLoop | prevWord thisWord skewWord halftoneWord mergeWord hInc y unskew skewMask notSkewMask mergeFnwith | "This version of the inner loop assumes noSource = false." self inline: false. self var: #mergeFnwith declareC: 'int (*mergeFnwith)(int, int)'. mergeFnwith _ self cCoerce: (opTable at: combinationRule+1) to: 'int (*)(int, int)'. mergeFnwith. "null ref for compiler" 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 mergeFn: (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 = 3 ifTrue: [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 mergeFn: (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 mergeFn: (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' stamp: 'di 12/30/97 14:43'! copyLoopNoSource | halftoneWord mergeWord mergeFnwith | "Faster copyLoop when source not used. hDir and vDir are both positive, and perload and skew are unused" self inline: false. self var: #mergeFnwith declareC: 'int (*mergeFnwith)(int, int)'. mergeFnwith _ self cCoerce: (opTable at: combinationRule+1) to: 'int (*)(int, int)'. mergeFnwith. "null ref for compiler" 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 mergeFn: 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 = 3 ifTrue: [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 mergeFn: 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 mergeFn: 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 12/30/97 14:45'! 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 mergeFnwith | self inline: false. self var: #mergeFnwith declareC: 'int (*mergeFnwith)(int, int)'. mergeFnwith _ self cCoerce: (opTable at: combinationRule+1) to: 'int (*)(int, int)'. mergeFnwith. "null ref for compiler" "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 mergeFn: (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'! addWord: sourceWord with: destinationWord ^sourceWord + destinationWord! ! !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<>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' stamp: 'di 1/21/98 21:57'! rgbMinInvert: wordToInvert with: destinationWord | sourceWord | self inline: false. sourceWord _ wordToInvert bitInvert32. 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'! sourceWord: sourceWord with: destinationWord ^sourceWord! ! !BitBltSimulation methodsFor: 'combination rules'! subWord: sourceWord with: destinationWord ^sourceWord - destinationWord! ! !BitBltSimulation methodsFor: 'combination rules' stamp: 'di 1/21/98 06:31'! tallyIntoMap: sourceWord with: 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 | colorMap = interpreterProxy nilObject ifTrue: [^ destinationWord "no op"]. destPixSize < 16 ifTrue: ["loop through all packed pixels." pixMask _ (1<> 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' stamp: 'di 12/30/97 20:45'! pickSourcePixels: nPix nullMap: nullMap srcMask: sourcePixMask destMask: destPixMask "This is intended to be expanded in-line; it merely calls the others" self inline: true. 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' stamp: 'di 12/30/97 20:46'! 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 | self inline: false. 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' stamp: 'di 12/30/97 20:46'! 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 | self inline: false. 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 12/30/97 20:46'! 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 | self inline: false. 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' stamp: 'di 12/30/97 20:07'! 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 | self inline: false. 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' stamp: 'di 12/30/97 20:10'! 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 | self inline: false. 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 methodsFor: 'translation support' stamp: 'di 1/21/98 23:01'! initBBOpTable self cCode: 'opTable[0+1] = (int)clearWordwith'. self cCode: 'opTable[1+1] = (int)bitAndwith'. self cCode: 'opTable[2+1] = (int)bitAndInvertwith'. self cCode: 'opTable[3+1] = (int)sourceWordwith'. self cCode: 'opTable[4+1] = (int)bitInvertAndwith'. self cCode: 'opTable[5+1] = (int)destinationWordwith'. self cCode: 'opTable[6+1] = (int)bitXorwith'. self cCode: 'opTable[7+1] = (int)bitOrwith'. self cCode: 'opTable[8+1] = (int)bitInvertAndInvertwith'. self cCode: 'opTable[9+1] = (int)bitInvertXorwith'. self cCode: 'opTable[10+1] = (int)bitInvertDestinationwith'. self cCode: 'opTable[11+1] = (int)bitOrInvertwith'. self cCode: 'opTable[12+1] = (int)bitInvertSourcewith'. self cCode: 'opTable[13+1] = (int)bitInvertOrwith'. self cCode: 'opTable[14+1] = (int)bitInvertOrInvertwith'. self cCode: 'opTable[15+1] = (int)destinationWordwith'. self cCode: 'opTable[16+1] = (int)destinationWordwith'. self cCode: 'opTable[17+1] = (int)destinationWordwith'. self cCode: 'opTable[18+1] = (int)addWordwith'. self cCode: 'opTable[19+1] = (int)subWordwith'. self cCode: 'opTable[20+1] = (int)rgbAddwith'. self cCode: 'opTable[21+1] = (int)rgbSubwith'. self cCode: 'opTable[22+1] = (int)rgbDiffwith'. self cCode: 'opTable[23+1] = (int)tallyIntoMapwith'. self cCode: 'opTable[24+1] = (int)alphaBlendwith'. self cCode: 'opTable[25+1] = (int)pixPaintwith'. self cCode: 'opTable[26+1] = (int)pixMaskwith'. self cCode: 'opTable[27+1] = (int)rgbMaxwith'. self cCode: 'opTable[28+1] = (int)rgbMinwith'. self cCode: 'opTable[29+1] = (int)rgbMinInvertwith'. self cCode: 'opTable[30+1] = (int)destinationWordwith'. self cCode: 'opTable[31+1] = (int)destinationWordwith'. ! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! BitBltSimulation class instanceVariableNames: ''! !BitBltSimulation class methodsFor: 'initialization'! initialize "BitBltSimulation initialize" self initializeRuleTable. "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' stamp: 'di 1/21/98 21:54'! initializeRuleTable "BitBltSimulation initializeRuleTable" OpTable _ #( "0" clearWord:with: "1" bitAnd:with: "2" bitAndInvert:with: "3" sourceWord:with: "4" bitInvertAnd:with: "5" destinationWord:with: "6" bitXor:with: "7" bitOr:with: "8" bitInvertAndInvert:with: "9" bitInvertXor:with: "10" bitInvertDestination:with: "11" bitOrInvert:with: "12" bitInvertSource:with: "13" bitInvertOr:with: "14" bitInvertOrInvert:with: "15" destinationWord:with: "16" destinationWord:with: "17" destinationWord:with: "18" addWord:with: "19" subWord:with: "20" rgbAdd:with: "21" rgbSub:with: "22" rgbDiff:with: "23" tallyIntoMap:with: "24" alphaBlend:with: "25" pixPaint:with: "26" pixMask:with: "27" rgbMax:with: "28" rgbMin:with: "29" rgbMinInvert:with: "30" destinationWord:with: "31" destinationWord:with: ). OpTableSize _ OpTable size + 1. "0-origin indexing" ! ! !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' stamp: 'di 12/29/97 20:00'! declareCVarsIn: aCCodeGenerator aCCodeGenerator var: 'opTable' declareC: 'int opTable[' , OpTableSize printString , ']'! ! BitBltSimulation subclass: #BitBltSimulator instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Squeak-Interpreter'! !BitBltSimulator methodsFor: 'all' stamp: 'di 12/30/97 09:23'! initBBOpTable opTable _ OpTable! ! !BitBltSimulator methodsFor: 'all' stamp: 'di 12/30/97 11:07'! mergeFn: arg1 with: arg2 ^ self perform: (opTable at: combinationRule+1) with: arg1 with: arg2! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! BitBltSimulator class instanceVariableNames: ''! !BitBltSimulator class methodsFor: 'translation' stamp: 'ikp 1/3/98 23:10'! translate: fileName doInlining: inlineFlag "Time millisecondsToRun: [ Interpreter translate: 'interp.c' doInlining: true. Smalltalk beep] 164760 167543 171826 174510" | 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.! ! MouseMenuController subclass: #BitEditor instanceVariableNames: 'scale squareForm color transparent ' classVariableNames: 'ColorButtons YellowButtonMenu YellowButtonMessages ' poolDictionaries: '' category: 'Graphics-Editors'! !BitEditor commentStamp: 'di 5/22/1998 16:32' prior: 0! BitEditor comment: 'I am a bit-magnifying tool for editing small Forms directly on the display screen. I continue to be active until the user points outside of my viewing area.'! !BitEditor methodsFor: 'initialize-release'! initialize super initialize. self initializeYellowButtonMenu! ! !BitEditor methodsFor: 'initialize-release'! release super release. squareForm release. squareForm _ nil! ! !BitEditor methodsFor: 'view access'! view: aView super view: aView. scale _ aView transformation scale. scale _ scale x rounded @ scale y rounded. squareForm _ Form extent: scale depth: aView model depth. squareForm fillBlack! ! !BitEditor methodsFor: 'basic control sequence'! controlInitialize super controlInitialize. Cursor crossHair show! ! !BitEditor methodsFor: 'basic control sequence'! controlTerminate Cursor normal show! ! !BitEditor methodsFor: 'control defaults'! isControlActive ^super isControlActive & sensor blueButtonPressed not & sensor keyboardPressed not! ! !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 methodsFor: 'menu messages'! accept "The edited information should now be accepted by the view." view accept! ! !BitEditor methodsFor: 'menu messages'! cancel "The edited informatin should be forgotten by the view." view cancel! ! !BitEditor methodsFor: 'menu messages' stamp: 'jm 3/27/98 14:52'! fileOut | fileName | fileName _ FillInTheBlank request: 'File name?' initialAnswer: 'Filename.form'. fileName isEmpty ifTrue: [^ self]. Cursor normal showWhile: [model writeOnFileNamed: fileName]. ! ! !BitEditor methodsFor: 'menu messages'! setColor: aColor "Set the color that the next edited dots of the model to be the argument, aSymbol. aSymbol can be any color changing message understood by a Form, such as white or black." color _ aColor pixelValueForDepth: model depth. squareForm fillColor: aColor. ! ! !BitEditor methodsFor: 'menu messages'! setTransparentColor squareForm fillColor: Color gray. color _ model transparentPixelValue! ! !BitEditor methodsFor: 'menu messages'! test view workingForm follow: [Sensor cursorPoint] while: [Sensor noButtonPressed]. Sensor waitNoButton! ! !BitEditor methodsFor: 'private'! initializeYellowButtonMenu self yellowButtonMenu: YellowButtonMenu yellowButtonMessages: YellowButtonMessages! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! BitEditor class instanceVariableNames: ''! !BitEditor class methodsFor: 'class initialization'! initialize "The Bit Editor is the only controller to override the use of the blue button with a different pop-up menu. Initialize this menu." YellowButtonMenu _ PopUpMenu labels: 'cancel accept file out test' lines: #(2 3). YellowButtonMessages _ #(cancel accept fileOut test) "BitEditor initialize"! ! !BitEditor class methodsFor: 'instance creation'! openOnForm: aForm "Create and schedule a BitEditor on the form aForm at its top left corner. Show the small and magnified view of aForm." | scaleFactor | scaleFactor _ 8 @ 8. ^self openOnForm: aForm at: (self locateMagnifiedView: aForm scale: scaleFactor) topLeft scale: scaleFactor! ! !BitEditor class methodsFor: 'instance creation'! openOnForm: aForm at: magnifiedLocation "Create and schedule a BitEditor on the form aForm at magnifiedLocation. Show the small and magnified view of aForm." ^self openOnForm: aForm at: magnifiedLocation scale: 8 @ 8! ! !BitEditor class methodsFor: 'instance creation'! openOnForm: aForm at: magnifiedLocation scale: scaleFactor "Create and schedule a BitEditor on the form aForm. Show the small and magnified view of aForm." | aScheduledView | aScheduledView _ self bitEdit: aForm at: magnifiedLocation scale: scaleFactor remoteView: nil. aScheduledView controller openDisplayAt: aScheduledView displayBox topLeft + (aScheduledView displayBox extent / 2)! ! !BitEditor class methodsFor: 'instance creation'! openScreenViewOnForm: aForm at: formLocation magnifiedAt: magnifiedLocation scale: scaleFactor "Create and schedule a BitEditor on the form aForm. Show the magnified view of aForm in a scheduled window." | smallFormView bitEditor savedForm r | smallFormView _ FormView new model: aForm. smallFormView align: smallFormView viewport topLeft with: formLocation. bitEditor _ self bitEdit: aForm at: magnifiedLocation scale: scaleFactor remoteView: smallFormView. bitEditor controller blueButtonMenu: nil blueButtonMessages: nil. savedForm _ Form fromDisplay: (r _ bitEditor displayBox expandBy: (0@23 corner: 0@0)). bitEditor controller startUp. savedForm displayOn: Display at: r topLeft. bitEditor release. smallFormView release. "BitEditor magnifyOnScreen."! ! !BitEditor class methodsFor: 'examples'! magnifyOnScreen "Bit editing of an area of the display screen. User designates a rectangular area that is magnified by 8 to allow individual screens dots to be modified. red button is used to set a bit to black and yellow button is used to set a bit to white. Editor is not scheduled in a view. Original screen location is updated immediately. This is the same as FormEditor magnify." | smallRect smallForm scaleFactor tempRect | scaleFactor _ 8 @ 8. smallRect _ Rectangle fromUser. smallRect isNil ifTrue: [^self]. smallForm _ Form fromDisplay: smallRect. tempRect _ self locateMagnifiedView: smallForm scale: scaleFactor. "show magnified form size until mouse is depressed" self openScreenViewOnForm: smallForm at: smallRect topLeft magnifiedAt: tempRect topLeft scale: scaleFactor "BitEditor magnifyOnScreen."! ! !BitEditor class methodsFor: 'examples'! magnifyWithSmall " Also try: BitEditor openOnForm: (Form extent: 32@32 depth: Display depth) BitEditor openOnForm: ((MaskedForm extent: 32@32 depth: Display depth) withTransparentPixelValue: -1) " "Open a BitEditor viewing an area on the screen which the user chooses" | area form | area _ Rectangle fromUser. area isNil ifTrue: [^ self]. form _ Form fromDisplay: area. self openOnForm: form "BitEditor magnifyWithSmall."! ! !BitEditor class methodsFor: 'private' stamp: 'di 1/16/98 15:46'! 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 _ StandardSystemView 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' stamp: 'jm 4/7/98 20:43'! 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 _ PluggableButtonView on: button getState: #isOn action: #turnOn. aSwitchView shortcutCharacter: ((nColors=3 ifTrue: ['xvn'] ifFalse: ['xn']) at: index); label: form; window: (0@0 extent: form extent); translateBy: (((index - 1) * 2 * form width) + leftOffset)@(form height // 2); borderWidth: 1. 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)). ! ! ArrayedCollection variableWordSubclass: #Bitmap instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Graphics-Support'! !Bitmap commentStamp: 'di 5/22/1998 16:32' prior: 0! Bitmap comment: 'My instances provide contiguous storage of bits, primarily to hold the graphical data of Forms. Forms and their subclasses provide the additional structural information as to how the bits should be interpreted in two dimensions.'! !Bitmap methodsFor: 'initialize-release'! fromByteStream: aStream "Initialize the array of bits by reading integers from the argument, aStream." aStream nextInto: self! ! !Bitmap methodsFor: 'filing' stamp: 'di 2/19/98 17:03'! compress: bm toByteArray: ba "Store a run-coded compression of the receiver into the byteArray ba, and return the last index stored into. ba is assumed to be large enough. The encoding is as follows... S {N D}*. S is the size of the original bitmap, followed by run-coded pairs. N is a run-length * 4 + data code. D, the data, depends on the data code... 0 skip N words, D is absent 1 N words with all 4 bytes = D (1 byte) 2 N words all = D (4 bytes) 3 N words follow in D (4N bytes) S and N are encoded as follows... 0-223 0-223 224-254 (0-30)*256 + next byte (0-7935) 255 next 4 bytes" | size k word j lowByte eqBytes i | self var: #bm declareC: 'int *bm'. self var: #ba declareC: 'unsigned char *ba'. size _ bm size. i _ self encodeInt: size in: ba at: 1. k _ 1. [k <= size] whileTrue: [word _ bm at: k. lowByte _ word bitAnd: 16rFF. eqBytes _ ((word >> 8) bitAnd: 16rFF) = lowByte and: [((word >> 16) bitAnd: 16rFF) = lowByte and: [((word >> 24) bitAnd: 16rFF) = lowByte]]. j _ k. [j < size and: [word = (bm at: j+1)]] "scan for = words..." whileTrue: [j _ j+1]. j > k ifTrue: ["We have two or more = words, ending at j" eqBytes ifTrue: ["Actually words of = bytes" i _ self encodeInt: j-k+1*4+1 in: ba at: i. ba at: i put: lowByte. i _ i+1] ifFalse: [i _ self encodeInt: j-k+1*4+2 in: ba at: i. i _ self encodeBytesOf: word in: ba at: i]. k _ j+1] ifFalse: ["Check for word of 4 = bytes" eqBytes ifTrue: ["Note 1 word of 4 = bytes" i _ self encodeInt: 1*4+1 in: ba at: i. ba at: i put: lowByte. i _ i+1. k _ k + 1] ifFalse: ["Finally, check for junk" [j < size and: [(bm at: j) ~= (bm at: j+1)]] "scan for ~= words..." whileTrue: [j _ j+1]. j = size ifTrue: [j _ j + 1]. "We have one or more unmatching words, ending at j-1" i _ self encodeInt: j-k*4+3 in: ba at: i. k to: j-1 do: [:m | i _ self encodeBytesOf: (bm at: m) in: ba at: i]. k _ j]]]. ^ i - 1 "number of bytes actually stored" " Space check: | n rawBytes myBytes b | n _ rawBytes _ myBytes _ 0. Form allInstancesDo: [:f | b _ f bits. n _ n + 1. rawBytes _ rawBytes + (b size*4). myBytes _ myBytes + (b compressToByteArray size)]. Array with: n with: rawBytes with: myBytes ColorForms: (116 230324 160318 ) Forms: (113 1887808 1325055 ) Integerity check: Form allInstances do: [:f | f bits = (Bitmap decompressFromByteArray: f bits compressToByteArray) ifFalse: [self halt]] Speed test: MessageTally spyOn: [Form allInstances do: [:f | Bitmap decompressFromByteArray: f bits compressToByteArray]] "! ! !Bitmap methodsFor: 'filing' stamp: 'di 2/19/98 16:59'! compressToByteArray "Return a run-coded compression of this bitmap into a byteArray" | byteArray lastByte | "Without skip codes, it is unlikely that the compressed bitmap will be any larger than was the original. The run-code cases are... N >= 1 words of equal bytes: 4N bytes -> 2 bytes (at worst 4 -> 2) N > 1 equal words: 4N bytes -> 5 bytes (at worst 8 -> 5) N > 1 unequal words: 4N bytes -> 4N + M, where M is the number of bytes required to encode the run length. The worst that can happen is that the method begins with unequal words, and than has interspersed occurrences of a word with equal bytes. Thus we require a run-length at the beginning, and after every interspersed word of equal bytes. However, each of these saves 2 bytes, so it must be followed by a run of 7936 or more (for which M jumps from 2 to 5) to add any extra overhead. Therefore the worst case is a series of runs of 7936 or more, with single interspersed words of equal bytes. At each break we save 2 bytes, but add 5. Thus the overhead would be no more than 5 + (S//7936*3)." byteArray _ ByteArray new: (self size*4) + 5 + (self size//7936*3). lastByte _ self compress: self toByteArray: byteArray. ^ byteArray copyFrom: 1 to: lastByte! ! !Bitmap methodsFor: 'filing' stamp: 'di 2/19/98 17:13'! decompress: bm fromByteArray: ba at: index "Decompress the body of a byteArray encoded by compressToByteArray (qv)... The format is simply a sequence of run-coded pairs, {N D}*. N is a run-length * 4 + data code. D, the data, depends on the data code... 0 skip N words, D is absent (could be used to skip from one raster line to the next) 1 N words with all 4 bytes = D (1 byte) 2 N words all = D (4 bytes) 3 N words follow in D (4N bytes) S and N are encoded as follows (see decodeIntFrom:)... 0-223 0-223 224-254 (0-30)*256 + next byte (0-7935) 255 next 4 bytes" "NOTE: If fed with garbage, this routine could read past the end of ba, but it should fail before writing past the ned of bm." | i code n anInt data end k pastEnd | self var: #bm declareC: 'int *bm'. self var: #ba declareC: 'unsigned char *ba'. i _ index. "byteArray read index" end _ ba size. k _ 1. "bitmap write index" pastEnd _ bm size + 1. [i <= end] whileTrue: ["Decode next run start N" anInt _ ba at: i. i _ i+1. anInt <= 223 ifFalse: [anInt <= 254 ifTrue: [anInt _ (anInt-224)*256 + (ba at: i). i _ i+1] ifFalse: [anInt _ 0. 1 to: 4 do: [:j | anInt _ (anInt bitShift: 8) + (ba at: i). i _ i+1]]]. n _ anInt >> 2. (k + n) > pastEnd ifTrue: [^ self primitiveFail]. code _ anInt bitAnd: 3. code = 0 ifTrue: ["skip"]. code = 1 ifTrue: ["n consecutive words of 4 bytes = the following byte" data _ ba at: i. i _ i+1. data _ data bitOr: (data bitShift: 8). data _ data bitOr: (data bitShift: 16). 1 to: n do: [:j | bm at: k put: data. k _ k+1]]. code = 2 ifTrue: ["n consecutive words = 4 following bytes" data _ 0. 1 to: 4 do: [:j | data _ (data bitShift: 8) bitOr: (ba at: i). i _ i+1]. 1 to: n do: [:j | bm at: k put: data. k _ k+1]]. code = 3 ifTrue: ["n consecutive words from the data..." 1 to: n do: [:m | data _ 0. 1 to: 4 do: [:j | data _ (data bitShift: 8) bitOr: (ba at: i). i _ i+1]. bm at: k put: data. k _ k+1]]]! ! !Bitmap methodsFor: 'filing' stamp: 'jm 2/15/98 17:27'! encodeBytesOf: anInt in: ba at: i "Copy the integer anInt into byteArray ba at index i, and return the next index" self inline: true. self var: #ba declareC: 'unsigned char *ba'. 0 to: 3 do: [:j | ba at: i+j put: (anInt >> (3-j*8) bitAnd: 16rFF)]. ^ i+4! ! !Bitmap methodsFor: 'filing' stamp: 'jm 2/12/98 17:32'! encodeInt: int "Encode the integer int as per encodeInt:in:at:, and return it as a ByteArray" | byteArray next | byteArray _ ByteArray new: 5. next _ self encodeInt: int in: byteArray at: 1. ^ byteArray copyFrom: 1 to: next - 1 ! ! !Bitmap methodsFor: 'filing' stamp: 'jm 2/15/98 17:26'! encodeInt: anInt in: ba at: i "Encode the integer anInt in byteArray ba at index i, and return the next index. The encoding is as follows... 0-223 0-223 224-254 (0-30)*256 + next byte (0-7935) 255 next 4 bytes" self inline: true. self var: #ba declareC: 'unsigned char *ba'. anInt <= 223 ifTrue: [ba at: i put: anInt. ^ i+1]. anInt <= 7935 ifTrue: [ba at: i put: anInt//256+224. ba at: i+1 put: anInt\\256. ^ i+2]. ba at: i put: 255. ^ self encodeBytesOf: anInt in: ba at: i+1! ! !Bitmap methodsFor: 'filing' stamp: 'di 2/11/98 21:34'! readCompressedFrom: strm "Decompress an old-style run-coded stream into this bitmap: [0 means end of runs] [n = 1..127] [(n+3) copies of next byte] [n = 128..191] [(n-127) next bytes as is] [n = 192..255] [(n-190) copies of next 4 bytes]" | n byte out outBuff bytes | out _ 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 copyFromByteArray: outBuff.! ! !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' stamp: 'jm 2/18/98 14:19'! writeOn: aStream "Store the array of bits onto the argument, aStream. A leading byte of 16r80 identifies this as compressed by compressToByteArray (qv)." | b | aStream nextPut: 16r80. b _ self compressToByteArray. aStream nextPutAll: (self encodeInt: b size); nextPutAll: b. ! ! !Bitmap methodsFor: 'printing'! printOn: aStream aStream nextPutAll: 'a Bitmap of length '. self size printOn: aStream! ! !Bitmap methodsFor: 'accessing'! bitPatternForDepth: depth "The raw call on BitBlt needs a Bitmap to represent this color. I already am Bitmap like. I am already adjusted for a specific depth. Interpret me as an array of (32/depth) Color pixelValues. BitBlt aligns the first element of this array with the top scanline of the destinationForm, the second with the second, and so on, cycling through the color array as necessary. 6/18/96 tk" ^ self! ! !Bitmap methodsFor: 'accessing'! byteAt: byteAddress "Extract a byte from a Bitmap. Note that this is a byte address and it is one-order. For repeated use, create an instance of BitBlt and use pixelAt:. See Form pixelAt: 7/1/96 tk" | lowBits | lowBits _ byteAddress - 1 bitAnd: 3. ^((self at: byteAddress - 1 - lowBits // 4 + 1) bitShift: (lowBits - 3) * 8) bitAnd: 16rFF! ! !Bitmap methodsFor: 'accessing'! byteAt: byteAddress put: byte "Insert a byte into a Bitmap. Note that this is a byte address and it is one-order. For repeated use, create an instance of BitBlt and use pixelAt:put:. See Form pixelAt:put: 7/1/96 tk" | longWord shift lowBits longAddr | lowBits _ byteAddress - 1 bitAnd: 3. longWord _ self at: (longAddr _ (byteAddress - 1 - lowBits) // 4 + 1). shift _ (3 - lowBits) * 8. longWord _ longWord - (longWord bitAnd: (16rFF bitShift: shift)) + (byte bitShift: shift). self at: longAddr put: longWord. ^ byte! ! !Bitmap methodsFor: 'accessing' stamp: 'di 10/4/97 11:56'! copyFromByteArray: byteArray "This method should work with either byte orderings" | long | (self size * 4) = byteArray size ifFalse: [self halt]. 1 to: byteArray size by: 4 do: [:i | long _ Integer byte1: (byteArray at: i+3) byte2: (byteArray at: i+2) byte3: (byteArray at: i+1) byte4: (byteArray at: i). self at: i+3//4 put: long]! ! !Bitmap methodsFor: 'accessing' stamp: 'tk 3/15/97'! pixelValueForDepth: depth "Self is being used to represent a single color. Answer bits that appear in ONE pixel of this color in a Bitmap of the given depth. The depth must be one of 1, 2, 4, 8, 16, or 32. Returns an integer. First pixel only. " ^ (self at: 1) bitAnd: (1 bitShift: depth) - 1! ! !Bitmap methodsFor: 'accessing'! primFill: aPositiveInteger "Fill the receiver, an indexable bytes or words object, with the given positive integer. The range of possible fill values is [0..255] for byte arrays and [0..(2^32 - 1)] for word arrays." self errorImproperStore.! ! !Bitmap methodsFor: 'accessing'! replaceFrom: start to: stop with: replacement startingAt: repStart "Primitive. This destructively replaces elements from start to stop in the receiver starting at index, repStart, in the collection, replacement. Answer the receiver. Range checks are performed in the primitive only. Optional. See Object documentation whatIsAPrimitive." super replaceFrom: start to: stop with: replacement startingAt: repStart! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Bitmap class instanceVariableNames: ''! !Bitmap class methodsFor: 'instance creation' stamp: 'di 2/9/98 16:02'! decodeIntFrom: s "Decode an integer in stream s as follows... 0-223 0-223 224-254 (0-30)*256 + next byte (0-7935) 255 next 4 bytes " | int | int _ s next. int <= 223 ifTrue: [^ int]. int <= 254 ifTrue: [^ (int-224)*256 + s next]. int _ s next. 1 to: 3 do: [:j | int _ (int bitShift: 8) + s next]. ^ int! ! !Bitmap class methodsFor: 'instance creation' stamp: 'di 2/12/98 14:34'! decompressFromByteArray: byteArray | s bitmap size | s _ ReadStream on: byteArray. size _ self decodeIntFrom: s. bitmap _ self new: size. bitmap decompress: bitmap fromByteArray: byteArray at: s position+1. ^ bitmap! ! !Bitmap class methodsFor: 'instance creation' stamp: 'di 2/11/98 21:11'! newFromStream: s | len | s next = 16r80 ifTrue: ["New compressed format" len _ self decodeIntFrom: s. ^ Bitmap decompressFromByteArray: (s nextInto: (ByteArray new: len))]. s skip: -1. len _ s nextInt32. len <= 0 ifTrue: ["Old compressed format" ^ (self new: len negated) readCompressedFrom: s] ifFalse: ["Old raw data format" ^ s nextInto: (self new: len)]! ! ContextPart variableSubclass: #BlockContext instanceVariableNames: 'nargs startpc home ' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Methods'! !BlockContext commentStamp: 'di 5/22/1998 16:32' prior: 0! BlockContext comment: 'My instances function similarly to instances of MethodContext, but they hold the dynamic state for execution of a block in Smalltalk. They access all temporary variables and the method sender via their home pointer, so that those values are effectively shared. Their indexable part is used to store their independent value stack during execution. My instance must hold onto its home in order to work. This can cause circularities if the home is also pointing (via a temp, perhaps) to the instance. In the rare event that this happens (as in SortedCollection sortBlock:) the message fixTemps will replace home with a copy of home, thus defeating the sharing of temps but, nonetheless, eliminating the circularity.'! !BlockContext methodsFor: 'initialize-release'! home: aContextPart startpc: position nargs: anInteger "This is the initialization message. The receiver has been initialized with the correct size only." home _ aContextPart. startpc _ position. nargs _ anInteger! ! !BlockContext methodsFor: 'accessing'! fixTemps "Fix the values of the temporary variables used in the block that are ordinarily shared with the method in which the block is defined." home _ home copy. home swapSender: nil! ! !BlockContext methodsFor: 'accessing'! hasMethodReturn "Answer whether the receiver has a return ('^') in its code." | method scanner end | method _ self method. "Determine end of block from long jump preceding it" end _ (method at: startpc-2)\\16-4*256 + (method at: startpc-1) + startpc - 1. scanner _ InstructionStream new method: method pc: startpc. scanner scanFor: [:byte | (byte between: 120 and: 124) or: [scanner pc > end]]. ^scanner pc <= end! ! !BlockContext methodsFor: 'accessing'! home "Answer the context in which the receiver was defined." ^home! ! !BlockContext methodsFor: 'accessing'! method "Answer the compiled method in which the receiver was defined." ^home method! ! !BlockContext methodsFor: 'accessing'! numArgs ^nargs! ! !BlockContext methodsFor: 'accessing'! receiver "Refer to the comment in ContextPart|receiver." ^home receiver! ! !BlockContext methodsFor: 'accessing'! tempAt: index "Refer to the comment in ContextPart|tempAt:." ^home at: index! ! !BlockContext methodsFor: 'accessing'! tempAt: index put: value "Refer to the comment in ContextPart|tempAt:put:." ^home at: index put: value! ! !BlockContext methodsFor: 'evaluating' stamp: 'jm 2/19/98 13:19'! ifError: errorHandlerBlock "Evaluate the block represented by the receiver. If an error occurs the given is evaluated with the error message and the receiver as parameters. The error handler block may return a value to be used if the receiver block gets an error. The receiver should not contain an explicit return statement as this would leave an obsolete error handler hanging around." "Examples: [1 whatsUpDoc] ifError: [:err :rcvr | ^ 'huh?']. [1 / 0] ifError: [:err :rcvr | 'division by 0' = err ifTrue: [^ Float inf] ifFalse: [self error: err]] " | lastHandler val activeProcess | activeProcess _ Processor activeProcess. lastHandler _ activeProcess errorHandler. activeProcess errorHandler: [:aString :aReceiver | activeProcess errorHandler: lastHandler. ^ errorHandlerBlock value: aString value: aReceiver]. val _ self value. activeProcess errorHandler: lastHandler. ^ val ! ! !BlockContext methodsFor: 'evaluating'! value "Primitive. Evaluate the block represented by the receiver. Fail if the block expects any arguments or if the block is already being executed. Optional. No Lookup. See Object documentation whatIsAPrimitive." ^self valueWithArguments: #()! ! !BlockContext methodsFor: 'evaluating'! value: arg "Primitive. Evaluate the block represented by the receiver. Fail if the block expects other than one argument or if the block is already being executed. Optional. No Lookup. See Object documentation whatIsAPrimitive." ^self valueWithArguments: (Array with: arg)! ! !BlockContext methodsFor: 'evaluating'! value: arg1 ifError: aBlock "Evaluate the block represented by the receiver. If an error occurs aBlock is evaluated with the error message and the receiver as parameters. The receiver should not contain an explicit return statement as this would leave an obsolete error handler hanging around." | lastHandler val activeProcess | activeProcess _ Processor activeProcess. lastHandler _ activeProcess errorHandler. activeProcess errorHandler: [:aString :aReceiver | activeProcess errorHandler: lastHandler. ^ aBlock value: aString value: aReceiver]. val _ self value: arg1. activeProcess errorHandler: lastHandler. ^ val! ! !BlockContext methodsFor: 'evaluating'! value: arg1 value: arg2 "Primitive. Evaluate the block represented by the receiver. Fail if the block expects other than two arguments or if the block is already being executed. Optional. See Object documentation whatIsAPrimitive." ^self valueWithArguments: (Array with: arg1 with: arg2)! ! !BlockContext methodsFor: 'evaluating'! value: arg1 value: arg2 value: arg3 "Primitive. Evaluate the block represented by the receiver. Fail if the block expects other than three arguments or if the block is already being executed. Optional. See Object documentation whatIsAPrimitive." ^self valueWithArguments: (Array with: arg1 with: arg2 with: arg3)! ! !BlockContext methodsFor: 'evaluating' stamp: 'di 11/30/97 09:19'! value: arg1 value: arg2 value: arg3 value: arg4 "Primitive. Evaluate the block represented by the receiver. Fail if the block expects other than three arguments or if the block is already being executed. Optional. See Object documentation whatIsAPrimitive." ^self valueWithArguments: (Array with: arg1 with: arg2 with: arg3 with: arg4)! ! !BlockContext methodsFor: 'evaluating'! 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." 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: 'controlling'! whileFalse "Ordinarily compiled in-line, and therefore not overridable. This is in case the message is sent to other than a literal block. Evaluate the receiver, as long as its value is false." ^ [self value] whileFalse: []! ! !BlockContext methodsFor: 'controlling'! whileFalse: aBlock "Ordinarily compiled in-line, and therefore not overridable. This is in case the message is sent to other than a literal block. Evaluate the argument, aBlock, as long as the value of the receiver is false." ^ [self value] whileFalse: [aBlock value]! ! !BlockContext methodsFor: 'controlling'! whileTrue "Ordinarily compiled in-line, and therefore not overridable. This is in case the message is sent to other than a literal block. Evaluate the receiver, as long as its value is true." ^ [self value] whileTrue: []! ! !BlockContext methodsFor: 'controlling'! whileTrue: aBlock "Ordinarily compiled in-line, and therefore not overridable. This is in case the message is sent to other than a literal block. Evaluate the argument, aBlock, as long as the value of the receiver is true." ^ [self value] whileTrue: [aBlock value]! ! !BlockContext methodsFor: 'scheduling'! fork "Create and schedule a Process running the code in the receiver." self newProcess resume! ! !BlockContext methodsFor: 'scheduling'! forkAt: priority "Create and schedule a Process running the code in the receiver. The priority of the process is the argument, priority." | forkedProcess | forkedProcess _ self newProcess. forkedProcess priority: priority. forkedProcess resume! ! !BlockContext methodsFor: 'scheduling'! newProcess "Answer a Process running the code in the receiver. The process is not scheduled." ^Process forContext: [self value. Processor terminateActive] priority: Processor activePriority! ! !BlockContext methodsFor: 'scheduling'! newProcessWith: anArray "Answer a Process running the code in the receiver. The receiver's block arguments are bound to the contents of the argument, anArray. The process is not scheduled." ^Process forContext: [self valueWithArguments: anArray. Processor terminateActive] priority: Processor activePriority! ! !BlockContext methodsFor: 'instruction decoding'! blockReturnTop "Simulate the interpreter's action when a ReturnTopOfStack bytecode is encountered in the receiver." | save dest | save _ home. "Needed because return code will nil it" dest _ self return: self pop to: self sender. home _ save. sender _ nil. ^dest! ! !BlockContext methodsFor: 'printing'! printOn: aStream home == nil ifTrue: [^aStream nextPutAll: 'a BlockContext with home=nil']. aStream nextPutAll: '[] in '. super printOn: aStream! ! !BlockContext methodsFor: 'private' stamp: 'tk 4/16/1998 15:38'! cannotReturn: result "The receiver tried to return result to a method context that no longer exists." Debugger openContext: thisContext label: 'Block cannot return' contents: thisContext shortStack. ! ! !BlockContext methodsFor: 'private'! startpc "for use by the System Tracer only" ^startpc! ! !BlockContext methodsFor: 'private'! valueError self error: 'Incompatible number of args, or already active'! ! !BlockContext methodsFor: 'system simulation'! pushArgs: args from: sendr "Simulates action of the value primitive." args size ~= nargs ifTrue: [^self error: 'incorrect number of args']. stackp _ 0. args do: [:arg | self push: arg]. sender _ sendr. pc _ startpc! ! ParseNode subclass: #BlockNode instanceVariableNames: 'arguments statements returns nArgsNode size remoteCopyNode ' classVariableNames: '' poolDictionaries: '' category: 'System-Compiler'! !BlockNode commentStamp: 'di 5/22/1998 16:32' prior: 0! BlockNode comment: 'I represent a bracketed block with 0 or more arguments and 1 or more statements. If I am initialized with no statements, I create one. I have a flag to tell whether my last statement returns a value from the enclosing method. My last three fields remember data needed for code generation. I can emit for value in the usual way, in which case I create a literal method (actually a context remotely copied) to be evaluated by sending it value: at run time. Or I can emit code to be evaluated in line; this only happens at the top level of a method and in conditionals and while-loops, none of which have arguments.'! !BlockNode methodsFor: 'initialize-release'! arguments: argNodes statements: statementsCollection returns: returnBool from: encoder "Compile." arguments _ argNodes. statements _ statementsCollection size > 0 ifTrue: [statementsCollection] ifFalse: [argNodes size > 0 ifTrue: [statementsCollection copyWith: arguments last] ifFalse: [Array with: NodeNil]]. returns _ returnBool! ! !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: 'accessing'! arguments: argNodes "Decompile." arguments _ argNodes! ! !BlockNode methodsFor: 'accessing'! firstArgument ^ arguments first! ! !BlockNode methodsFor: 'accessing'! numberOfArguments ^arguments size! ! !BlockNode methodsFor: 'accessing'! returnLast self returns ifFalse: [returns _ true. statements at: statements size put: statements last asReturnNode]! ! !BlockNode methodsFor: 'accessing'! returnSelfIfNoOther self returns ifFalse: [statements last == NodeSelf ifFalse: [statements add: NodeSelf]. self returnLast]! ! !BlockNode methodsFor: 'testing'! canBeSpecialArgument "Can I be an argument of (e.g.) ifTrue:?" ^arguments size = 0! ! !BlockNode methodsFor: 'testing'! isComplex ^statements size > 1 or: [statements size = 1 and: [statements first isComplex]]! ! !BlockNode methodsFor: 'testing'! isJust: node returns ifTrue: [^false]. ^statements size = 1 and: [statements first == node]! ! !BlockNode methodsFor: 'testing'! isJustCaseError ^ statements size = 1 and: [statements first isMessage: #caseError receiver: [:r | r==NodeSelf] arguments: nil]! ! !BlockNode methodsFor: 'testing'! isQuick ^ statements size = 1 and: [statements first isVariableReference or: [statements first isSpecialConstant]]! ! !BlockNode methodsFor: 'testing'! returns ^returns or: [statements last isReturningIf]! ! !BlockNode methodsFor: 'code generation'! code ^statements first code! ! !BlockNode methodsFor: 'code generation'! emitExceptLast: stack on: aStream | nextToLast | nextToLast _ statements size - 1. nextToLast < 1 ifTrue: [^ self]. "Only one statement" 1 to: nextToLast - 1 do: [:i | (statements at: i) emitForEffect: stack on: aStream]. (returns "Don't pop before a return" and: [(statements at: nextToLast) prefersValue]) ifTrue: [(statements at: nextToLast) emitForValue: stack on: aStream] ifFalse: [(statements at: nextToLast) emitForEffect: stack on: aStream]! ! !BlockNode methodsFor: 'code generation'! emitForEvaluatedEffect: stack on: aStream self returns ifTrue: [self emitForEvaluatedValue: stack on: aStream. stack pop: 1] ifFalse: [self emitExceptLast: stack on: aStream. statements last emitForEffect: stack on: aStream]! ! !BlockNode methodsFor: 'code generation'! emitForEvaluatedValue: stack on: aStream self emitExceptLast: stack on: aStream. statements last emitForValue: stack on: aStream. (returns and: [statements size > 1 and: [(statements at: statements size-1) prefersValue]]) ifTrue: [stack pop: 1] "compensate for elided pop prior to return"! ! !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: 'code generation'! sizeExceptLast: encoder | codeSize nextToLast | nextToLast _ statements size - 1. nextToLast < 1 ifTrue: [^ 0]. "Only one statement" codeSize _ 0. 1 to: nextToLast - 1 do: [:i | codeSize _ codeSize + ((statements at: i) sizeForEffect: encoder)]. ^ (returns "Don't pop before a return" and: [(statements at: nextToLast) prefersValue]) ifTrue: [codeSize + ((statements at: nextToLast) sizeForValue: encoder)] ifFalse: [codeSize + ((statements at: nextToLast) sizeForEffect: encoder)]! ! !BlockNode methodsFor: 'code generation'! sizeForEvaluatedEffect: encoder self returns ifTrue: [^self sizeForEvaluatedValue: encoder]. ^(self sizeExceptLast: encoder) + (statements last sizeForEffect: encoder)! ! !BlockNode methodsFor: 'code generation'! sizeForEvaluatedValue: encoder ^(self sizeExceptLast: encoder) + (statements last sizeForValue: encoder)! ! !BlockNode methodsFor: 'code generation'! sizeForValue: encoder nArgsNode _ encoder encodeLiteral: arguments size. remoteCopyNode _ encoder encodeSelector: #blockCopy:. size _ (self sizeForEvaluatedValue: encoder) + (self returns ifTrue: [0] ifFalse: [1]). "endBlock" arguments _ arguments collect: "Chance to prepare debugger remote temps" [:arg | arg asStorableNode: encoder]. arguments do: [:arg | size _ size + (arg sizeForStorePop: encoder)]. ^1 + (nArgsNode sizeForValue: encoder) + (remoteCopyNode size: encoder args: 1 super: false) + 2 + size! ! !BlockNode methodsFor: 'printing'! printArgumentsOn: aStream indent: level arguments size = 0 ifFalse: [arguments do: [:arg | aStream nextPut: $:. aStream nextPutAll: arg key. aStream space]. aStream nextPutAll: '| '. "If >0 args and >1 statement, put all statements on separate lines" statements size > 1 ifTrue: [aStream crtab: level]]! ! !BlockNode methodsFor: 'printing'! printOn: aStream indent: level statements size <= 1 ifFalse: [aStream crtab: level]. aStream nextPut: $[. self printArgumentsOn: aStream indent: level. self printStatementsOn: aStream indent: level. aStream nextPut: $]! ! !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: 'equation translation'! statements ^statements! ! !BlockNode methodsFor: 'equation translation'! statements: val statements _ val! ! !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! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! BlockNode class instanceVariableNames: ''! !BlockNode class methodsFor: 'instance creation'! withJust: aNode "Used to create a simple block, eg: withJust: NodeNil" ^ self new statements: (Array with: aNode) returns: false! ! AlignmentMorph subclass: #BookMorph instanceVariableNames: 'pageSize pages currentPage copyContents newPagePrototype ' classVariableNames: 'PageFlipSoundOn ' poolDictionaries: '' category: 'Morphic-Widgets'! !BookMorph methodsFor: 'initialization' stamp: 'sw 5/6/1998 10:09'! addDressing | controlColor pageControls | self addMorph: (Morph new color: color; extent: 10@10). "spacer" controlColor _ (color saturation > 0.1) ifTrue: [color lighter] ifFalse: [color darker]. pageControls _ Preferences noviceMode ifTrue: [self makeKidsPageControlsColored: controlColor] ifFalse: [self makeAuthoringPageControlsColored: controlColor]. pageControls borderWidth: 1; inset: 4. self addMorph: pageControls! ! !BookMorph methodsFor: 'initialization' stamp: 'sw 10/3/97 18:49'! addKidsDressing | controlColor pageControls | self addMorph: (Morph new color: color; extent: 10@10). "spacer" controlColor _ (color saturation > 0.1) ifTrue: [color lighter] ifFalse: [color darker]. pageControls _ self makeKidsPageControlsColored: controlColor. pageControls borderWidth: 1; inset: 4. self addMorph: pageControls! ! !BookMorph methodsFor: 'initialization' stamp: 'sw 10/18/97 18:03'! beThoroughlyRepelling submorphs do: [:m | m beRepelling]. self beRepelling! ! !BookMorph methodsFor: 'initialization' stamp: 'sw 8/16/97 13:39'! closeCurrentPageToDragNDrop currentPage ifNotNil: [currentPage openToDragNDrop: false]! ! !BookMorph methodsFor: 'initialization' stamp: 'jm 9/24/97 08:48'! initialize super initialize. self setInitialState. pages _ OrderedCollection new. self addDressing. BookMorph turnOffSoundWhile: [self insertPage]. ! ! !BookMorph methodsFor: 'initialization' stamp: 'jm 11/17/97 17:26'! newPages: pageList currentIndex: index "Replace all my pages with the given list of BookPageMorphs. Make the current page be the page with the given index." pages _ pages species new. pages addAll: pageList. pages isEmpty ifTrue: [^ self insertPage]. self goToPage: index. ! ! !BookMorph methodsFor: 'initialization' stamp: 'sw 8/5/97 20:52'! removeEverything currentPage _ nil. pages _ OrderedCollection new. super removeAllMorphs! ! !BookMorph methodsFor: 'initialization' stamp: 'sw 8/12/97 21:31'! setInitialState orientation _ #vertical. centering _ #topLeft. hResizing _ #shrinkWrap. vResizing _ #shrinkWrap. inset _ 5. color _ Color white. pageSize _ 160@300. openToDragNDrop _ true. copyContents _ false.! ! !BookMorph methodsFor: 'accessing' stamp: 'tk 12/18/97 09:44'! allNonSubmorphMorphs "Return a collection containing all morphs in this morph which are not currently in the submorph containment hierarchy (put in primarily for bookmorphs)" ^ pages copyWithout: currentPage! ! !BookMorph methodsFor: 'accessing' stamp: 'sw 11/5/97 13:37'! currentPage ^ currentPage! ! !BookMorph methodsFor: 'accessing' stamp: 'sw 9/20/97 20:29'! pageNamed: aName ^ pages detect: [:p | p externalName = aName] ifNone: [nil]! ! !BookMorph methodsFor: 'accessing'! pages ^ pages ! ! !BookMorph methodsFor: 'accessing' stamp: 'tk 8/13/97 17:01'! pages: aMorphList pages _ aMorphList asOrderedCollection. "John: While it is tempting to put this code here, it is wrong. pages size > 0 ifTrue: [currentPage _ pages first] ifFalse: [self insertPage]. If currentPage is not page 1, then when it comes back in, two pages are shown at once!! Just trust the copying mechanism and let currentPage be copied correctly. --Ted."! ! !BookMorph methodsFor: 'accessing'! pageSize: aPoint pageSize _ aPoint. ! ! !BookMorph methodsFor: 'dropping/grabbing' stamp: 'sw 10/18/97 18:03'! 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: 'sw 10/18/97 18:19'! 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: 'zooming page turns' stamp: 'di 1/21/98 07:06'! showPageTurningFeedbackFromOrigin: oldOrigin ascending: ascending ascending ifNotNil: [self playPageFlipSound. (PageFlipSoundOn and: [oldOrigin ~~ nil]) ifTrue: [Display wipeImage: currentPage imageForm at: oldOrigin delta: (ascending ifTrue: [0@-4] ifFalse: [0@4])]]! ! !BookMorph methodsFor: 'menu' stamp: 'jm 5/15/1998 06:45'! addBookMenuItemsTo: aCustomMenu hand: aHandMorph aCustomMenu add: (copyContents ifTrue: ['don''t be parts bin when closed'] ifFalse: ['be parts bin when closed']) action: #toggleCopyContents. 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:. aCustomMenu add: 'sort pages' action: #sortPages:. aCustomMenu add: 'save as new-page prototype' action: #setNewPagePrototype. newPagePrototype ifNotNil: [ aCustomMenu add: 'clear new-page prototype' action: #clearNewPagePrototype]. (aHandMorph classOfPasteBuffer isKindOf: PasteUpMorph class) ifTrue: [aCustomMenu add: 'paste book page' action: #pasteBookPage] ! ! !BookMorph methodsFor: 'menu' stamp: 'sw 9/13/97 23:24'! addCustomMenuItems: aCustomMenu hand: aHandMorph super addCustomMenuItems: aCustomMenu hand: aHandMorph. self addBookMenuItemsTo: aCustomMenu hand: aHandMorph "This factoring allows subclasses, such as TabbedPaletteMorph, to choose different items and different wording and still use the super call for the rest of the metamenu"! ! !BookMorph methodsFor: 'menu' stamp: 'jm 5/14/1998 20:18'! clearNewPagePrototype "Clear the new page prototype." newPagePrototype _ nil. ! ! !BookMorph methodsFor: 'menu' stamp: 'sw 10/2/97 15:22'! configureForKids super configureForKids. pages do: [:aPage | aPage configureForKids].! ! !BookMorph methodsFor: 'menu' stamp: 'sw 8/15/97 22:01'! deleteControls "If the receiver has an element answering to the name 'Page Controls', delete it" | controls | (controls _ self findSubmorphThat: [:m | m externalName = 'Page Controls'] ifAbsent: [nil]) ifNotNil: [controls delete. self changed]! ! !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' stamp: 'sw 8/4/97 12:05'! firstPage self goToPage: 1. ! ! !BookMorph methodsFor: 'menu' stamp: 'sw 8/9/97 00:02'! insertPage self insertPageColored: self color ! ! !BookMorph methodsFor: 'menu' stamp: 'sw 10/12/97 21:48'! insertPage: aPage pageSize: aPageSize ^ self insertPage: aPage pageSize: aPageSize atIndex: (pages size + 1)! ! !BookMorph methodsFor: 'menu' stamp: 'sw 5/14/1998 11:06'! insertPage: aPage pageSize: aPageSize atIndex: anIndex | sz predecessor | sz _ aPageSize ifNil: [currentPage == nil ifTrue: [pageSize] ifFalse: [currentPage extent]] ifNotNil: [aPageSize]. aPage extent: sz. ((pages isEmpty | anIndex == nil) or: [anIndex > pages size]) ifTrue: [pages add: aPage] ifFalse: [anIndex <= 1 ifTrue: [pages addFirst: aPage] ifFalse: [predecessor _ anIndex == nil ifTrue: [currentPage] ifFalse: [pages at: anIndex]. self pages add: aPage after: predecessor]]. self goToPageMorph: aPage ! ! !BookMorph methodsFor: 'menu' stamp: 'jm 5/14/1998 20:37'! insertPageColored: aColor | sz newPage bw bc | currentPage == nil ifTrue: [sz _ pageSize. bw _ 0. bc _ Color blue muchLighter] ifFalse: [sz _ currentPage extent. bw _ currentPage borderWidth. bc _ currentPage borderColor]. newPagePrototype ifNil: [ newPage _ PasteUpMorph new extent: sz; color: aColor. newPage borderWidth: bw; borderColor: bc] ifNotNil: [ newPage _ newPagePrototype fullCopy]. newPage resizeToFit: false. pages isEmpty ifTrue: [pages add: (currentPage _ newPage)] ifFalse: [pages add: newPage after: currentPage]. self nextPage. ! ! !BookMorph methodsFor: 'menu' stamp: 'sw 10/2/97 21:31'! insertPageShowingString: aString fontName: aName fontSize: aSize "For creating text content on a page of a BookMorph, from cold code. Sadly, can't yet specify font..." | aTextMorph tempContents | self insertPage. aTextMorph _ TextMorph new. aTextMorph extent: (self extent - (12@0)). aName ifNotNil: [aTextMorph string: aString fontName: aName size: aSize] ifNil: [aTextMorph contentsWrapped: aString]. tempContents _ aTextMorph contents. aTextMorph contentsWrapped: '-'. aTextMorph extent: (self extent - (12@0)). aTextMorph contentsWrapped: tempContents. currentPage addMorph: aTextMorph.! ! !BookMorph methodsFor: 'menu' stamp: 'sw 9/15/97 01:05'! insertPageShowingString: aString usingFont: aFont "For creating text content on a page of a BookMorph, from cold code. Sadly, can't yet specify font..." self insertPage. currentPage addMorph: (TextMorph new extent: (self extent - (12@0)); contentsWrapped: aString)! ! !BookMorph methodsFor: 'menu' stamp: 'jm 5/15/1998 06:46'! invokeBookMenu "Answer a menu to be popped up from the book-control panel" | aMenu | aMenu _ CustomMenu new. aMenu addList: #( " ('border color...' changeBorderColor:) ('border width...' changeBorderWidth:) ('lock' lock)" ('make bookmark' bookmarkForThisPage) ('sort pages' sortPages:) ('remove control panel' deleteControls) ). (self primaryHand classOfPasteBuffer isKindOf: PasteUpMorph class) ifTrue: [aMenu add: 'paste book page' action: #pasteBookPage]. aMenu add: 'save as new-page prototype' action: #setNewPagePrototype. newPagePrototype ifNotNil: [ aMenu add: 'clear new-page prototype' action: #clearNewPagePrototype]. aMenu add: (openToDragNDrop ifTrue: ['close'] ifFalse: ['open']) , ' dragNdrop' action: #openCloseDragNDrop. aMenu invokeOn: self defaultSelection: nil! ! !BookMorph methodsFor: 'menu' stamp: 'sw 8/4/97 12:05'! lastPage self goToPage: pages size ! ! !BookMorph methodsFor: 'menu' stamp: 'sw 8/5/97 21:13'! newTextMorph "Create a new, empty TextMorph that can be placed in this book." self isInWorld ifTrue: [self primaryHand attachMorph: (TextMorph new extent: currentPage width@30)]. ! ! !BookMorph methodsFor: 'menu' stamp: 'sw 10/1/97 00:18'! nextPage | i | currentPage == nil ifTrue: [^ self goToPage: 1]. i _ (pages indexOf: currentPage ifAbsent: [0]) + 1. self goToPage: i. ! ! !BookMorph methodsFor: 'menu' stamp: 'sw 10/2/97 21:39'! pageControls: evt | buttonPanel | buttonPanel _ self makePageControls. buttonPanel borderWidth: 1; inset: 4. evt hand attachMorph: buttonPanel. ! ! !BookMorph methodsFor: 'menu' stamp: 'sw 5/14/1998 11:04'! pasteBookPage | aPage | aPage _ self primaryHand objectToPaste. self insertPage: aPage pageSize: aPage extent atIndex: ((pages indexOf: currentPage) - 1). "self goToPageMorph: aPage"! ! !BookMorph methodsFor: 'menu' stamp: 'sw 8/11/97 23:40'! previousPage | i | i _ (pages indexOf: currentPage ifAbsent: [2]) - 1. self goToPage: i. ! ! !BookMorph methodsFor: 'menu' stamp: 'jm 5/14/1998 20:17'! setNewPagePrototype "Record the current page as the prototype to be copied when inserting new pages." currentPage ifNotNil: [newPagePrototype _ currentPage fullCopy]. ! ! !BookMorph methodsFor: 'menu' stamp: 'jm 11/17/97 17:33'! sortPages: evt | sorter | sorter _ BookPageSorterMorph new forBook: self. sorter pageHolder cursor: (pages indexOf: currentPage ifAbsent: [0]). evt == nil ifTrue: [self world addMorphFront: sorter] ifFalse: [evt hand attachMorph: sorter]. ! ! !BookMorph methodsFor: 'menu' stamp: 'jm 7/8/97 10:44'! toggleCopyContents "Toggle this morph's ability to behave like a parts bin when closed." copyContents _ copyContents not. ! ! !BookMorph methodsFor: 'private' stamp: 'sw 5/13/1998 11:46'! authorControlSpecs ^ #( ( '<--' firstPage 'Go to first page') ( '<-' previousPage 'Go to previous page') ('-' deletePage 'Delete current page') ('<<>>' invokeBookMenu 'Get a menu') ('+' insertPage 'Insert new page after this one') ('->' nextPage 'Go to next page') ( '-->' lastPage 'Go to final page'))! ! !BookMorph methodsFor: 'private' stamp: 'sw 8/12/97 12:16'! bookmarkForThisPage | b | b _ SimpleButtonMorph new target: self. b actionSelector: #goToPageMorph:. b label: 'Bookmark'. b arguments: (Array with: currentPage). self primaryHand attachMorph: b ! ! !BookMorph methodsFor: 'private' stamp: 'sw 5/13/1998 15:11'! goToPage: pageNumber | pageIndex oldOrigin aWorld oldRect oldPageNumber ascending | pages isEmpty ifTrue: [^ self]. oldPageNumber _ pages indexOf: currentPage ifAbsent: [1]. pageIndex _ pageNumber asInteger. pageNumber < 1 ifTrue: [pageIndex _ pages size]. pageNumber > pages size ifTrue: [pageIndex _ 1]. ascending _ oldPageNumber < pageIndex. oldPageNumber = pageIndex ifTrue: [ascending _ nil]. (aWorld _ self world) ifNotNil: [self primaryHand newKeyboardFocus: nil]. currentPage ifNotNil: [(oldRect _ currentPage screenRectangle) ifNotNil: [oldOrigin _ oldRect origin]. currentPage releaseCachedState; delete]. currentPage _ pages at: pageIndex. self addMorphBack: currentPage. aWorld ifNotNil: [self world startSteppingSubmorphsOf: currentPage. self showPageTurningFeedbackFromOrigin: oldOrigin ascending: ascending]! ! !BookMorph methodsFor: 'private' stamp: 'jm 7/1/97 16:43'! goToPageMorph: aMorph | i | i _ pages indexOf: aMorph. i = 0 ifFalse: [self goToPage: i]. ! ! !BookMorph methodsFor: 'private' stamp: 'sw 4/30/1998 12:16'! goToPageMorphNamed: aName | aMorph | aMorph _ pages detect: [:p | p externalName = aName] ifNone: [^ self beep]. self goToPageMorph: aMorph! ! !BookMorph methodsFor: 'private' stamp: 'di 5/6/1998 21:10'! insertPageLabel: labelString morphs: morphList | m c labelAllowance | self insertPage. labelString ifNotNil: [m _ (TextMorph new extent: currentPage width@20; contents: labelString). m lock. m position: currentPage position + (((currentPage width - m width) // 2) @ 5). currentPage addMorph: m. labelAllowance _ 40] ifNil: [labelAllowance _ 0]. "use a column to align the given morphs, then add them to the page" c _ AlignmentMorph newColumn centering: #center. c addAllMorphs: morphList. c position: currentPage position + (0 @ labelAllowance). currentPage addAllMorphs: morphList. ^ currentPage ! ! !BookMorph methodsFor: 'private' stamp: 'di 5/6/1998 21:10'! insertPageLabel: labelString morphs: firstColMorphs secondColumnMorphs: secondColMorphs | c | self insertPageLabel: labelString morphs: firstColMorphs. "use a column to align the given morphs, then add them to the page" c _ AlignmentMorph newColumn centering: #center. c addAllMorphs: secondColMorphs. c position: currentPage position + (100@40). currentPage addAllMorphs: secondColMorphs. ! ! !BookMorph methodsFor: 'private' stamp: 'sw 10/18/97 18:03'! kidControlSpecs true ifTrue: [^ self minimalKidsControlSpecs]. ^ #( ( '<--' firstPage 'Go to first page') ( '<-' previousPage 'Go to previous page') ('->' nextPage 'Go to next page') ( '-->' lastPage 'Go to final page'))! ! !BookMorph methodsFor: 'private' stamp: 'sw 10/2/97 18:49'! makeAuthoringPageControlsColored: aColor ^ self makePageControlsFrom: self authorControlSpecs color: aColor! ! !BookMorph methodsFor: 'private' stamp: 'sw 10/2/97 18:50'! makeKidsPageControlsColored: aColor ^ self makePageControlsFrom: self kidControlSpecs color: aColor! ! !BookMorph methodsFor: 'private' stamp: 'sw 5/21/1998 18:08'! makeMinimalControlsWithColor: aColor title: aString | aButton aColumn aRow but | aButton _ SimpleButtonMorph new target: self; borderColor: Color black; color: aColor; borderWidth: 0. aColumn _ AlignmentMorph newColumn. aColumn color: aButton color; borderWidth: 0; inset: 0. aColumn hResizing: #shrinkWrap; vResizing: #shrinkWrap; extent: 5@5. aRow _ AlignmentMorph newRow. aRow color: aButton color; borderWidth: 0; inset: 0. aRow hResizing: #shrinkWrap; vResizing: #shrinkWrap; extent: 5@5. aRow addMorphBack: (but _ aButton fullCopy label: ' < ' ; actionSelector: #previousPage). but setBalloonText: 'Go to previous page'. aRow addMorphBack: (StringMorph contents: aString) lock. aRow addMorphBack: (but _ aButton fullCopy label: ' > ' ; actionSelector: #nextPage). but setBalloonText: 'Go to next page'. aColumn addMorphBack: aRow. aColumn setNameTo: 'Page Controls'. ^ aColumn! ! !BookMorph methodsFor: 'private' stamp: 'di 5/6/1998 21:10'! makePageControls | b c r | b _ SimpleButtonMorph new target: self; borderColor: Color black. c _ AlignmentMorph newColumn. c color: b color; borderWidth: 0; inset: 0. c hResizing: #shrinkWrap; vResizing: #shrinkWrap; extent: 5@5. r _ AlignmentMorph 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). c addMorphBack: r. r _ r copy removeAllMorphs. r addMorphBack: (b fullCopy label: 'Bookmark'; actionSelector: #bookmarkForThisPage). r addMorphBack: (b fullCopy label: 'Save'; actionSelector: #saveBookToFile). c addMorphBack: r. ^ c ! ! !BookMorph methodsFor: 'private' stamp: 'sw 5/7/1998 09:06'! makePageControlsFrom: controlSpecs color: aColor | aButton aColumn aRow but | aButton _ SimpleButtonMorph new target: self; borderColor: Color black; color: aColor. aColumn _ AlignmentMorph newColumn. aColumn color: aButton color; borderWidth: 0; inset: 0. aColumn hResizing: #shrinkWrap; vResizing: #shrinkWrap; extent: 5@5. aRow _ AlignmentMorph newRow. aRow color: aButton color; borderWidth: 0; inset: 0. aRow hResizing: #shrinkWrap; vResizing: #shrinkWrap; extent: 5@5. controlSpecs do: [:pair | aRow addMorphBack: (but _ aButton fullCopy label: pair first; actionSelector: pair second). but setBalloonText: pair third. (pair last includesSubString: 'enu') ifTrue: [but actWhen: #buttonDown]]. aColumn addMorphBack: aRow. aColumn setNameTo: 'Page Controls'. ^ aColumn! ! !BookMorph methodsFor: 'private' stamp: 'sw 10/18/97 18:03'! minimalKidsControlSpecs ^ #( ( '<-' previousPage 'Go to previous page') ('->' nextPage 'Go to next page'))! ! !BookMorph methodsFor: 'private' stamp: 'jm 5/16/1998 10:39'! playPageFlipSound (self world soundsEnabled "user-controllable" and: [PageFlipSoundOn]) "mechanism to suppress sounds at init time" ifTrue: [self playSoundNamed: 'camera']. ! ! !BookMorph methodsFor: 'private' stamp: 'jm 2/11/98 12:24'! releaseCachedState "Release the cached state of all my pages." super releaseCachedState. pages do: [:page | page allMorphsDo: [:m | m releaseCachedState]]. ! ! !BookMorph methodsFor: 'private' stamp: 'jm 7/1/97 16:55'! saveBookToFile "Save this book in a file." | fileName s | fileName _ FillInTheBlank request: 'File name for this Book?'. fileName isEmpty ifTrue: [^ self]. "abort" s _ SmartRefStream newFileNamed: fileName, '.morph'. s nextPut: self fullCopy. s close. ! ! !BookMorph methodsFor: 'private' stamp: 'sw 8/12/97 12:30'! switchToAuthorMode "Replace the control panel with one specially for authoring" self deleteControls. self addMorph: ((self makeAuthoringPageControlsColored: self color lighter) borderWidth: 1; inset: 4) ! ! !BookMorph methodsFor: 'copying' stamp: 'tk 8/13/97 15:00'! 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]]). ^ new ! ! !BookMorph methodsFor: 'copying' stamp: 'jm 7/1/97 17:06'! updateReferencesUsing: aDictionary super updateReferencesUsing: aDictionary. pages do: [:page | page allMorphsDo: [:m | m updateReferencesUsing: aDictionary]]. ! ! !BookMorph methodsFor: 'object fileIn' stamp: 'di 5/21/1998 19:23'! convertbosfcepbbochvimolppcc0: varDict bosfcepcbbochvimolppccn0: smartRefStrm "These variables are automatically stored into the new instance ('pageSize' 'pages' 'currentPage' 'copyContents' ). This method is for additional changes. Use statements like (foo _ varDict at: 'foo')." "Be sure to to fill in ('newPagePrototype' ) and deal with the information in ()"! ! !BookMorph methodsFor: 'object fileIn' stamp: 'jm 9/24/97 08:49'! convertbosfcepbbochvimolppccs0: varDict bosfcepbbochvimolppcc0: smartRefStrm "These variables are automatically stored into the new instance ('pageSize' 'pages' 'currentPage' 'copyContents' ). This method is for additional changes. Use statements like (foo _ varDict at: 'foo')." "Be sure to to fill in () and deal with the information in ('saveBlock' )"! ! !BookMorph methodsFor: 'object fileIn' stamp: 'jm 5/15/1998 06:59'! convertbosfcepcbbochvimolppcc0: varDict bosfcepcbbochvimolppccn0: smartRefStrm "Adding newPagePrototype instance variable." newPagePrototype _ nil. ! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! BookMorph class instanceVariableNames: ''! !BookMorph class methodsFor: 'all' stamp: 'sw 5/13/1998 11:43'! authoringPrototype "Answer an instance of the receiver suitable for placing in a parts bin for authors" | book | book _ self new markAsPartsDonor. book removeEverything; pageSize: 128@102; color: (Color r: 0.9 g: 0.9 b: 0.9). book borderWidth: 1; borderColor: Color black. book addDressing; insertPage. ^ book! ! !BookMorph class methodsFor: 'all' stamp: 'jm 9/24/97 08:42'! initialize "BookMorph initialize" PageFlipSoundOn _ true. ! ! !BookMorph class methodsFor: 'all' stamp: 'jm 9/24/97 08:47'! turnOffSoundWhile: aBlock "Turn off page flip sound during the given block." | old | old _ PageFlipSoundOn. PageFlipSoundOn _ false. aBlock value. PageFlipSoundOn _ old. ! ! AlignmentMorph subclass: #BookPageSorterMorph instanceVariableNames: 'book pageHolder ' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Widgets'! !BookPageSorterMorph methodsFor: 'all' stamp: 'jm 11/17/97 17:42'! acceptSort | pages | pages _ OrderedCollection new. pageHolder submorphsDo: [:m | (m isKindOf: BookPageThumbnailMorph) ifTrue: [pages add: m page]]. book newPages: pages currentIndex: pageHolder cursor. self delete. ! ! !BookPageSorterMorph methodsFor: 'all' stamp: 'di 5/6/1998 21:09'! addControls | b r | b _ SimpleButtonMorph new target: self; borderColor: Color black. r _ AlignmentMorph newRow. r color: b color; borderWidth: 0; inset: 0. r hResizing: #shrinkWrap; vResizing: #shrinkWrap; extent: 5@5. r centering: #topLeft. r addMorphBack: (b fullCopy label: 'Okay'; actionSelector: #acceptSort). r addMorphBack: (b fullCopy label: 'Cancel'; actionSelector: #cancelSort). self addMorphBack: r. ! ! !BookPageSorterMorph methodsFor: 'all' stamp: 'jm 11/17/97 15:14'! cancelSort self delete. ! ! !BookPageSorterMorph methodsFor: 'all' stamp: 'jm 11/17/97 19:06'! forBook: aBookMorph book _ aBookMorph. pageHolder removeAllMorphs. pageHolder addAllMorphs: (book pages collect: [:p | BookPageThumbnailMorph new page: p]). pageHolder extent: pageHolder width@pageHolder fullBounds height. ! ! !BookPageSorterMorph methodsFor: 'all' stamp: 'jm 11/17/97 19:40'! initialize super initialize. self extent: 440@400; orientation: #vertical; centering: #topLeft; hResizing: #spaceFill; vResizing: #spaceFill; inset: 3; color: Color lightGray; borderWidth: 2. pageHolder _ HolderMorph new extent: self extent - borderWidth. pageHolder cursor: 0. self addControls. self addMorphBack: pageHolder. ! ! !BookPageSorterMorph methodsFor: 'all' stamp: 'jm 11/17/97 16:46'! pageHolder ^ pageHolder ! ! SketchMorph subclass: #BookPageThumbnailMorph instanceVariableNames: 'page ' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Widgets'! !BookPageThumbnailMorph methodsFor: 'all' stamp: 'jm 11/17/97 17:45'! computeThumbnail | f scale | f _ page imageForm. scale _ self height / f height. "keep height invariant" self form: (f magnify: f boundingBox by: scale@scale smoothing: 2). ! ! !BookPageThumbnailMorph methodsFor: 'all' stamp: 'jm 11/17/97 14:01'! initialize | f | super initialize. color _ Color lightGray. "background color" f _ Form extent: 60@80 depth: 16. f fill: f boundingBox fillColor: color. self form: f. ! ! !BookPageThumbnailMorph methodsFor: 'all' stamp: 'jm 11/17/97 17:30'! page ^ page ! ! !BookPageThumbnailMorph methodsFor: 'all' stamp: 'jm 11/17/97 17:31'! page: aBookPageMorph page _ aBookPageMorph. self computeThumbnail. ! ! Object subclass: #Boolean instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Objects'! !Boolean commentStamp: 'di 5/22/1998 16:32' prior: 0! Boolean comment: 'I represent logical values, providing boolean operations and conditional control structures.'! !Boolean methodsFor: 'logical operations'! & aBoolean "Evaluating conjunction. Evaluate the argument. Then answer true if both the receiver and the argument are true." self subclassResponsibility! ! !Boolean methodsFor: 'logical operations'! eqv: aBoolean "Answer true if the receiver is equivalent to aBoolean." ^self == aBoolean! ! !Boolean methodsFor: 'logical operations'! not "Negation. Answer true if the receiver is false, answer false if the receiver is true." self subclassResponsibility! ! !Boolean methodsFor: 'logical operations'! xor: aBoolean "Exclusive OR. Answer true if the receiver is not equivalent to aBoolean." ^(self == aBoolean) not! ! !Boolean methodsFor: 'logical operations'! | aBoolean "Evaluating disjunction (OR). Evaluate the argument. Then answer true if either the receiver or the argument is true." self subclassResponsibility! ! !Boolean methodsFor: 'controlling'! and: alternativeBlock "Nonevaluating conjunction. If the receiver is true, answer the value of the argument, alternativeBlock; otherwise answer false without evaluating the argument." self subclassResponsibility! ! !Boolean methodsFor: 'controlling'! ifFalse: alternativeBlock "If the receiver is true (i.e., the condition is true), then the value is the true alternative, which is nil. Otherwise answer the result of evaluating the argument, alternativeBlock. Create an error notification if the receiver is nonBoolean. Execution does not actually reach here because the expression is compiled in-line." self subclassResponsibility! ! !Boolean methodsFor: 'controlling'! ifFalse: falseAlternativeBlock ifTrue: trueAlternativeBlock "Same as ifTrue:ifFalse:." self subclassResponsibility! ! !Boolean methodsFor: 'controlling'! ifTrue: alternativeBlock "If the receiver is false (i.e., the condition is false), then the value is the false alternative, which is nil. Otherwise answer the result of evaluating the argument, alternativeBlock. Create an error notification if the receiver is nonBoolean. Execution does not actually reach here because the expression is compiled in-line." self subclassResponsibility! ! !Boolean methodsFor: 'controlling'! ifTrue: trueAlternativeBlock ifFalse: falseAlternativeBlock "If the receiver is true (i.e., the condition is true), then answer the value of the argument trueAlternativeBlock. If the receiver is false, answer the result of evaluating the argument falseAlternativeBlock. If the receiver is a nonBoolean then create an error notification. Execution does not actually reach here because the expression is compiled in-line." self subclassResponsibility! ! !Boolean methodsFor: 'controlling'! or: alternativeBlock "Nonevaluating disjunction. If the receiver is false, answer the value of the argument, alternativeBlock; otherwise answer true without evaluating the argument." self subclassResponsibility! ! !Boolean methodsFor: 'copying'! deepCopy "Receiver has two concrete subclasses, True and False. Only one instance of each should be made, so return self."! ! !Boolean methodsFor: 'copying'! shallowCopy "Receiver has two concrete subclasses, True and False. Only one instance of each should be made, so return self."! ! !Boolean methodsFor: 'printing' stamp: 'sw 4/25/1998 12:51'! basicType ^ #boolean! ! !Boolean methodsFor: 'printing'! storeOn: aStream "Refer to the comment in Object|storeOn:." self printOn: aStream! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Boolean class instanceVariableNames: ''! !Boolean class methodsFor: 'instance creation'! new self error: 'You may not create any more Booleans - this is two-valued logic'! ! ScriptEditorMorph subclass: #BooleanScriptEditor instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Scripting-Support'! !BooleanScriptEditor commentStamp: 'di 5/22/1998 16:32' prior: 0! BooleanScriptEditor class comment: 'A ScriptEditor required to hold a Boolean'! !BooleanScriptEditor methodsFor: 'all' stamp: 'sw 10/14/97 12:55'! storeCodeOn: aStream (submorphs size > 0 and: [submorphs first submorphs size > 0]) ifTrue: [aStream nextPutAll: '(('. super storeCodeOn: aStream. aStream nextPutAll: ') ~~ false)'. ^ self]. aStream nextPutAll: ' true '! ! !BooleanScriptEditor methodsFor: 'all' stamp: 'di 10/17/97 16:32'! wantsDroppedMorph: aMorph ^ aMorph isTileLike and: [aMorph resultType ~~ #command] ! ! Morph subclass: #BorderedMorph instanceVariableNames: 'borderWidth borderColor ' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Kernel'! !BorderedMorph methodsFor: 'initialization' stamp: 'di 6/20/97 11:07'! initialize super initialize. borderColor _ Color black. borderWidth _ 2. ! ! !BorderedMorph methodsFor: 'accessing' stamp: 'sw 8/6/97 14:34'! borderColor ^ borderColor! ! !BorderedMorph methodsFor: 'accessing' stamp: 'jm 5/14/1998 11:07'! borderColor: colorOrSymbolOrNil borderColor = colorOrSymbolOrNil ifFalse: [ borderColor _ colorOrSymbolOrNil. self changed]. ! ! !BorderedMorph methodsFor: 'accessing' stamp: 'di 6/20/97 11:24'! borderInset self borderColor: #inset! ! !BorderedMorph methodsFor: 'accessing' stamp: 'di 6/20/97 11:25'! borderRaised self borderColor: #raised! ! !BorderedMorph methodsFor: 'accessing' stamp: 'di 6/20/97 11:09'! borderWidth ^ borderWidth! ! !BorderedMorph methodsFor: 'accessing' stamp: 'sw 11/17/97 14:57'! borderWidth: anInteger borderColor ifNil: [borderColor _ Color black]. borderWidth _ anInteger max: 0. self changed! ! !BorderedMorph methodsFor: 'accessing' stamp: 'di 6/20/97 11:19'! doesBevels "To return true means that this object can show bevelled borders, and therefore can accept, eg, #raised or #inset as valid borderColors. Must be overridden by subclasses that do not support bevelled borders." ^ true! ! !BorderedMorph methodsFor: 'accessing' stamp: 'sw 4/13/98 15:22'! wearCostume: anotherMorph "Modify the receiver so that it resembles anotherMorph" super wearCostume: anotherMorph. self setBorderWidth: anotherMorph borderWidth borderColor: anotherMorph borderColor ! ! !BorderedMorph methodsFor: 'drawing' stamp: 'di 1/9/98 22:25'! 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: 'drawing' stamp: 'di 5/17/1998 00:16'! drawOnFills: aRectangle ^ (bounds containsRect: aRectangle) and: [self isOpaque]! ! !BorderedMorph methodsFor: 'drawing' stamp: 'di 5/22/1998 08:45'! isOpaque color isTransparent ifTrue: [^ false]. borderWidth = 0 ifTrue: [^ true] ifFalse: [^ borderColor isColor not or: [borderColor isTransparent not]]! ! !BorderedMorph methodsFor: 'geometry' stamp: 'di 6/20/97 11:15'! innerBounds ^ bounds insetBy: borderWidth! ! !BorderedMorph methodsFor: 'menu' stamp: 'sw 8/5/97 13:33'! addCustomMenuItems: aCustomMenu hand: aHandMorph super addCustomMenuItems: aCustomMenu hand: aHandMorph. aCustomMenu addList: #(('border color...' changeBorderColor:) ('border width...' changeBorderWidth:)). self doesBevels ifTrue: [borderColor == #raised ifFalse: [aCustomMenu add: 'raised bevel' action: #borderRaised]. borderColor == #inset ifFalse: [aCustomMenu add: 'inset bevel' action: #borderInset]] ! ! !BorderedMorph methodsFor: 'menu' stamp: 'sw 5/13/1998 12:08'! changeBorderColor: evt | aHand | aHand _ evt ifNotNil: [evt hand] ifNil: [self primaryHand]. aHand changeColorTarget: self selector: #borderColor:. ! ! !BorderedMorph methodsFor: 'menu' stamp: 'sw 5/13/1998 12:11'! changeBorderWidth: evt | handle origin aHand | aHand _ evt ifNil: [self primaryHand] ifNotNil: [evt hand]. origin _ aHand gridPointRaw. handle _ HandleMorph new forEachPointDo: [:newPoint | handle removeAllMorphs. handle addMorph: (PolygonMorph vertices: (Array with: origin with: newPoint) color: Color black borderWidth: 1 borderColor: Color black). self borderWidth: (newPoint - origin) r asInteger // 5]. aHand attachMorph: handle. handle startStepping! ! !BorderedMorph methodsFor: 'menu' stamp: 'sw 5/21/1998 15:21'! slotNamesAndTypesForBank: aNumber "Return an array of part names and part types for use in a viewer on the receiver's costumee; here we only put the costume-specific parts" ^ aNumber == 2 ifTrue: [#( (color color readWrite getColor setColor:) (borderWidth number readWrite getBorderWidth setBorderWidth:) (borderColor color readWrite getBorderColor setBorderColor:) "(mouseX number readOnly getMouseX unused)" "(mouseY number readOnly getMouseY unused)" )] ifFalse: [super slotNamesAndTypesForBank: aNumber] ! ! !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.! ! Morph subclass: #BouncingAtomsMorph instanceVariableNames: 'damageReported infectionHistory transmitInfection ' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Demo'! !BouncingAtomsMorph commentStamp: 'di 5/22/1998 16:32' prior: 0! 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' stamp: 'jm 7/30/97 09:45'! 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. self addAtoms: 30. ! ! !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]. ! ! Object subclass: #BraceConstructor instanceVariableNames: 'elements initIndex subBraceSize constructor decompiler ' classVariableNames: '' poolDictionaries: '' category: 'System-Compiler'! !BraceConstructor methodsFor: 'constructing'! codeBrace: numElements fromBytes: aDecompiler withConstructor: aConstructor "Decompile. Consume at least a Pop and usually several stores into variables or braces. See BraceNode= 0 ifTrue: [^loc]]. ^-1! ! !BraceNode methodsFor: 'testing'! blockAssociationCheck: encoder "If all elements are MessageNodes of the form [block]->[block], and there is at least one element, answer true. Otherwise, notify encoder of an error." elements size = 0 ifTrue: [^encoder notify: 'At least one case required']. elements with: sourceLocations do: [:x :loc | (x isMessage: #-> receiver: [:rcvr | (rcvr isKindOf: BlockNode) and: [rcvr numberOfArguments = 0]] arguments: [:arg | (arg isKindOf: BlockNode) and: [arg numberOfArguments = 0]]) ifFalse: [^encoder notify: 'Association between 0-argument blocks required' at: loc]]. ^true! ! !BraceNode methodsFor: 'testing'! numElements ^ elements size! ! !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! ! !BraceNode methodsFor: 'code generation'! emitStore: stack on: aStream aStream nextPut: Dup. stack push: 1. self emitStorePop: stack on: aStream! ! !BraceNode methodsFor: 'code generation'! emitStorePop: stack on: aStream "N, toBraceStack:, pop, pop elemN, ..., pop elem1" nElementsNode emitForValue: stack on: aStream. toBraceStackNode emit: stack args: 1 on: aStream. stack push: elements size. aStream nextPut: Pop. stack pop: 1. elements reverseDo: [:element | element emitStorePop: stack on: aStream]! ! !BraceNode methodsFor: 'code generation'! sizeForStore: encoder ^1 + (self sizeForStorePop: encoder)! ! !BraceNode methodsFor: 'code generation'! sizeForStorePop: encoder "N, toBraceStack:, pop, pop elemN, ..., pop elem1" nElementsNode _ encoder encodeLiteral: elements size. toBraceStackNode _ encoder encodeSelector: #toBraceStack:. ^elements inject: (nElementsNode sizeForValue: encoder) + (toBraceStackNode size: encoder args: 1 super: false) + 1 into: [:subTotal :element | subTotal + (element sizeForStorePop: encoder)]! ! !BraceNode methodsFor: 'code generation'! sizeForValue: encoder "elem1, ..., elemN, collectionClass, N, fromBraceStack:" nElementsNode _ encoder encodeLiteral: elements size. collClassNode isNil ifTrue: [collClassNode _ encoder encodeVariable: #Array]. fromBraceStackNode _ encoder encodeSelector: #fromBraceStack:. ^elements inject: (nElementsNode sizeForValue: encoder) + (collClassNode sizeForValue: encoder) + (fromBraceStackNode size: encoder args: 1 super: false) into: [:subTotal :element | subTotal + (element sizeForValue: encoder)]! ! !BraceNode methodsFor: 'enumerating'! casesForwardDo: aBlock "For each case in forward order, evaluate aBlock with three arguments: the key block, the value block, and whether it is the last case." | numCases case | 1 to: (numCases _ elements size) do: [:i | case _ elements at: i. aBlock value: case receiver value: case arguments first value: i=numCases]! ! !BraceNode methodsFor: 'enumerating'! casesReverseDo: aBlock "For each case in reverse order, evaluate aBlock with three arguments: the key block, the value block, and whether it is the last case." | numCases case | (numCases _ elements size) to: 1 by: -1 do: [:i | case _ elements at: i. aBlock value: case receiver value: case arguments first value: i=numCases]! ! !BraceNode methodsFor: 'enumerating'! do: aBlock "For each element in order, evaluate aBlock with two arguments: the element, and whether it is the last element." | numElements | 1 to: (numElements _ elements size) do: [:i | aBlock value: (elements at: i) value: i=numElements]! ! !BraceNode methodsFor: 'enumerating'! reverseDo: aBlock "For each element in reverse order, evaluate aBlock with two arguments: the element, and whether it is the last element." | numElements | (numElements _ elements size) to: 1 by: -1 do: [:i | aBlock value: (elements at: i) value: i=numElements]! ! !BraceNode methodsFor: 'printing'! printOn: aStream indent: level | shown | aStream nextPut: ${. shown _ elements size. 1 to: shown do: [:i | (elements at: i) printOn: aStream indent: level. i < shown ifTrue: [aStream nextPut: $.; space]]. aStream nextPut: $}! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! BraceNode class instanceVariableNames: ''! !BraceNode class methodsFor: 'examples'! example "Test the {a. b. c} syntax." | a b c d e x y | x _ {1. {2. 3}. 4}. {a. {b. c}. d. e} _ x, {5}, {}. y _ {a} _ {0}. {} _ {}. ^{e. d. c. b. a + 1. y first} as: Set "BraceNode example" "Smalltalk garbageCollect. Time millisecondsToRun: [20 timesRepeat: [BraceNode example]] 1097 2452"! ! StringHolder subclass: #Browser instanceVariableNames: 'systemOrganizer classOrganizer metaClassOrganizer systemCategoryListIndex classListIndex messageCategoryListIndex messageListIndex editSelection metaClassIndicated ' classVariableNames: 'RecentClasses ' poolDictionaries: '' category: 'Interface-Browser'! !Browser commentStamp: 'di 5/22/1998 16:32' prior: 0! Browser comment: 'I represent a query path into the class descriptions, the software of the system.'! !Browser methodsFor: 'initialize-release'! browserWindowActivated "Called when a window whose model is the receiver is reactivated, giving the receiver an opportunity to take steps if it wishes. The default is to do nothing. 8/5/96 sw"! ! !Browser methodsFor: 'initialize-release' stamp: 'tk 4/8/98 15:22'! buildClassSwitchView | aSwitchView | aSwitchView _ PluggableButtonView on: self getState: #classMessagesIndicated action: #indicateClassMessages. aSwitchView label: 'class'; window: (0@0 extent: 15@8); askBeforeChanging: true. ^ aSwitchView ! ! !Browser methodsFor: 'initialize-release' stamp: 'tk 4/8/98 16:10'! buildCommentSwitchView | aSwitchView | aSwitchView _ PluggableButtonView on: self getState: #classCommentIndicated action: #editComment. aSwitchView label: '?' asText allBold asParagraph; borderWidthLeft: 0 right: 1 top: 0 bottom: 0; window: (0@0 extent: 10@8); askBeforeChanging: true. ^ aSwitchView ! ! !Browser methodsFor: 'initialize-release' stamp: 'tk 4/8/98 16:11'! buildInstanceClassSwitchView | aView aSwitchView instSwitchView comSwitchView | aView _ View new model: self. aView window: (0 @ 0 extent: 50 @ 8). instSwitchView _ self buildInstanceSwitchView. aView addSubView: instSwitchView. comSwitchView _ self buildCommentSwitchView. aView addSubView: comSwitchView toRightOf: instSwitchView. aSwitchView _ self buildClassSwitchView. aView addSubView: aSwitchView toRightOf: comSwitchView. ^aView! ! !Browser methodsFor: 'initialize-release' stamp: 'tk 4/8/98 16:10'! buildInstanceSwitchView | aSwitchView | aSwitchView _ PluggableButtonView on: self getState: #instanceMessagesIndicated action: #indicateInstanceMessages. aSwitchView label: 'instance'; borderWidthLeft: 0 right: 1 top: 0 bottom: 0; window: (0@0 extent: 25@8); askBeforeChanging: true. ^ aSwitchView ! ! !Browser methodsFor: 'initialize-release' stamp: 'di 5/16/1998 15:04'! buildMorphicSwitches | instanceSwitch commentSwitch classSwitch row | instanceSwitch _ PluggableButtonMorph on: self getState: #instanceMessagesIndicated action: #indicateInstanceMessages. instanceSwitch label: 'instance'; askBeforeChanging: true. commentSwitch _ PluggableButtonMorph on: self getState: #classCommentIndicated action: #editComment. commentSwitch label: '?' asText allBold asParagraph; askBeforeChanging: true. classSwitch _ PluggableButtonMorph on: self getState: #classMessagesIndicated action: #indicateClassMessages. classSwitch label: 'class'; askBeforeChanging: true. row _ AlignmentMorph newRow hResizing: #spaceFill; vResizing: #spaceFill; inset: 0; borderColor: Color transparent; addMorphBack: instanceSwitch; addMorphBack: commentSwitch; addMorphBack: classSwitch. ^ row ! ! !Browser methodsFor: 'initialize-release'! defaultBackgroundColor ^ #lightGreen! ! !Browser methodsFor: 'initialize-release' stamp: 'di 5/16/1998 17:21'! openAsMorphClassEditing: editString "Create a pluggable version a Browser on just a single class." | window codePane | window _ (SystemWindow labelled: 'later') model: self. window addMorph: (PluggableListMorph on: self list: #classListSingleton selected: #indexIsOne changeSelected: #indexIsOne: menu: #classListMenu:) frame: (0@0 extent: 0.5@0.06). window addMorph: self buildMorphicSwitches frame: (0.5@0 extent: 0.5@0.06). window addMorph: (PluggableListMorph on: self list: #messageCategoryList selected: #messageCategoryListIndex changeSelected: #messageCategoryListIndex: menu: #messageCategoryMenu:) frame: (0@0.06 extent: 0.5@0.30). window addMorph: (PluggableListMorph on: self list: #messageList selected: #messageListIndex changeSelected: #messageListIndex: menu: #messageListMenu:shifted:) frame: (0.5@0.06 extent: 0.5@0.30). codePane _ PluggableTextMorph on: self text: #contents accept: #contents:notifying: readSelection: #contentsSelection menu: #codePaneMenu:shifted:. editString ifNotNil: [codePane editString: editString. codePane hasUnacceptedEdits: true]. window addMorph: codePane frame: (0@0.36 corner: 1@1). ^ window! ! !Browser methodsFor: 'initialize-release' stamp: 'di 5/16/1998 16:08'! openAsMorphEditing: editString "Create a pluggable version of all the views for a Browser, including views and controllers." | window codePane | window _ (SystemWindow labelled: 'later') model: self. window addMorph: (PluggableListMorph on: self list: #systemCategoryList selected: #systemCategoryListIndex changeSelected: #systemCategoryListIndex: menu: #systemCategoryMenu:) frame: (0@0 extent: 0.25@0.4). window addMorph: (PluggableListMorph on: self list: #classList selected: #classListIndex changeSelected: #classListIndex: menu: #classListMenu:) frame: (0.25@0 extent: 0.25@0.3). window addMorph: self buildMorphicSwitches frame: (0.25@0.3 extent: 0.25@0.1). window addMorph: (PluggableListMorph on: self list: #messageCategoryList selected: #messageCategoryListIndex changeSelected: #messageCategoryListIndex: menu: #messageCategoryMenu:) frame: (0.5@0 extent: 0.25@0.4). window addMorph: (PluggableListMorph on: self list: #messageList selected: #messageListIndex changeSelected: #messageListIndex: menu: #messageListMenu:shifted:) frame: (0.75@0 extent: 0.25@0.4). codePane _ PluggableTextMorph on: self text: #contents accept: #contents:notifying: readSelection: #contentsSelection menu: #codePaneMenu:shifted:. editString ifNotNil: [codePane editString: editString. codePane hasUnacceptedEdits: true]. window addMorph: codePane frame: (0@0.4 corner: 1@1). ^ window! ! !Browser methodsFor: 'initialize-release' stamp: 'di 5/6/1998 21:36'! openAsMorphMessageEditing: editString "Create a pluggable version a Browser on just a messageCategory." | window codePane | window _ (SystemWindow labelled: 'later') model: self. window addMorph: (PluggableListMorph on: self list: #messageListSingleton selected: #indexIsOne changeSelected: #indexIsOne: menu: #messageListMenu:shifted:) frame: (0@0 extent: 1.0@0.06). codePane _ PluggableTextMorph on: self text: #contents accept: #contents:notifying: readSelection: #contentsSelection menu: #codePaneMenu:shifted:. editString ifNotNil: [codePane editString: editString. codePane hasUnacceptedEdits: true]. window addMorph: codePane frame: (0@0.06 corner: 1@1). ^ window! ! !Browser methodsFor: 'initialize-release' stamp: 'di 5/6/1998 21:36'! openAsMorphMsgCatEditing: editString "Create a pluggable version a Browser on just a messageCategory." | window codePane | window _ (SystemWindow labelled: 'later') model: self. window addMorph: (PluggableListMorph on: self list: #messageCatListSingleton selected: #indexIsOne changeSelected: #indexIsOne: menu: #messageCategoryMenu:) frame: (0@0 extent: 1.0@0.06). window addMorph: (PluggableListMorph on: self list: #messageList selected: #messageListIndex changeSelected: #messageListIndex: menu: #messageListMenu:shifted:) frame: (0@0.06 extent: 1.0@0.30). codePane _ PluggableTextMorph on: self text: #contents accept: #contents:notifying: readSelection: #contentsSelection menu: #codePaneMenu:shifted:. editString ifNotNil: [codePane editString: editString. codePane hasUnacceptedEdits: true]. window addMorph: codePane frame: (0@0.36 corner: 1@1). ^ window! ! !Browser methodsFor: 'initialize-release' stamp: 'di 5/16/1998 17:19'! openAsMorphSysCatEditing: editString "Create a pluggable version of all the views for a Browser, including views and controllers." | window codePane | window _ (SystemWindow labelled: 'later') model: self. window addMorph: (PluggableListMorph on: self list: #systemCategorySingleton selected: #indexIsOne changeSelected: #indexIsOne: menu: #systemCategoryMenu:) frame: (0@0 extent: 1.0@0.06). window addMorph: (PluggableListMorph on: self list: #classList selected: #classListIndex changeSelected: #classListIndex: menu: #classListMenu:) frame: (0@0.06 extent: 0.3333@0.24). window addMorph: self buildMorphicSwitches frame: (0@0.3 extent: 0.3333@0.06). window addMorph: (PluggableListMorph on: self list: #messageCategoryList selected: #messageCategoryListIndex changeSelected: #messageCategoryListIndex: menu: #messageCategoryMenu:) frame: (0.3333@0.06 extent: 0.3333@0.30). window addMorph: (PluggableListMorph on: self list: #messageList selected: #messageListIndex changeSelected: #messageListIndex: menu: #messageListMenu:shifted:) frame: (0.6666@0.06 extent: 0.3333@0.30). codePane _ PluggableTextMorph on: self text: #contents accept: #contents:notifying: readSelection: #contentsSelection menu: #codePaneMenu:shifted:. editString ifNotNil: [codePane editString: editString. codePane hasUnacceptedEdits: true]. window addMorph: codePane frame: (0@0.36 corner: 1@1). ^ window! ! !Browser methodsFor: 'initialize-release' stamp: 'di 5/16/1998 17:07'! openEditString: aString "Create a pluggable version of all the views for a Browser, including views and controllers." | systemCategoryListView classListView messageCategoryListView messageListView browserCodeView topView switchView | World ifNotNil: [^ self openAsMorphEditing: aString]. Sensor leftShiftDown ifTrue: [^ self openAsMorphEditing: aString "testing"]. topView _ (StandardSystemView new) model: self. topView borderWidth: 1. "label and minSize taken care of by caller" systemCategoryListView _ PluggableListView on: self list: #systemCategoryList selected: #systemCategoryListIndex changeSelected: #systemCategoryListIndex: menu: #systemCategoryMenu:. systemCategoryListView window: (0 @ 0 extent: 50 @ 70). topView addSubView: systemCategoryListView. classListView _ PluggableListView on: self list: #classList selected: #classListIndex changeSelected: #classListIndex: menu: #classListMenu:. classListView window: (0 @ 0 extent: 50 @ 62). topView addSubView: classListView toRightOf: systemCategoryListView. switchView _ self buildInstanceClassSwitchView. switchView borderWidth: 1. topView addSubView: switchView below: classListView. messageCategoryListView _ PluggableListView on: self list: #messageCategoryList selected: #messageCategoryListIndex changeSelected: #messageCategoryListIndex: menu: #messageCategoryMenu:. messageCategoryListView window: (0 @ 0 extent: 50 @ 70). topView addSubView: messageCategoryListView toRightOf: classListView. messageListView _ PluggableListView on: self list: #messageList selected: #messageListIndex changeSelected: #messageListIndex: menu: #messageListMenu:shifted: keystroke: #messageListKey:from:. messageListView window: (0 @ 0 extent: 50 @ 70). topView addSubView: messageListView toRightOf: messageCategoryListView. browserCodeView _ PluggableTextView on: self text: #contents accept: #contents:notifying: readSelection: #contentsSelection menu: #codePaneMenu:shifted:. browserCodeView window: (0@0 extent: 200@110). topView addSubView: browserCodeView below: systemCategoryListView. aString ifNotNil: [browserCodeView editString: aString. browserCodeView hasUnacceptedEdits: true]. ^ topView ! ! !Browser methodsFor: 'initialize-release' stamp: 'tk 5/6/1998 21:25'! openMessageCatEditString: aString "Create a pluggable version of the views for a Browser that just shows one message category." | messageCategoryListView messageListView browserCodeView topView | World ifNotNil: [^ self openAsMorphMsgCatEditing: aString]. topView _ (StandardSystemView new) model: self. topView borderWidth: 1. "label and minSize taken care of by caller" messageCategoryListView _ PluggableListView on: self list: #messageCatListSingleton selected: #indexIsOne changeSelected: #indexIsOne: menu: #messageCategoryMenu:. messageCategoryListView window: (0 @ 0 extent: 200 @ 12). topView addSubView: messageCategoryListView. messageListView _ PluggableListView on: self list: #messageList selected: #messageListIndex changeSelected: #messageListIndex: menu: #messageListMenu:shifted: keystroke: #messageListKey:from:. messageListView window: (0 @ 0 extent: 200 @ 70). topView addSubView: messageListView below: messageCategoryListView. browserCodeView _ PluggableTextView on: self text: #contents accept: #contents:notifying: readSelection: #contentsSelection menu: #codePaneMenu:shifted:. browserCodeView window: (0@0 extent: 200@(200-12-70)). topView addSubView: browserCodeView below: messageListView. aString ifNotNil: [browserCodeView editString: aString. browserCodeView hasUnacceptedEdits: true]. ^ topView ! ! !Browser methodsFor: 'initialize-release' stamp: 'tk 5/6/1998 21:27'! openMessageEditString: aString "Create a pluggable version of the views for a Browser that just shows one message." | messageListView browserCodeView topView | World ifNotNil: [^ self openAsMorphMessageEditing: aString]. topView _ (StandardSystemView new) model: self. topView borderWidth: 1. "label and minSize taken care of by caller" messageListView _ PluggableListView on: self list: #messageListSingleton selected: #indexIsOne changeSelected: #indexIsOne: menu: #messageListMenu:shifted:. messageListView window: (0 @ 0 extent: 200 @ 12). topView addSubView: messageListView. browserCodeView _ PluggableTextView on: self text: #contents accept: #contents:notifying: readSelection: #contentsSelection menu: #codePaneMenu:shifted:. browserCodeView window: (0@0 extent: 200@(200-12)). topView addSubView: browserCodeView below: messageListView. aString ifNotNil: [browserCodeView editString: aString. browserCodeView hasUnacceptedEdits: true]. ^ topView ! ! !Browser methodsFor: 'initialize-release' stamp: 'tk 5/6/1998 21:25'! openOnClassWithEditString: aString "Create a pluggable version of all the views for a Browser, including views and controllers." | classListView messageCategoryListView messageListView browserCodeView topView switchView | World ifNotNil: [^ self openAsMorphClassEditing: aString]. topView _ (StandardSystemView new) model: self. topView borderWidth: 1. "label and minSize taken care of by caller" classListView _ PluggableListView on: self list: #classListSingleton selected: #indexIsOne changeSelected: #indexIsOne: menu: #classListMenu:. classListView window: (0 @ 0 extent: 100 @ 12). topView addSubView: classListView. messageCategoryListView _ PluggableListView on: self list: #messageCategoryList selected: #messageCategoryListIndex changeSelected: #messageCategoryListIndex: menu: #messageCategoryMenu:. messageCategoryListView window: (0 @ 0 extent: 100 @ 70). topView addSubView: messageCategoryListView below: classListView. messageListView _ PluggableListView on: self list: #messageList selected: #messageListIndex changeSelected: #messageListIndex: menu: #messageListMenu:shifted: keystroke: #messageListKey:from:. messageListView window: (0 @ 0 extent: 100 @ 70). topView addSubView: messageListView toRightOf: messageCategoryListView. switchView _ self buildInstanceClassSwitchView. switchView borderWidth: 1. switchView window: switchView window viewport: (classListView viewport topRight corner: messageListView viewport topRight). topView addSubView: switchView toRightOf: classListView. browserCodeView _ PluggableTextView on: self text: #contents accept: #contents:notifying: readSelection: #contentsSelection menu: #codePaneMenu:shifted:. browserCodeView window: (0@0 extent: 200@(200-12-70)). topView addSubView: browserCodeView below: messageCategoryListView. aString ifNotNil: [browserCodeView editString: aString. browserCodeView hasUnacceptedEdits: true]. ^ topView ! ! !Browser methodsFor: 'initialize-release' stamp: 'di 5/8/1998 22:31'! openSystemCatEditString: aString "Create a pluggable version of all the views for a Browser, including views and controllers. The top list view is of the currently selected system class category--a single item list." | systemCategoryListView classListView messageCategoryListView messageListView browserCodeView topView switchView | World ifNotNil: [^ self openAsMorphSysCatEditing: aString]. topView _ (StandardSystemView new) model: self. topView borderWidth: 1. "label and minSize taken care of by caller" systemCategoryListView _ PluggableListView on: self list: #systemCategorySingleton selected: #indexIsOne changeSelected: #indexIsOne: menu: #systemCategoryMenu:. systemCategoryListView window: (0 @ 0 extent: 200 @ 12). topView addSubView: systemCategoryListView. classListView _ PluggableListView on: self list: #classList selected: #classListIndex changeSelected: #classListIndex: menu: #classListMenu:. classListView window: (0 @ 0 extent: 67 @ 62). topView addSubView: classListView below: systemCategoryListView. messageCategoryListView _ PluggableListView on: self list: #messageCategoryList selected: #messageCategoryListIndex changeSelected: #messageCategoryListIndex: menu: #messageCategoryMenu:. messageCategoryListView window: (0 @ 0 extent: 66 @ 70). topView addSubView: messageCategoryListView toRightOf: classListView. switchView _ self buildInstanceClassSwitchView. switchView window: switchView window viewport: (classListView viewport bottomLeft corner: messageCategoryListView viewport bottomLeft). switchView borderWidth: 1. topView addSubView: switchView below: classListView. messageListView _ PluggableListView on: self list: #messageList selected: #messageListIndex changeSelected: #messageListIndex: menu: #messageListMenu:shifted: keystroke: #messageListKey:from:. messageListView window: (0 @ 0 extent: 67 @ 70). topView addSubView: messageListView toRightOf: messageCategoryListView. browserCodeView _ PluggableTextView on: self text: #contents accept: #contents:notifying: readSelection: #contentsSelection menu: #codePaneMenu:shifted:. browserCodeView window: (0@0 extent: 200@(110-12)). topView addSubView: browserCodeView below: switchView. aString ifNotNil: [browserCodeView editString: aString. browserCodeView hasUnacceptedEdits: true]. ^ topView ! ! !Browser methodsFor: 'initialize-release' stamp: 'tk 5/2/1998 14:35'! setClass: aBehavior selector: aSymbol "Set the state of a new, uninitialized Browser." | isMeta aClass systemCatIndex messageCatIndex | aBehavior ifNil: [^ self]. (aBehavior isKindOf: Metaclass) ifTrue: [isMeta _ true. aClass _ aBehavior soleInstance] ifFalse: [isMeta _ false. aClass _ aBehavior]. systemCatIndex _ SystemOrganization categories indexOf: aClass category. self systemCategoryListIndex: systemCatIndex. self classListIndex: ((SystemOrganization listAtCategoryNumber: systemCatIndex) indexOf: aClass name). self metaClassIndicated: isMeta. aSymbol ifNil: [^ self]. messageCatIndex _ aBehavior organization numberOfCategoryOfElement: aSymbol. self messageCategoryListIndex: messageCatIndex. messageCatIndex = 0 ifTrue: [^ self]. self messageListIndex: ((aBehavior organization listAtCategoryNumber: messageCatIndex) indexOf: aSymbol). ! ! !Browser methodsFor: 'initialize-release'! systemOrganizer: aSystemOrganizer "Initialize the receiver as a perspective on the system organizer, aSystemOrganizer. Typically there is only one--the system variable SystemOrganization." super initialize. contents _ nil. systemOrganizer _ aSystemOrganizer. systemCategoryListIndex _ 0. classListIndex _ 0. messageCategoryListIndex _ 0. messageListIndex _ 0. metaClassIndicated _ false. self setClassOrganizer. editSelection _ #none! ! !Browser methodsFor: 'accessing' stamp: 'tk 4/9/98 13:47'! contents "Depending on the current selection, different information is retrieved. Answer a string description of that information. This information is the method of the currently selected class and message." | comment theClass | editSelection == #none ifTrue: [^ '']. editSelection == #editSystemCategories ifTrue: [^ systemOrganizer printString]. editSelection == #newClass ifTrue: [^ Class template: self selectedSystemCategoryName]. editSelection == #editClass ifTrue: [^ self selectedClassOrMetaClass definition]. editSelection == #editComment ifTrue: [(theClass _ self selectedClass) ifNil: [^ '']. comment _ theClass 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]. editSelection == #byteCodes ifTrue: [ ^ (self selectedClassOrMetaClass compiledMethodAt: self selectedMessageName) symbolic asText]. self error: 'Browser internal error: unknown edit selection.'! ! !Browser methodsFor: 'accessing' stamp: 'di 1/14/98 14:01'! contents: input notifying: aController "The retrieved information has changed and its source must now be updated. The information can be a variety of things, depending on the list selections (such as templates for class or message definition, methods) or the user menu commands (such as definition, comment, hierarchy). Answer the result of updating the source." | aString aText theClass | 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: [theClass _ self selectedClass. theClass ifNil: [PopUpMenu notify: 'You must select a class before giving it a comment.'. ^ false]. theClass comment: aText. ^ true]. editSelection == #hierarchy ifTrue: [^ true]. editSelection == #editMessageCategories ifTrue: [^ self changeMessageCategories: aString]. editSelection == #editMessage | (editSelection == #newMessage) ifTrue: [^ self defineMessage: aText notifying: aController]. editSelection == #none ifTrue: [PopUpMenu notify: 'This text cannot be accepted in this part of the browser.'. ^ false]. self error: 'unacceptable accept'! ! !Browser methodsFor: 'accessing' stamp: 'tk 4/2/98 13:33'! contentsSelection "Return the interval of text in the code pane to select when I set the pane's contents" messageCategoryListIndex > 0 & (messageListIndex = 0) ifTrue: [^ 1 to: 500] "entire empty method template" ifFalse: [^ 1 to: 0] "null selection"! ! !Browser methodsFor: 'accessing' stamp: 'di 5/6/1998 20:57'! couldBrowseAnyClass "Answer whether the receiver is equipped to browse any class. This is in support of the system-brower feature that allows the browser to be redirected at the selected class name. This implementation is clearly ugly, but the feature it enables is handsome enough. 3/1/96 sw" self dependents detect: [:d | (d class == PluggableListView) and: [d getListSelector == #systemCategoryList]] ifNone: [^ false]. ^ true ! ! !Browser methodsFor: 'accessing'! doItReceiver "This class's classPool has been jimmied to be the classPool of the class being browsed. A doIt in the code pane will let the user see the value of the class variables." ^ FakeClassPool new! ! !Browser methodsFor: 'accessing'! editSelection ^editSelection! ! !Browser methodsFor: 'accessing' stamp: 'jm 4/28/1998 05:55'! request: prompt initialAnswer: initialAnswer ^ FillInTheBlank request: prompt initialAnswer: initialAnswer ! ! !Browser methodsFor: 'accessing' stamp: 'di 5/20/1998 22:48'! spawn: aString "Create and schedule a new browser as though the command browse were issued with respect to one of the browser's lists. The initial textual contents is aString, which is the (modified) textual contents of the receiver." messageListIndex ~= 0 ifTrue: [^self buildMessageBrowserEditString: aString]. messageCategoryListIndex ~= 0 ifTrue: [^self buildMessageCategoryBrowserEditString: aString]. classListIndex ~= 0 ifTrue: [^self buildClassBrowserEditString: aString]. systemCategoryListIndex ~= 0 ifTrue: [^self buildSystemCategoryBrowserEditString: aString]. ^Browser new openEditString: aString! ! !Browser methodsFor: 'system category list' stamp: 'tk 5/4/1998 15:46'! indexIsOne "When used as a singleton list, index is always one" ^ 1! ! !Browser methodsFor: 'system category list' stamp: 'tk 5/4/1998 15:46'! indexIsOne: value "When used as a singleton list, can't change it" ^ self! ! !Browser methodsFor: 'system category list'! selectedSystemCategoryName "Answer the name of the selected system category or nil." systemCategoryListIndex = 0 ifTrue: [^nil]. ^self systemCategoryList at: systemCategoryListIndex! ! !Browser methodsFor: 'system category list'! systemCategoryList "Answer the class categories modelled by the receiver." ^systemOrganizer categories! ! !Browser methodsFor: 'system category list'! systemCategoryListIndex "Answer the index of the selected class category." ^systemCategoryListIndex! ! !Browser methodsFor: 'system category list' stamp: 'tk 4/2/98 13:41'! systemCategoryListIndex: anInteger "Set the selected system category index to be anInteger. Update all other selections to be deselected." systemCategoryListIndex _ anInteger. classListIndex _ 0. messageCategoryListIndex _ 0. messageListIndex _ 0. editSelection _ anInteger = 0 ifTrue: [#none] ifFalse: [#newClass]. metaClassIndicated _ false. self setClassOrganizer. contents _ nil. self changed: #systemCategorySelectionChanged. self changed: #systemCategoryListIndex. "update my selection" self changed: #classList. self changed: #messageCategoryList. self changed: #messageList. self changed: #contents. ! ! !Browser methodsFor: 'system category list' stamp: 'tk 4/3/98 10:30'! systemCategorySingleton | cat | cat _ self selectedSystemCategoryName. ^ cat ifNil: [Array new] ifNotNil: [Array with: cat]! ! !Browser methodsFor: 'system category list'! toggleSystemCategoryListIndex: anInteger "If anInteger is the current system category index, deselect it. Else make it the current system category selection." self systemCategoryListIndex: (systemCategoryListIndex = anInteger ifTrue: [0] ifFalse: [anInteger])! ! !Browser methodsFor: 'system category functions' stamp: 'di 4/12/98 13:56'! addSystemCategory "Prompt for a new category name and add it before the current selection, or at the end if no current selection" | oldIndex newName | self okToChange ifFalse: [^ self]. oldIndex _ systemCategoryListIndex. newName _ self request: 'Please type new category name' initialAnswer: 'Category-Name'. newName isEmpty ifTrue: [^ self] ifFalse: [newName _ newName asSymbol]. systemOrganizer addCategory: newName before: (systemCategoryListIndex = 0 ifTrue: [nil] ifFalse: [self selectedSystemCategoryName]). self systemCategoryListIndex: (oldIndex = 0 ifTrue: [systemOrganizer categories size] ifFalse: [oldIndex]). self changed: #systemCategoryList.! ! !Browser methodsFor: 'system category functions' stamp: 'tk 4/6/98 21:09'! browseAllClasses "Create and schedule a new browser on all classes alphabetically." | newBrowser | newBrowser _ HierarchyBrowser new initAlphabeticListing. Browser openBrowserView: (newBrowser openSystemCatEditString: nil) label: 'All Classes Alphabetically'! ! !Browser methodsFor: 'system category functions'! buildSystemCategoryBrowser "Create and schedule a new system category browser." self buildSystemCategoryBrowserEditString: nil! ! !Browser methodsFor: 'system category functions' stamp: 'tk 5/4/1998 15:56'! buildSystemCategoryBrowserEditString: aString "Create and schedule a new system category browser with initial textual contents set to aString." | newBrowser | systemCategoryListIndex > 0 ifTrue: [newBrowser _ Browser new. newBrowser systemCategoryListIndex: systemCategoryListIndex. newBrowser setClass: self selectedClassOrMetaClass selector: self selectedMessageName. Browser openBrowserView: (newBrowser openSystemCatEditString: aString) label: 'Classes in category ', newBrowser selectedSystemCategoryName]! ! !Browser methodsFor: 'system category functions' stamp: 'di 4/12/98 13:21'! changeSystemCategories: aString "Update the class categories by parsing the argument aString." systemOrganizer changeFromString: aString. self changed: #systemCategoryList. ^ true! ! !Browser methodsFor: 'system category functions' stamp: 'tk 4/2/98 13:43'! classNotFound self changed: #flash.! ! !Browser methodsFor: 'system category functions' stamp: 'tk 4/2/98 13:44'! editSystemCategories "Retrieve the description of the class categories of the system organizer." self okToChange ifFalse: [^ self]. self systemCategoryListIndex: 0. editSelection _ #editSystemCategories. self changed: #editSystemCategories. self changed: #contents! ! !Browser methodsFor: 'system category functions' stamp: 'tk 3/31/98 07:52'! fileOutSystemCategory "Print a description of each class in the selected category onto a file whose name is the category name followed by .st." systemCategoryListIndex ~= 0 ifTrue: [systemOrganizer fileOutCategory: self selectedSystemCategoryName]! ! !Browser methodsFor: 'system category functions' stamp: 'tk 4/2/98 13:44'! findClass "Search for a class by name. 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 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)]. self systemCategoryListIndex: (self systemCategoryList indexOf: foundClass category). self classListIndex: (self classList indexOf: foundClass name). ! ! !Browser methodsFor: 'system category functions' stamp: 'tk 4/2/98 13:46'! printOutSystemCategory "Print a description of each class in the selected category as Html." Cursor write showWhile: [systemCategoryListIndex ~= 0 ifTrue: [systemOrganizer fileOutCategory: self selectedSystemCategoryName asHtml: true ]] ! ! !Browser methodsFor: 'system category functions' stamp: 'di 4/12/98 13:55'! removeSystemCategory "If a class category is selected, create a Confirmer so the user can verify that the currently selected class category and all of its classes should be removed from the system. If so, remove it." systemCategoryListIndex = 0 ifTrue: [^ self]. self okToChange ifFalse: [^ self]. (self classList size = 0 or: [self confirm: 'Are you sure you want to remove this system category and all its classes?']) ifTrue: [systemOrganizer removeSystemCategory: self selectedSystemCategoryName. self systemCategoryListIndex: 0. self changed: #systemCategoryList]! ! !Browser methodsFor: 'system category functions' stamp: 'di 4/12/98 13:55'! renameSystemCategory "Prompt for a new category name and add it before the current selection, or at the end if no current selection" | oldIndex oldName newName | (oldIndex _ systemCategoryListIndex) = 0 ifTrue: [^ self]. "no selection" self okToChange ifFalse: [^ self]. oldName _ self selectedSystemCategoryName. newName _ self request: 'Please type new category name' initialAnswer: oldName. newName isEmpty ifTrue: [^ self] ifFalse: [newName _ newName asSymbol]. oldName = newName ifTrue: [^ self]. systemOrganizer renameCategory: oldName toBe: newName. self systemCategoryListIndex: oldIndex. self changed: #systemCategoryList.! ! !Browser methodsFor: 'system category functions' stamp: 'tk 4/2/98 13:48'! systemCategoryMenu: aMenu ^ aMenu labels: 'find class... recent classes... browse all browse printOut fileOut reorganize update add item... rename... remove' lines: #(2 4 6 8) selections: #(findClass recent browseAllClasses buildSystemCategoryBrowser printOutSystemCategory fileOutSystemCategory editSystemCategories updateSystemCategories addSystemCategory renameSystemCategory removeSystemCategory ) ! ! !Browser methodsFor: 'system category functions' stamp: 'di 4/12/98 13:17'! updateSystemCategories "The class categories were changed in another browser. The receiver must reorganize its lists based on these changes." self okToChange ifFalse: [^ self]. self changed: #systemCategoryList! ! !Browser methodsFor: 'class list'! classList "Answer an array of the class names of the selected category. Answer an empty array if no selection exists." systemCategoryListIndex = 0 ifTrue: [^Array new] ifFalse: [^systemOrganizer listAtCategoryNumber: systemCategoryListIndex]! ! !Browser methodsFor: 'class list'! classListIndex "Answer the index of the current class selection." ^classListIndex! ! !Browser methodsFor: 'class list' stamp: 'tk 4/2/98 13:30'! classListIndex: anInteger "Set anInteger to be the index of the current class selection." | className | classListIndex _ anInteger. self setClassOrganizer. messageCategoryListIndex _ 0. messageListIndex _ 0. self classCommentIndicated ifTrue: [] ifFalse: [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. self changed: #classListIndex. "update my selection" self changed: #messageCategoryList. self changed: #messageList. self changed: #contents. ! ! !Browser methodsFor: 'class list' stamp: 'tk 4/5/98 12:25'! classListSingleton | name | name _ self selectedClassName. ^ name ifNil: [Array new] ifNotNil: [Array with: name]! ! !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' stamp: 'tk 4/4/98 18:48'! selectedClass "Answer the class that is currently selected. Answer nil if no selection exists." | name | (name _ self selectedClassName) ifNil: [^ nil]. ^ Smalltalk at: name! ! !Browser methodsFor: 'class list'! selectedClassName "Answer the name of the current class. Answer nil if no selection exists." classListIndex = 0 ifTrue: [^nil]. ^self classList at: classListIndex! ! !Browser methodsFor: 'class list'! toggleClassListIndex: anInteger "If anInteger is the current class index, deselect it. Else make it the current class selection." self classListIndex: (classListIndex = anInteger ifTrue: [0] ifFalse: [anInteger])! ! !Browser methodsFor: 'class functions'! buildClassBrowser "Create and schedule a new class category browser for the current class selection, if one exists." self buildClassBrowserEditString: nil! ! !Browser methodsFor: 'class functions' stamp: 'tk 4/7/98 13:15'! buildClassBrowserEditString: aString "Create and schedule a new class browser for the current selection, if one exists, with initial textual contents set to aString." | newBrowser | self selectedClass ifNotNil: [newBrowser _ Browser new. newBrowser setClass: self selectedClassOrMetaClass selector: self selectedMessageName. Browser openBrowserView: (newBrowser openOnClassWithEditString: aString) label: 'Class Browser: ', self selectedClassOrMetaClass name] ! ! !Browser methodsFor: 'class functions' stamp: 'tk 4/10/1998 12:44'! classListMenu: aMenu ^ aMenu labels: 'browse class browse full printOut fileOut hierarchy definition comment spawn hierarchy spawn protocol inst var refs.. inst var defs.. class var refs... class vars class refs rename... remove unsent methods find method...' lines: #(4 7 9 11 14 16) selections: #(buildClassBrowser browseMethodFull printOutClass fileOutClass hierarchy editClass editComment spawnHierarchy spawnProtocol browseInstVarRefs browseInstVarDefs browseClassVarRefs browseClassVariables browseClassRefs renameClass removeClass browseUnusedMethods findMethod) ! ! !Browser methodsFor: 'class functions' stamp: 'tk 4/24/1998 23:52'! defineClass: aString notifying: aController "The receiver's textual content is a request to define a new class. The source code is aString. If any errors occur in compilation, notify aController." | oldClass class | oldClass _ self selectedClassOrMetaClass. oldClass isNil ifTrue: [oldClass _ Object]. class _ oldClass subclassDefinerClass evaluate: aString notifying: aController logged: true. (class isKindOf: Behavior) ifTrue: [self changed: #classList. self classListIndex: (self classList indexOf: ((class isKindOf: Metaclass) ifTrue: [class soleInstance name] ifFalse: [class name])). self clearUserEditFlag; editClass. ^true] ifFalse: [^false]! ! !Browser methodsFor: 'class functions' stamp: 'tk 4/2/98 13:49'! editClass "Retrieve the description of the class definition." classListIndex = 0 ifTrue: [^ self]. self okToChange ifFalse: [^ self]. self messageCategoryListIndex: 0. editSelection _ #editClass. self changed: #editClass. self changed: #contents. ! ! !Browser methodsFor: 'class functions' stamp: 'tk 4/2/98 13:49'! editComment "Retrieve the description of the class comment." classListIndex = 0 ifTrue: [^ self]. self okToChange ifFalse: [^ self]. self messageCategoryListIndex: 0. editSelection _ #editComment. self changed: #classSelectionChanged. self changed: #contents. ! ! !Browser methodsFor: 'class functions'! explainSpecial: string "Answer a string explaining the code pane selection if it is displaying one of the special edit functions." | classes whole lits reply | (editSelection == #editClass or: [editSelection == #newClass]) ifTrue: ["Selector parts in class definition" string last == $: ifFalse: [^nil]. lits _ Array with: #subclass:instanceVariableNames:classVariableNames:poolDictionaries:category:. (whole _ lits detect: [:each | (each keywords detect: [:frag | frag = string] ifNone: []) ~~ nil] ifNone: []) ~~ nil ifTrue: [reply _ '"' , string , ' is one part of the message selector ' , whole , '.'] ifFalse: [^nil]. classes _ Smalltalk allClassesImplementing: whole. classes _ 'these classes ' , classes printString. ^reply , ' It is defined in ' , classes , '." Smalltalk browseAllImplementorsOf: #' , whole]. editSelection == #hierarchy ifTrue: ["Instance variables in subclasses" classes _ self selectedClassOrMetaClass allSubclasses. classes _ classes detect: [:each | (each instVarNames detect: [:name | name = string] ifNone: []) ~~ nil] ifNone: [^nil]. classes _ classes printString. ^'"is an instance variable in class ' , classes , '." ' , classes , ' browseAllAccessesTo: ''' , string , '''.']. editSelection == #editSystemCategories ifTrue: [^nil]. editSelection == #editMessageCategories ifTrue: [^nil]. ^nil! ! !Browser methodsFor: 'class functions' stamp: 'tk 4/2/98 13:50'! fileOutClass "Print a description of the selected class onto a file whose name is the category name followed by .st." Cursor write showWhile: [classListIndex ~= 0 ifTrue: [self selectedClass fileOut]]! ! !Browser methodsFor: 'class functions' stamp: 'tk 4/2/98 13:50'! findMethod "Pop up a list of the current class's methods, and select the one chosen by the user. 5/21/96 sw, based on a suggestion of John Maloney's." | aClass selectors reply cat messageCatIndex messageIndex | self classListIndex = 0 ifTrue: [^ self]. self okToChange ifFalse: [^ self]. aClass _ self selectedClassOrMetaClass. selectors _ aClass selectors asSortedArray. reply _ (SelectionMenu labelList: selectors selections: selectors) startUp. reply == nil ifTrue: [^ self]. cat _ aClass whichCategoryIncludesSelector: reply. messageCatIndex _ self messageCategoryList indexOf: cat. self messageCategoryListIndex: messageCatIndex. messageIndex _ (self messageList indexOf: reply). self messageListIndex: messageIndex. ! ! !Browser methodsFor: 'class functions' stamp: 'tk 4/2/98 13:50'! 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 changed: #contents. ^ self! ! !Browser methodsFor: 'class functions' stamp: 'tk 4/2/98 13:50'! printOutClass "Print a description of the selected class onto a file whose name is the category name followed by .html." Cursor write showWhile: [classListIndex ~= 0 ifTrue: [self selectedClass fileOutAsHtml: true]]! ! !Browser methodsFor: 'class functions' stamp: 'tk 4/24/1998 23:52'! removeClass "The selected class should be removed from the system. Use a Confirmer to make certain the user intends this irrevocable command to be carried out." | message class className | classListIndex = 0 ifTrue: [^ self]. self okToChange ifFalse: [^ self]. class _ self selectedClass. className _ class name. message _ 'Are you certain that you want to delete the class ', className, '?'. (self confirm: message) ifTrue: [class subclasses size > 0 ifTrue: [self notify: 'class has subclasses: ' , message]. class removeFromSystem. self classListIndex: 0]. self changed: #classList. ! ! !Browser methodsFor: 'class functions' stamp: 'tk 4/24/1998 23:54'! renameClass | oldName newName obs | classListIndex = 0 ifTrue: [^ self]. self okToChange ifFalse: [^ self]. oldName _ self selectedClass name. newName _ (self request: 'Please type new class name' initialAnswer: oldName) asSymbol. newName = oldName ifTrue: [^ self]. (Smalltalk includesKey: newName) ifTrue: [^ self error: newName , ' already exists']. self selectedClass rename: newName. self changed: #classList. self classListIndex: ((systemOrganizer listAtCategoryNamed: self selectedSystemCategoryName) indexOf: newName). obs _ Smalltalk allCallsOn: (Smalltalk associationAt: newName). obs isEmpty ifFalse: [Smalltalk browseMessageList: obs name: 'Obsolete References to ' , oldName autoSelect: oldName]. ! ! !Browser methodsFor: 'class functions' stamp: 'tk 4/7/98 13:25'! spawnHierarchy "Create and schedule a new class hierarchy browser on the currently selected class or meta." | newBrowser aSymbol aBehavior messageCatIndex | classListIndex = 0 ifTrue: [^ self]. newBrowser _ HierarchyBrowser new initHierarchyForClass: self selectedClass meta: self metaClassIndicated. (aSymbol _ self selectedMessageName) ifNotNil: [ aBehavior _ self selectedClassOrMetaClass. messageCatIndex _ aBehavior organization numberOfCategoryOfElement: aSymbol. newBrowser messageCategoryListIndex: messageCatIndex. newBrowser messageListIndex: ((aBehavior organization listAtCategoryNumber: messageCatIndex) indexOf: aSymbol)]. Browser openBrowserView: (newBrowser openSystemCatEditString: nil) label: self selectedClassName , ' hierarchy'! ! !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 list' stamp: 'tk 4/5/98 12:25'! messageCatListSingleton | name | name _ self selectedMessageCategoryName. ^ name ifNil: [Array new] ifNotNil: [Array with: name]! ! !Browser methodsFor: 'message category list'! messageCategoryList "Answer the selected category of messages." classListIndex = 0 ifTrue: [^Array new] ifFalse: [^self classOrMetaClassOrganizer categories]! ! !Browser methodsFor: 'message category list'! messageCategoryListIndex "Answer the index of the selected message category." ^messageCategoryListIndex! ! !Browser methodsFor: 'message category list' stamp: 'tk 4/2/98 13:41'! messageCategoryListIndex: anInteger "Set the selected message category to be the one indexed by anInteger." messageCategoryListIndex _ anInteger. messageListIndex _ 0. editSelection _ anInteger = 0 ifTrue: [#none] ifFalse: [#newMessage]. contents _ nil. self changed: #messageCategorySelectionChanged. self changed: #messageCategoryListIndex. "update my selection" self changed: #messageList. self changed: #contents. ! ! !Browser methodsFor: 'message category list'! selectedMessageCategoryName "Answer the name of the selected message category, if any. Answer nil otherwise." messageCategoryListIndex = 0 ifTrue: [^nil]. ^self messageCategoryList at: messageCategoryListIndex! ! !Browser methodsFor: 'message category list'! toggleMessageCategoryListIndex: anInteger "If the currently selected message category index is anInteger, deselect the category. Otherwise select the category whose index is anInteger." self messageCategoryListIndex: (messageCategoryListIndex = anInteger ifTrue: [0] ifFalse: [anInteger])! ! !Browser methodsFor: 'message category functions' stamp: 'di 5/19/1998 23:58'! addCategory "Prompt for a new category name and add it before the current selection, or at the end if no current selection" | oldIndex newName | self okToChange ifFalse: [^ self]. classListIndex = 0 ifTrue: [^ self]. oldIndex _ messageCategoryListIndex. newName _ self request: 'Please type new category name' initialAnswer: 'category name'. newName isEmpty ifTrue: [^ self] ifFalse: [newName _ newName asSymbol]. self classOrMetaClassOrganizer addCategory: newName before: (messageCategoryListIndex = 0 ifTrue: [nil] ifFalse: [self selectedMessageCategoryName]). self changed: #messageCategoryList. self messageCategoryListIndex: (oldIndex = 0 ifTrue: [self classOrMetaClassOrganizer categories size] ifFalse: [oldIndex]). self changed: #messageCategoryList. ! ! !Browser methodsFor: 'message category functions'! buildMessageCategoryBrowser "Create and schedule a message category browser for the currently selected message category." self buildMessageCategoryBrowserEditString: nil! ! !Browser methodsFor: 'message category functions' stamp: 'tk 5/6/1998 21:30'! buildMessageCategoryBrowserEditString: aString "Create and schedule a message category browser for the currently selected message category. The initial text view contains the characters in aString." | newBrowser | messageCategoryListIndex ~= 0 ifTrue: [newBrowser _ Browser new. newBrowser systemCategoryListIndex: systemCategoryListIndex. newBrowser classListIndex: classListIndex. newBrowser metaClassIndicated: metaClassIndicated. newBrowser messageCategoryListIndex: messageCategoryListIndex. newBrowser messageListIndex: messageListIndex. Browser openBrowserView: (newBrowser openMessageCatEditString: aString) label: 'Message Category Browser (' , newBrowser selectedClassOrMetaClassName , ')']! ! !Browser methodsFor: 'message category functions' stamp: 'jm 3/24/98 16:05'! changeMessageCategories: aString "The characters in aString represent an edited version of the the message categories for the selected class. Update this information in the system and inform any dependents that the categories have been changed. This message is invoked because the user had issued the categories command and edited the message categories. Then the user issued the accept command." self classOrMetaClassOrganizer changeFromString: aString. Smalltalk changes reorganizeClass: self selectedClassOrMetaClass. self clearUserEditFlag. self editClass. self classListIndex: classListIndex. ^ true! ! !Browser methodsFor: 'message category functions' stamp: 'tk 4/2/98 13:53'! editMessageCategories "Indicate to the receiver and its dependents that the message categories of the selected class have been changed." self okToChange ifFalse: [^ self]. classListIndex ~= 0 ifTrue: [self messageCategoryListIndex: 0. editSelection _ #editMessageCategories. self changed: #editMessageCategories. self changed: #contents]! ! !Browser methodsFor: 'message category functions' stamp: 'tk 4/2/98 13:53'! fileOutMessageCategories "Print a description of the selected message category of the selected class onto an external file." Cursor write showWhile: [messageCategoryListIndex ~= 0 ifTrue: [self selectedClassOrMetaClass fileOutCategory: self selectedMessageCategoryName]]! ! !Browser methodsFor: 'message category functions' stamp: 'tk 4/2/98 13:53'! messageCategoryMenu: aMenu ^ aMenu labels: 'browse printOut fileOut reorganize add item... rename... remove' lines: #(3 4) selections: #(buildMessageCategoryBrowser printOutMessageCategories fileOutMessageCategories editMessageCategories addCategory renameCategory removeMessageCategory) ! ! !Browser methodsFor: 'message category functions' stamp: 'tk 4/2/98 13:53'! printOutMessageCategories "Print a description of the selected message category of the selected class onto an external file in Html format." Cursor write showWhile: [messageCategoryListIndex ~= 0 ifTrue: [self selectedClassOrMetaClass fileOutCategory: self selectedMessageCategoryName asHtml: true]]! ! !Browser methodsFor: 'message category functions' stamp: 'tk 4/2/98 13:54'! removeMessageCategory "If a message category is selected, create a Confirmer so the user can verify that the currently selected message category should be removed from the system. If so, remove it." | messageCategoryName | messageCategoryListIndex = 0 ifTrue: [^ self]. self okToChange ifFalse: [^ self]. messageCategoryName _ self selectedMessageCategoryName. (self messageList size = 0 or: [self confirm: 'Are you sure you want to remove this method category and all its methods?']) ifTrue: [self selectedClassOrMetaClass removeCategory: messageCategoryName. self messageCategoryListIndex: 0. self changed: #classSelectionChanged]. self changed: #messageCategoryList. ! ! !Browser methodsFor: 'message category functions' stamp: 'tk 4/2/98 13:54'! renameCategory "Prompt for a new category name and add it before the current selection, or at the end if no current selection" | oldIndex oldName newName | classListIndex = 0 ifTrue: [^ self]. self okToChange ifFalse: [^ self]. (oldIndex _ messageCategoryListIndex) = 0 ifTrue: [^ self]. oldName _ self selectedMessageCategoryName. newName _ self request: 'Please type new category name' initialAnswer: oldName. newName isEmpty ifTrue: [^ self] ifFalse: [newName _ newName asSymbol]. newName = oldName ifTrue: [^ self]. self classOrMetaClassOrganizer renameCategory: oldName toBe: newName. Smalltalk changes reorganizeClass: self selectedClassOrMetaClass. self classListIndex: classListIndex. self messageCategoryListIndex: oldIndex. self changed: #messageCategoryList. ! ! !Browser methodsFor: 'message list'! messageList "Answer an Array of the message selectors of the currently selected message category. Otherwise, answer a new empty Array." messageCategoryListIndex = 0 ifTrue: [^Array new] ifFalse: [^self classOrMetaClassOrganizer listAtCategoryNumber: messageCategoryListIndex]! ! !Browser methodsFor: 'message list'! messageListIndex "Answer the index of the selected message selector into the currently selected message category." ^messageListIndex! ! !Browser methodsFor: 'message list' stamp: 'tk 4/25/1998 00:11'! messageListIndex: anInteger "Set the selected message selector to be the one indexed by anInteger." messageListIndex _ anInteger. editSelection _ anInteger = 0 ifTrue: [#newMessage] ifFalse: [#editMessage]. contents _ nil. self changed: #messageListIndex. "update my selection" self changed: #contents. ! ! !Browser methodsFor: 'message list' stamp: 'tk 4/6/98 10:48'! messageListSingleton | name | name _ self selectedMessageName. ^ name ifNil: [Array new] ifNotNil: [Array with: name]! ! !Browser methodsFor: 'message list' stamp: 'tk 4/4/98 21:25'! 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 asString in: class notifying: nil) tempNames. contents _ ((class decompilerClass new withTempNames: tempNames) decompile: selector in: class method: method) decompileString. contents _ contents asText makeSelectorBoldIn: self selectedClassOrMetaClass. ^ contents copy]. contents _ class sourceCodeAt: selector. contents _ contents asText makeSelectorBoldIn: self selectedClassOrMetaClass. ^ contents copy! ! !Browser methodsFor: 'message list'! selectedMessageName "Answer the message selector of the currently selected message, if any. Answer nil otherwise." messageListIndex = 0 ifTrue: [^nil]. ^self messageList at: messageListIndex! ! !Browser methodsFor: 'message list'! toggleMessageListIndex: anInteger "If the currently selected message index is anInteger, deselect the message selector. Otherwise select the message selector whose index is anInteger." self messageListIndex: (messageListIndex = anInteger ifTrue: [0] ifFalse: [anInteger])! ! !Browser methodsFor: 'message functions'! browseImplementors "Create and schedule a message set browser on all implementors of the currently selected message selector. Do nothing if no message is selected." messageListIndex ~= 0 ifTrue: [Smalltalk browseAllImplementorsOf: self selectedMessageName]! ! !Browser methodsFor: 'message functions'! buildMessageBrowser "Create and schedule a message browser on the currently selected message. Do nothing if no message is selected. The initial text view contains nothing." self buildMessageBrowserEditString: nil! ! !Browser methodsFor: 'message functions' stamp: 'tk 4/6/98 21:47'! buildMessageBrowserEditString: aString "Create and schedule a message browser for the receiver in which the argument, aString, contains characters to be edited in the text view." messageListIndex = 0 ifTrue: [^ self]. ^ Browser openMessageBrowserForClass: self selectedClassOrMetaClass selector: self selectedMessageName editString: aString! ! !Browser methodsFor: 'message functions' stamp: 'tk 4/25/1998 00:08'! defineMessage: aString notifying: aController "Compile the expressions in aString. Notify aController if a syntax error occurs. Install the compiled method in the selected class classified under the currently selected message category name. Answer true if compilation succeeds, false otherwise." | selectedMessageName selector category oldMessageList | selectedMessageName _ self selectedMessageName. oldMessageList _ self messageList. contents _ nil. selector _ self selectedClassOrMetaClass compile: aString classified: (category _ self selectedMessageCategoryName) notifying: aController. selector == nil ifTrue: [^ false]. contents _ aString copy. selector ~~ selectedMessageName ifTrue: [category = ClassOrganizer nullCategory ifTrue: [self changed: #classSelectionChanged. self changed: #classList. self messageCategoryListIndex: 1]. self setClassOrganizer. "In case organization not cached" (oldMessageList includes: selector) ifFalse: [self changed: #messageList]. self messageListIndex: (self messageList indexOf: selector)]. ^ true! ! !Browser methodsFor: 'message functions' stamp: 'tk 4/2/98 17:02'! inspectInstances "Inspect all instances of the selected class. 1/26/96 sw" | myClass | myClass _ self selectedClassOrMetaClass. myClass ~~ nil ifTrue: [myClass theNonMetaClass inspectAllInstances]. ! ! !Browser methodsFor: 'message functions' stamp: 'tk 4/2/98 17:02'! inspectSubInstances "Inspect all instances of the selected class and all its subclasses 1/26/96 sw" | aClass | aClass _ self selectedClassOrMetaClass. aClass ~~ nil ifTrue: [aClass _ aClass theNonMetaClass. aClass inspectSubInstances]. ! ! !Browser methodsFor: 'message functions' stamp: 'tk 4/18/1998 16:14'! messageListMenu: aMenu shifted: shifted ^ shifted ifFalse: [aMenu labels: 'browse full fileOut printOut senders of... implementors of... method inheritance versions inst var refs... inst var defs... class var refs... class variables class refs remove more...' lines: #(3 7 12) selections: #(browseMethodFull fileOutMessage printOutMessage browseSendersOfMessages browseMessages methodHierarchy browseVersions browseInstVarRefs browseInstVarDefs browseClassVarRefs browseClassVariables browseClassRefs removeMessage shiftedYellowButtonActivity )] ifTrue: [aMenu labels: 'browse class hierarchy browse class browse method implementors of sent messages change sets with this method inspect instances inspect subinstances remove from this browser revert to previous version remove from current change set revert and forget more...' lines: #(5 7 11) selections: #(classHierarchy browseClass buildMessageBrowser browseAllMessages findMethodInChangeSets inspectInstances inspectSubInstances removeMessageFromBrowser revertToPreviousVersion removeFromCurrentChanges revertAndForget unshiftedYellowButtonActivity)] ! ! !Browser methodsFor: 'message functions' stamp: 'tk 4/2/98 17:03'! removeFromCurrentChanges "Tell the changes mgr to forget that the current msg was changed." Smalltalk changes removeSelectorChanges: self selectedMessageName class: self selectedClassOrMetaClass. ! ! !Browser methodsFor: 'message functions' stamp: 'tk 4/25/1998 00:07'! removeMessage "If a message is selected, create a Confirmer so the user can verify that the currently selected message should be removed from the system. If so, remove it. If the Preference 'confirmMethodRemoves' is set to false, the confirmer is bypassed." | messageName confirmation | messageListIndex = 0 ifTrue: [^ self]. self okToChange ifFalse: [^ self]. messageName _ self selectedMessageName. confirmation _ self selectedClassOrMetaClass confirmRemovalOf: messageName. confirmation == 3 ifTrue: [^ self]. self selectedClassOrMetaClass removeSelector: self selectedMessageName. self changed: #messageList. self messageListIndex: 0. self setClassOrganizer. "In case organization not cached" confirmation == 2 ifTrue: [Smalltalk browseAllCallsOn: messageName] ! ! !Browser methodsFor: 'message functions' stamp: 'tk 4/2/98 17:03'! removeMessageFromBrowser "Our list speaks the truth and can't have arbitrary things removed" ^ self changed: #flash! ! !Browser methodsFor: 'message functions' stamp: 'tk 4/24/1998 23:46'! revertAndForget "Revert to the previous version of the current method, and tell the changes mgr to forget that it was ever changed. Danger!! Use only if you really know what you're doing!!" self revertToPreviousVersion. self removeFromCurrentChanges. self changed: #contents! ! !Browser methodsFor: 'message functions' stamp: 'tk 4/2/98 17:04'! revertToPreviousVersion "Revert to the previous version of the current method" | aClass aSelector changeRecords codeController | aClass _ self selectedClassOrMetaClass. aClass ifNil: [^ self changed: #flash]. aSelector _ self selectedMessageName. changeRecords _ aClass changeRecordsAt: aSelector. changeRecords size <= 1 ifTrue: [self changed: #flash. ^ self beep]. codeController _ (self dependents detect: [:v | v isKindOf: PluggableTextView]) controller. "later find a better way to do this!!" self contents: (changeRecords at: 2) string notifying: codeController. self changed: #contents! ! !Browser methodsFor: 'message functions' stamp: 'tk 4/2/98 20:57'! shiftedYellowButtonActivity "Invoke the model's other menu. Just do what the controller would have done." | menu | menu _ self messageListMenu: (CustomMenu new) shifted: true. menu == nil ifTrue: [Sensor waitNoButton] ifFalse: [menu invokeOn: self]. ! ! !Browser methodsFor: 'message functions' stamp: 'tk 4/2/98 20:58'! unshiftedYellowButtonActivity "Invoke the model's other menu. Just do what the controller would have done." | menu | menu _ self messageListMenu: (CustomMenu new) shifted: false. menu == nil ifTrue: [Sensor waitNoButton] ifFalse: [menu invokeOn: self]. ! ! !Browser methodsFor: 'code pane' stamp: 'tk 4/9/98 14:03'! showBytecodes "Show the bytecodes of the selected method." "Set a mode for contents!!" ((self messageListIndex = 0) | (self okToChange not)) ifTrue: [^ self changed: #flash]. editSelection _ #byteCodes. self changed: #contents. ! ! !Browser methodsFor: 'metaclass' stamp: 'di 1/14/98 12:25'! classCommentIndicated "Answer true iff we're viewing the class comment." ^ editSelection == #editComment ! ! !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'! indicateClassMessages "Indicate that the message selection should come from the metaclass messages." self metaClassIndicated: true! ! !Browser methodsFor: 'metaclass'! indicateInstanceMessages "Indicate that the message selection should come from the class (instance) messages." self metaClassIndicated: false! ! !Browser methodsFor: 'metaclass' stamp: 'di 1/14/98 13:20'! instanceMessagesIndicated "Answer whether the messages to be presented should come from the class." ^metaClassIndicated not and: [self classCommentIndicated not]! ! !Browser methodsFor: 'metaclass' stamp: 'di 1/14/98 13:19'! metaClassIndicated "Answer the boolean flag that indicates which of the method dictionaries, class or metaclass." ^ metaClassIndicated and: [self classCommentIndicated not]! ! !Browser methodsFor: 'metaclass' stamp: 'tk 4/2/98 17:05'! metaClassIndicated: trueOrFalse "Indicate whether browsing instance or class messages." metaClassIndicated _ trueOrFalse. self setClassOrganizer. systemCategoryListIndex > 0 ifTrue: [editSelection _ classListIndex = 0 ifTrue: [metaClassIndicated ifTrue: [#none] ifFalse: [#newClass]] ifFalse: [#editClass]]. messageCategoryListIndex _ 0. messageListIndex _ 0. contents _ nil. self changed: #classSelectionChanged. self changed: #messageCategoryList. self changed: #messageList. self changed: #contents. ! ! !Browser methodsFor: 'metaclass' stamp: 'tk 4/9/98 10:48'! selectedClassOrMetaClass "Answer the selected class or metaclass." | cls | self metaClassIndicated ifTrue: [^ (cls _ self selectedClass) ifNil: [nil] ifNotNil: [cls class]] ifFalse: [^ self selectedClass]! ! !Browser methodsFor: 'metaclass'! selectedClassOrMetaClassName "Answer the selected class name or metaclass name." ^self selectedClassOrMetaClass name! ! !Browser methodsFor: 'metaclass' stamp: 'di 1/14/98 13:27'! setClassOrganizer "Install whatever organization is appropriate" | theClass | classOrganizer _ nil. metaClassOrganizer _ nil. classListIndex = 0 ifTrue: [^ self]. classOrganizer _ (theClass _ self selectedClass) organization. metaClassOrganizer _ theClass class organization.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Browser class instanceVariableNames: ''! !Browser class methodsFor: 'instance creation' stamp: 'tk 4/10/1998 17:37'! fullOnClass: aClass "Open a new full browser set to class." | brow | brow _ Browser new. brow setClass: aClass selector: nil. Browser openBrowserView: (brow openEditString: nil) label: 'System Browser'! ! !Browser class methodsFor: 'instance creation' stamp: 'tk 4/18/1998 15:27'! fullOnClass: aClass selector: aSelector "Open a new full browser set to class." | brow | brow _ Browser new. brow setClass: aClass selector: aSelector. Browser openBrowserView: (brow openEditString: nil) label: 'System Browser'! ! !Browser class methodsFor: 'instance creation'! new ^super new systemOrganizer: SystemOrganization! ! !Browser class methodsFor: 'instance creation' stamp: 'tk 4/6/98 22:04'! newOnCategory: aCategory "Browse the system category of the given name. 7/13/96 sw" "Browser newOnCategory: 'Interface-Browser'" | newBrowser catList | newBrowser _ Browser new. catList _ newBrowser systemCategoryList. newBrowser systemCategoryListIndex: (catList indexOf: aCategory asSymbol ifAbsent: [^ self inform: 'No such category']). Browser openBrowserView: (newBrowser openSystemCatEditString: nil) label: 'Classes in category ', aCategory ! ! !Browser class methodsFor: 'instance creation' stamp: 'tk 4/18/1998 16:28'! newOnClass: aClass "Open a new class browser on this class." ^ self newOnClass: aClass label: 'Class Browser: ', aClass name! ! !Browser class methodsFor: 'instance creation' stamp: 'tk 4/6/98 22:55'! newOnClass: aClass label: aLabel "Open a new class browser on this class." | newBrowser | newBrowser _ Browser new. newBrowser setClass: aClass selector: nil. Browser openBrowserView: (newBrowser openOnClassWithEditString: nil) label: aLabel ! ! !Browser class methodsFor: 'instance creation' stamp: 'tk 4/18/1998 16:29'! newOnClass: aClass selector: aSymbol "Open a new class browser on this class." | newBrowser | newBrowser _ Browser new. newBrowser setClass: aClass selector: aSymbol. Browser openBrowserView: (newBrowser openOnClassWithEditString: nil) label: 'Class Browser: ', aClass name ! ! !Browser class methodsFor: 'instance creation' stamp: 'tk 4/6/98 21:28'! openBrowser "Create and schedule a BrowserView with label 'System Browser'. The view consists of five subviews, starting with the list view of system categories of SystemOrganization. The initial text view part is empty." Browser openBrowserView: (Browser new openEditString: nil) label: 'System Browser' ! ! !Browser class methodsFor: 'instance creation' stamp: 'di 5/14/1998 09:43'! openBrowserView: aBrowserView label: aString "Schedule aBrowserView, labelling the view aString." aBrowserView isMorph ifTrue: [(aBrowserView setLabel: aString) openInWorld] ifFalse: [aBrowserView label: aString. aBrowserView minimumSize: 300 @ 200. aBrowserView subViews do: [:each | each controller]. aBrowserView controller open]! ! !Browser class methodsFor: 'instance creation' stamp: 'tk 4/6/98 21:44'! openMessageBrowserForClass: aBehavior selector: aSymbol editString: aString "Create and schedule a message browser for the class, aBehavior, in which the argument, aString, contains characters to be edited in the text view. These characters are the source code for the message selector aSymbol." | newBrowser | (newBrowser _ Browser new) setClass: aBehavior selector: aSymbol. ^ Browser openBrowserView: (newBrowser openMessageEditString: aString) label: newBrowser selectedClassOrMetaClassName , ' ' , newBrowser selectedMessageName ! ! !Browser class methodsFor: 'class initialization'! initialize "Browser initialize" RecentClasses := OrderedCollection new! ! Switch subclass: #Button instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Interface-Menus'! !Button commentStamp: 'di 5/22/1998 16:32' prior: 0! Button comment: 'I am a Switch that turns off automatically after being turned on, that is, I act like a push-button switch.'! !Button methodsFor: 'state'! turnOff "Sets the state of the receiver to 'off'. The off action of the receiver is not executed." on _ false! ! !Button methodsFor: 'state'! turnOn "The receiver remains in the 'off' state'." self doAction: onAction. self doAction: offAction! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Button class instanceVariableNames: ''! !Button class methodsFor: 'instance creation'! newOn "Refer to the comment in Switch|newOn." self error: 'Buttons cannot be created in the on state'. ^nil! ! SimpleButtonMorph subclass: #ButtonMorph instanceVariableNames: 'lastAcceptedScript lastScriptEditor ' classVariableNames: '' poolDictionaries: '' category: 'Experimental-Miscellaneous'! !ButtonMorph methodsFor: 'menu' stamp: 'di 11/4/97 09:01'! addCustomMenuItems: aCustomMenu hand: aHandMorph super addCustomMenuItems: aCustomMenu hand: aHandMorph. aCustomMenu add: 'border color' action: #changeBorderColor:. aCustomMenu add: 'border width' action: #changeBorderWidth:. aCustomMenu add: 'change label' action: #setLabel. aCustomMenu add: 'script' action: #editScript:. ! ! !ButtonMorph methodsFor: 'menu'! editScript: evt self nameInModel ifNil: [self choosePartNameSilently]. evt hand attachMorph: (self scriptEditorFor: 'buttonUp'). ! ! !ButtonMorph methodsFor: 'menu'! hasScript "Return true if there is already a script for this morph." ^ lastAcceptedScript ~~ nil! ! !ButtonMorph methodsFor: 'menu'! scriptEditorFor: ignored (lastScriptEditor ~= nil and: [lastScriptEditor isInWorld]) ifTrue: [^ lastScriptEditor]. lastAcceptedScript = nil ifTrue: [ ^ lastScriptEditor _ ScriptEditorMorph new setMorph: self scriptName: 'ButtonUp'. ] ifFalse: [ ^ lastScriptEditor _ lastAcceptedScript fullCopy]. ! ! !ButtonMorph methodsFor: 'copying' stamp: 'tk 12/4/97 11:22'! copy | obj | obj _ super copy. obj lastScriptEditor: obj lastAcceptedScript. "lastScriptEditor would not have been copied, as it is owned by the world, not me. Can't allow mine to creep into the copy." ^ obj! ! !ButtonMorph methodsFor: 'copying' stamp: 'sw 9/22/97 08:57'! copyRecordingIn: dict "Overridden to copy lastAcceptedScript as well." | new | new _ super copyRecordingIn: dict. lastAcceptedScript ifNotNil: [ new lastAcceptedScript: ((dict includesKey: lastAcceptedScript) ifTrue: [dict at: lastAcceptedScript] ifFalse: [lastAcceptedScript copyRecordingIn: dict])]. lastScriptEditor ifNotNil: [ new lastScriptEditor: ((dict includesKey: lastScriptEditor) ifTrue: [dict at: lastScriptEditor] ifFalse: [lastScriptEditor copyRecordingIn: dict])]. ^ new ! ! !ButtonMorph methodsFor: 'copying' stamp: 'tk 12/4/97 11:23'! prepareToBeSaved "SmartRefStream will not write any morph that is owned by someone outside the root being written. (See DataStream.typeIDFor:) Open Scripts are like that. Make a private copy of the scriptEditor." super prepareToBeSaved. lastAcceptedScript ifNotNil: [ lastAcceptedScript owner ifNotNil: ["open on the screen" lastAcceptedScript _ lastAcceptedScript fullCopy setMorph: self. "lastAcceptedScript privateOwner: nil" "fullCopy does it"]]. "lastScriptEditor will not be written out"! ! !ButtonMorph methodsFor: 'copying' stamp: 'tk 12/4/97 11:21'! shallowCopy | obj | obj _ super shallowCopy. obj lastScriptEditor: obj lastAcceptedScript. "lastScriptEditor would not have been copied, as it is owned by the world, not me. Can't allow mine to creep into the copy." ^ obj! ! !ButtonMorph methodsFor: 'other'! acceptScript: aScriptEditorMorph for: ignored lastAcceptedScript _ aScriptEditorMorph. self world model class compile: lastAcceptedScript methodString classified: 'scripts' notifying: nil. ! ! !ButtonMorph methodsFor: 'other'! buttonUpSelector ^ (self nameInModel, 'ButtonUp') asSymbol ! ! !ButtonMorph methodsFor: 'other'! choosePartName "Override to add null on-ticks script when this morph is named." | newName | newName _ super choosePartName. newName ifNil: [^ self]. "user cancelled or chose a bad part name" (self world model class) compile: self buttonUpSelector classified: 'scripts' notifying: nil. ! ! !ButtonMorph methodsFor: 'other'! choosePartNameSilently super choosePartNameSilently. (self world model class) compile: self buttonUpSelector classified: 'scripts' notifying: nil. ! ! !ButtonMorph methodsFor: 'other'! doButtonAction self nameInModel ~~ nil ifTrue: [ self world model perform: self buttonUpSelector]. ! ! !ButtonMorph methodsFor: 'other' stamp: 'tk 12/4/97 11:22'! lastAcceptedScript ^ lastAcceptedScript! ! !ButtonMorph methodsFor: 'other' stamp: 'tk 9/21/97 00:16'! lastAcceptedScript: scriptEditor "Need to do a clean store here." lastAcceptedScript _ scriptEditor! ! !ButtonMorph methodsFor: 'other' stamp: 'tk 9/21/97 00:16'! lastScriptEditor: scriptEditor "Need to do a clean store here." lastScriptEditor _ scriptEditor! ! ArrayedCollection variableByteSubclass: #ByteArray instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Collections-Arrayed'! !ByteArray commentStamp: 'di 5/22/1998 16:32' prior: 0! ByteArray comment: 'I represent an ArrayedCollection whose elements can only be integers between 0 and 255. They are stored two bytes to a word.'! !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! ! !ByteArray methodsFor: 'accessing'! doubleWordAt: i "Answer the value of the double word (4 bytes) starting at byte index i." | b0 b1 b2 w | "Primarily for reading socket #s in Pup headers" b0 _ self at: i. b1 _ self at: i+1. b2 _ self at: i+2. w _ self at: i+3. "Following sequence minimizes LargeInteger arithmetic for small results." b2=0 ifFalse: [w _ (b2 bitShift: 8) + w]. b1=0 ifFalse: [w _ (b1 bitShift: 16) + w]. b0=0 ifFalse: [w _ (b0 bitShift: 24) + w]. ^w! ! !ByteArray methodsFor: 'accessing'! doubleWordAt: i put: value "Set the value of the double word (4 bytes) starting at byte index i." | w | "Primarily for setting socket #s in Pup headers" w _ value asInteger. self at: i put: (w digitAt: 4). self at: i + 1 put: (w digitAt: 3). self at: i + 2 put: (w digitAt: 2). self at: i + 3 put: (w digitAt: 1)! ! !ByteArray methodsFor: 'accessing'! wordAt: i "Answer the value of the word (2 bytes) starting at index i." | j | j _ i + i. ^((self at: j - 1) bitShift: 8) + (self at: j)! ! !ByteArray methodsFor: 'accessing'! wordAt: i put: v "Set the value of the word (2 bytes) starting at index i." | j | j _ i + i. self at: j - 1 put: ((v bitShift: -8) bitAnd: 8r377). self at: j put: (v bitAnd: 8r377)! ! !ByteArray methodsFor: 'private'! defaultElement ^0! ! !ByteArray methodsFor: 'private'! replaceFrom: start to: stop with: replacement startingAt: repStart "Primitive. This destructively replaces elements from start to stop in the receiver starting at index, repStart, in the collection, replacement. Answer the receiver. Range checks are performed in the primitive only. Optional. See Object documentation whatIsAPrimitive." super replaceFrom: start to: stop with: replacement startingAt: repStart! ! Object subclass: #CCodeGenerator instanceVariableNames: 'translationDict inlineList constants variables variableDeclarations methods variablesSetCache ' classVariableNames: '' poolDictionaries: '' category: 'Squeak-Translation to C'! !CCodeGenerator commentStamp: 'di 5/22/1998 16:32' prior: 0! 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' stamp: 'ikp 12/4/97 23:01'! 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). ]. "ikp..." aClass sharedPools do: [:pool | pool associationsDo: [ :assoc | constants at: assoc key put: (TConstantNode new setValue: assoc value). ]. ]. variables addAll: aClass instVarNames. 'Adding Class ' , aClass name , '...' displayProgressAt: Sensor cursorPoint from: 0 to: aClass selectors size during: [: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' stamp: 'jm 1/5/98 16:36'! addClassVarsFor: aClass "Add the class variables for the given class (and its superclasses) to the code base as constants." | allClasses | allClasses _ aClass allSuperclasses asOrderedCollection. allClasses add: aClass. allClasses do: [:c | c classPool associationsDo: [:assoc | constants at: assoc key put: (TConstantNode new setValue: assoc value)]]. ! ! !CCodeGenerator methodsFor: 'public' stamp: 'ikp 9/26/97 14:48'! 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 doAssertions: true. ^stream contents! ! !CCodeGenerator methodsFor: 'public' stamp: 'jm 2/15/98 18:26'! codeStringForPrimitives: classAndSelectorList | sel aClass source s verbose meth | self initialize. classAndSelectorList do: [:classAndSelector | aClass _ Smalltalk at: (classAndSelector at: 1). self addClassVarsFor: aClass. sel _ classAndSelector at: 2. (aClass includesSelector: sel) ifTrue: [source _ aClass sourceCodeAt: sel] ifFalse: [source _ aClass class sourceCodeAt: sel]. meth _ ((Compiler new parse: source in: aClass notifying: nil) asTMethodFromClass: aClass). meth primitive > 0 ifTrue: [meth preparePrimitiveInClass: aClass]. "for old-style array accessing: meth covertToZeroBasedArrayReferences." meth replaceSizeMessages. self addMethod: meth]. "method preparation" verbose _ false. self prepareMethods. verbose ifTrue: [ self printUnboundCallWarnings. self printUnboundVariableReferenceWarnings. Transcript cr]. "code generation" self doInlining: true. s _ ReadWriteStream on: (String new: 1000). 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: 'ikp 9/26/97 14:50'! storeCodeOnFile: fileName doInlining: inlineFlag "Store C code for this code base on the given file." self storeCodeOnFile: fileName doInlining: inlineFlag doAssertions: true! ! !CCodeGenerator methodsFor: 'public' stamp: 'ikp 9/26/97 14:50'! storeCodeOnFile: fileName doInlining: inlineFlag doAssertions: assertionFlag "Store C code for this code base on the given file." | stream | stream _ FileStream newFileNamed: fileName. self emitCCodeOn: stream doInlining: inlineFlag doAssertions: assertionFlag. 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' stamp: 'ikp 12/4/97 22:56'! 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. ]. ]. "ikp..." aClass sharedPools do: [:pool | pool 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' stamp: 'ikp 1/3/98 23:13'! doInlining: inlineFlag "Inline the bodies of all methods that are suitable for inlining." "Modified slightly for the translator, since the first level of inlining for the interpret loop must be performed in order that the instruction implementations can easily discover their addresses." "Interpreter translate: 'InterpTest.c' doInlining: true" | pass progress | inlineFlag ifFalse: [ ^self inlineDispatchesInMethodNamed: #interpret localizingVars: #(). ]. 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: 3 during: [ :bar | self inlineDispatchesInMethodNamed: #interpret localizingVars: #(currentBytecode localIP localSP localCP localTP). bar value: 1. "xxx (methods includesKey: #translateNewMethod) ifTrue: [self inlineDispatchesInMethodNamed: #translateNewMethod localizingVars: #(currentByte bytePointer opPointer). self removeMethodsReferingToGlobals: #(currentByte bytePointer opPointer) except: #translateNewMethod. ]. xxx" bar value: 2. self removeMethodsReferingToGlobals: #(currentBytecode localIP localSP localCP localTP) except: #interpret. bar value: 3. ]. ! ! !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' stamp: 'ikp 9/26/97 14:50'! removeAssertions "Remove all assertions in method bodies. This is for the benefit of inlining, which fails to recognise and disregard empty method bodies when checking the inlinability of sends." | newMethods | newMethods _ Dictionary new. 'Removing assertions...' displayProgressAt: Sensor cursorPoint from: 0 to: methods size during: [ :bar | methods doWithIndex: [ :m :i | bar value: i. m isAssertion ifFalse: [ newMethods at: m selector put: m. m removeAssertions]]]. methods _ newMethods.! ! !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' stamp: 'ikp 12/2/97 19:40'! cLiteralFor: anObject "Return a string representing the C literal value for the given object." | s | (anObject isKindOf: Integer) ifTrue: [ (anObject < 16r7FFFFFFF) ifTrue: [^ anObject printString] ifFalse: [^ anObject printString , 'U']]. (anObject isKindOf: String) ifTrue: [^ '"', anObject, '"' ]. (anObject isKindOf: Float) ifTrue: [^ anObject printString ]. anObject == nil ifTrue: [^ 'null' ]. anObject == true ifTrue: [^ '1' ]. "ikp" anObject == false ifTrue: [^ '0' ]. "ikp" self error: "ikp" 'Warning: A Smalltalk literal could not be translated into a C constant: ', anObject printString. ^'"XXX UNTRANSLATABLE CONSTANT XXX"'! ! !CCodeGenerator methodsFor: 'C code generator' stamp: 'ikp 12/7/97 20:54'! emitCCodeOn: aStream doInlining: inlineFlag self emitCCodeOn: aStream doInlining: inlineFlag doAssertions: true! ! !CCodeGenerator methodsFor: 'C code generator' stamp: 'ikp 12/7/97 20:54'! emitCCodeOn: aStream doInlining: inlineFlag doAssertions: assertionFlag "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. ]. assertionFlag ifFalse: [ self removeAssertions ]. self doInlining: inlineFlag. "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 cursorPoint from: 0 to: methods size during: [: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' stamp: 'ikp 1/4/98 00:03'! 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 Functions/Variables ***/ extern int stackValue(int); extern int successFlag; '. aStream cr.! ! !CCodeGenerator methodsFor: 'C code generator' stamp: 'jm 2/1/98 15:35'! 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. aStream nextPutAll: '#include "sqMachDep.h" /* needed only by the JIT virtual machine */'; 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' stamp: 'jm 2/15/98 17:07'! 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: #basicAt: #generateAt:on:indent: #basicAt: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 instanceVariableNames: ''! !CCodeGenerator class methodsFor: 'removing from system' stamp: 'jm 5/16/1998 10:26'! 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'. ]. Smalltalk at: #AbstractSound ifPresent: [:abstractSound | abstractSound class removeCategory: 'primitive generation']. ! ! SwikiAction subclass: #CachedSwikiAction instanceVariableNames: 'cacheDirectory cacheURL pwsURL ' classVariableNames: '' poolDictionaries: '' category: 'PluggableWebServer'! !CachedSwikiAction commentStamp: 'di 5/22/1998 16:32' prior: 0! CachedSwikiAction caches SwikiAction pages so that they can be served as plain HTML files (no embedded Squeak code) even by a native webServer. You must edit three class methods in CachedSwikiAction to get it to serve appropriately. * CachedSwikiAction class defaultCacheDirectory is where to store cached pages * CachedSwikiAction class defaultCacheURL is the URL to precede cached pages * CachedSwikiAction class defaultPWSURL is where the PWS is that can handle editing and searching. ! ]style[(25 12 201 45 34 39 38 37 61)f1,f1LSwikiAction Comment;,f1,f1LCachedSwikiAction class defaultCacheDirectory;,f1,f1LCachedSwikiAction class defaultCacheURL;,f1,f1LCachedSwikiAction class defaultPWSURL;,f1! !CachedSwikiAction methodsFor: 'save/restore' stamp: 'mjg 3/18/98 12:44'! restore: nameOfSwiki super restore: nameOfSwiki. self source: 'cswiki',(ServerAction pathSeparator). self cacheDirectory: (self class defaultCacheDirectory). self cacheURL: (self class defaultCacheURL). self pwsURL: (self class defaultPWSURL). self generate. ! ! !CachedSwikiAction methodsFor: 'save/restore' stamp: 'mjg 3/23/98 11:35'! restoreNoGen: nameOfSwiki super restore: nameOfSwiki. self source: 'cswiki',(ServerAction pathSeparator). self cacheDirectory: (self class defaultCacheDirectory). self cacheURL: (self class defaultCacheURL). self pwsURL: (self class defaultPWSURL). "self generate." ! ! !CachedSwikiAction methodsFor: 'URL processing' stamp: 'mjg 3/18/98 12:41'! browse: pageRef from: request "Just reply with a page in HTML format" | formattedPage | formattedPage _ pageRef copy. "Make a copy, then format the text." formattedPage formatted: (HTMLformatter swikify: pageRef text linkhandler: [:link | urlmap linkForCache: link from: request peerName storingTo: OrderedCollection new]). request reply: (HTMLformatter evalEmbedded: (self fileContents: source ,'page.html') with: formattedPage). ! ! !CachedSwikiAction methodsFor: 'URL processing' stamp: 'mjg 3/18/98 12:34'! generate 1 to: (urlmap pages size) do: [:ref | self generate: (urlmap atID: ref) from: 'Beginning'.]. self generateRecent. ! ! !CachedSwikiAction methodsFor: 'URL processing' stamp: 'mjg 3/26/98 12:39'! generate: pageRef from: request "Just reply with a page in HTML format" | formattedPage peer cacheFile file| (request isKindOf: PWS) ifFalse: [(request isKindOf: String) ifTrue: [peer _ request] ifFalse: [peer _ ' ']] ifTrue: [peer _ request peerName]. formattedPage _ pageRef copy. "Make a copy, then format the text." formattedPage formatted: (HTMLformatter swikify: pageRef text linkhandler: [:link | urlmap linkForCache: link from: peer storingTo: OrderedCollection new]). cacheFile _ (self cacheDirectory),(self name),(ServerAction pathSeparator),(pageRef coreID),'.html'. (StandardFileStream isAFileNamed: cacheFile) ifTrue: [FileDirectory deleteFilePath: cacheFile]. file _ FileStream fileNamed: cacheFile. file nextPutAll: (HTMLformatter evalEmbedded: (self fileContents: source ,'page.html') with: formattedPage). file close. ! ! !CachedSwikiAction methodsFor: 'URL processing' stamp: 'mjg 3/18/98 12:21'! generateRecent | file | file _ FileStream fileNamed: (self cacheDirectory),(self name),(ServerAction pathSeparator),'recent.html'. file nextPutAll: (HTMLformatter evalEmbedded: (self fileContents: source, 'recent.html') with: urlmap recentCache). file close.! ! !CachedSwikiAction methodsFor: 'URL processing' stamp: 'mjg 3/23/98 11:44'! inputFrom: request "Take user's input and respond with a searchresult or store the edit" | coreRef page | coreRef _ request message size < 2 ifTrue: ['1'] ifFalse: [request message at: 2]. coreRef = 'searchresult' ifTrue: [ "If contains search string, do search" request reply: PWS crlf, (HTMLformatter evalEmbedded: (self fileContents: source, 'results.html') with: (urlmap searchCacheFor: (request fields at: 'searchFor' ifAbsent: ['nothing']))). ^ #return]. (request fields includesKey: 'text') ifTrue: ["It's a response from an edit, so store the page" page _ urlmap storeID: coreRef text: (request fields at: 'text' ifAbsent: ['blank text']) from: request peerName. page user: request userID. "Address is machine, user only if logged in" self generate: (urlmap atID: coreRef) from: request. self generateRecent. ^ self]. "return self means do serve the edited page afterwards" "oops, a new kind!!" Transcript show: 'Unknown data from client. '; show: request fields printString; cr.! ! !CachedSwikiAction methodsFor: 'access' stamp: 'mjg 3/18/98 11:39'! cacheDirectory ^cacheDirectory! ! !CachedSwikiAction methodsFor: 'access' stamp: 'mjg 3/18/98 11:39'! cacheDirectory: directory cacheDirectory _ directory! ! !CachedSwikiAction methodsFor: 'access' stamp: 'mjg 3/18/98 11:44'! cacheURL ^cacheURL! ! !CachedSwikiAction methodsFor: 'access' stamp: 'mjg 3/18/98 11:44'! cacheURL: urlString cacheURL _ urlString! ! !CachedSwikiAction methodsFor: 'access' stamp: 'mjg 3/18/98 12:44'! pwsURL ^pwsURL ! ! !CachedSwikiAction methodsFor: 'access' stamp: 'mjg 3/18/98 12:44'! pwsURL: urlString pwsURL _ urlString ! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! CachedSwikiAction class instanceVariableNames: ''! !CachedSwikiAction class methodsFor: 'initialization' stamp: 'tk 5/21/1998 12:58'! setUp: named | newAction | super setUp: named. newAction _ PWS actions at: named. newAction cacheDirectory: (self defaultCacheDirectory). newAction cacheURL: (self defaultCacheURL). newAction source: 'cswiki',(ServerAction pathSeparator). ^ newAction! ! !CachedSwikiAction class methodsFor: 'services' stamp: 'mjg 3/23/98 12:05'! defaultCacheDirectory ^'Guz 7600:WebSTAR 2.0:'! ! !CachedSwikiAction class methodsFor: 'services' stamp: 'mjg 3/23/98 12:05'! defaultCacheURL ^'http://guzdial.cc.gatech.edu/'! ! !CachedSwikiAction class methodsFor: 'services' stamp: 'mjg 3/23/98 12:05'! defaultPWSURL ^'http://guzdial.cc.gatech.edu:8080/'! ! Morph subclass: #CachingMorph instanceVariableNames: 'damageRecorder cacheCanvas ' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Kernel'! !CachingMorph commentStamp: 'di 5/22/1998 16:32' prior: 0! 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' stamp: 'jm 11/13/97 16:31'! releaseCachedState super releaseCachedState. cacheCanvas _ nil. ! ! !CachingMorph methodsFor: 'all' stamp: 'jm 7/30/97 12:43'! 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). damageRecorder reset. rectList do: [:r | c _ cacheCanvas copyOrigin: myBnds origin negated clipRect: r. c fillColor: Color transparent. "clear to transparent" super fullDrawOn: c]. ! ! Object subclass: #Canvas instanceVariableNames: 'origin clipRect shadowDrawing ' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Support'! !Canvas commentStamp: 'di 5/22/1998 16:32' prior: 0! 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' stamp: 'jm 8/2/97 13:54'! copy ^ self clone ! ! !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' stamp: 'jm 8/2/97 13:54'! fillOval: r color: c self fillOval: r color: c borderWidth: 0 borderColor: Color transparent. ! ! !Canvas methodsFor: 'drawing' stamp: 'jm 8/2/97 13:54'! fillOval: r color: c borderWidth: borderWidth borderColor: borderColor "Noop here; overridden by non-trivial canvases." ! ! !Canvas methodsFor: 'drawing'! fillRectangle: r color: c "Noop here; overridden by non-trivial canvases."! ! !Canvas methodsFor: 'drawing' stamp: 'jm 8/2/97 13:54'! frameAndFillRectangle: r fillColor: fillColor borderWidth: borderWidth borderColor: borderColor "Noop here; overridden by non-trivial canvases." ! ! !Canvas methodsFor: 'drawing' stamp: 'jm 8/2/97 13:54'! frameAndFillRectangle: r fillColor: fillColor borderWidth: borderWidth topLeftColor: topLeftColor bottomRightColor: bottomRightColor "Noop here; overridden by non-trivial canvases." ! ! !Canvas methodsFor: 'drawing' stamp: 'jm 8/2/97 14:08'! frameOval: r color: c self fillOval: r color: Color transparent borderWidth: 1 borderColor: c. ! ! !Canvas methodsFor: 'drawing' stamp: 'jm 8/2/97 14:10'! frameOval: r width: w color: c self fillOval: r color: Color transparent borderWidth: w borderColor: c. ! ! !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'! image: i at: aPoint "Noop here; overridden by non-trivial canvases."! ! !Canvas methodsFor: 'drawing' stamp: 'jm 7/28/97 14:30'! image: aForm at: aPoint sourceRect: sourceRect rule: rule "Noop here; overridden by non-trivial canvases." ! ! !Canvas methodsFor: 'drawing' stamp: 'jm 8/2/97 13:54'! 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' stamp: 'jm 8/2/97 13:54'! text: s at: pt font: fontOrNil color: c ^ self text: s bounds: (pt extent: 10000@10000) font: fontOrNil color: c ! ! !Canvas methodsFor: 'drawing' stamp: 'jm 8/2/97 13:54'! text: s bounds: boundsRect font: fontOrNil color: c "Draw the given string in the given font and color clipped to the given rectangle. If the font is nil, the default font is used. Noop here; overridden by non-trivial canvases." ! ! !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.! ! ParseNode subclass: #CascadeNode instanceVariableNames: 'receiver messages ' classVariableNames: '' poolDictionaries: '' category: 'System-Compiler'! !CascadeNode commentStamp: 'di 5/22/1998 16:32' prior: 0! CascadeNode comment: 'The first message has the common receiver, the rest have receiver == nil, which signifies cascading.'! !CascadeNode methodsFor: 'initialize-release'! receiver: receivingObject messages: msgs " Transcript show: 'abc'; cr; show: 'def' " receiver _ receivingObject. messages _ msgs! ! !CascadeNode methodsFor: 'code generation'! emitForValue: stack on: aStream receiver emitForValue: stack on: aStream. 1 to: messages size - 1 do: [:i | aStream nextPut: Dup. stack push: 1. (messages at: i) emitForValue: stack on: aStream. aStream nextPut: Pop. stack pop: 1]. messages last emitForValue: stack on: aStream! ! !CascadeNode methodsFor: 'code generation'! sizeForValue: encoder | size | size _ (receiver sizeForValue: encoder) + (messages size - 1 * 2). messages do: [:aMessage | size _ size + (aMessage sizeForValue: encoder)]. ^size! ! !CascadeNode methodsFor: 'printing'! printOn: aStream indent: level self printOn: aStream indent: level precedence: 0! ! !CascadeNode methodsFor: 'printing'! printOn: aStream indent: level precedence: p | thisPrec | p > 0 ifTrue: [aStream nextPut: $(]. thisPrec _ messages first precedence. receiver printOn: aStream indent: level precedence: thisPrec. 1 to: messages size do: [:i | (messages at: i) printOn: aStream indent: level. i < messages size ifTrue: [aStream nextPut: $;. thisPrec >= 2 ifTrue: [aStream crtab: level]]]. p > 0 ifTrue: [aStream nextPut: $)]! ! !CascadeNode methodsFor: 'C translation'! asTranslatorNode ^TStmtListNode new setArguments: #() statements: (messages collect: [ :msg | msg asTranslatorNode receiver: receiver asTranslatorNode ])! ! Object subclass: #CautiousModel instanceVariableNames: 'initialExtent ' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Support'! !CautiousModel methodsFor: 'all' stamp: 'sw 8/15/97 17:20'! fullScreenSize "Answer the size to which a window displaying the receiver should be set" ^ (0@0 extent: DisplayScreen actualScreenSize) copy! ! !CautiousModel methodsFor: 'all' stamp: 'sw 10/2/97 23:16'! initialExtent initialExtent ifNotNil: [^ initialExtent]. ^ super initialExtent! ! !CautiousModel methodsFor: 'all' stamp: 'sw 10/2/97 23:16'! initialExtent: anExtent initialExtent _ anExtent! ! !CautiousModel methodsFor: 'all' stamp: 'sw 10/2/97 16:19'! okToChange | parms | (parms _ Smalltalk at: #EToyParameters ifAbsent: [nil]) ifNotNil: [parms cautionBeforeClosing ifFalse: [^ true]]. Sensor leftShiftDown ifTrue: [^ true]. self beep. ^ self confirm: 'Warning!! If you answer "yes" here, this window will disappear and its contents will be lost!! Do you really want to do that?' "CautiousModel new okToChange"! ! StringHolder subclass: #ChangeList instanceVariableNames: 'changeList list listIndex listSelections file lostMethodPointer ' classVariableNames: '' poolDictionaries: '' category: 'Interface-Changes'! !ChangeList commentStamp: 'di 5/22/1998 16:32' prior: 0! A ChangeList represents a list of changed methods that reside on a file in fileOut format. The classes and methods in my list are not necessarily in this image!! Used as the model for both Version Lists and Changed Methods (in Screen Menu, Changes...). Note that the two kinds of window have different controller classes!!!! It holds three lists: changeList - a list of ChangeRecords list - a list of one-line printable headers listSelections - a list of Booleans (true = selected, false = not selected) multiple OK. listIndex Items that are removed (removeDoits, remove an item) are removed from all three lists. Most recently clicked item is the one showing in the bottom pane.! !ChangeList methodsFor: 'initialization-release'! addItem: item text: text | cr | cr _ Character cr. changeList addLast: item. list addLast: (text collect: [:x | x = cr ifTrue: [$/] ifFalse: [x]])! ! !ChangeList methodsFor: 'scanning' stamp: 'sw 1/15/98 21:56'! scanCategory "Scan anything that involves more than one chunk; method name is historical only" | itemPosition item tokens stamp isComment anIndex | itemPosition _ file position. item _ file nextChunk. isComment _ (item includesSubString: 'commentStamp:'). (isComment or: [item includesSubString: 'methodsFor:']) ifFalse: ["Maybe a preamble, but not one we recognize; bail out with the preamble trick" ^ 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 _ ''. anIndex _ tokens indexOf: #stamp: ifAbsent: [nil]. anIndex ifNotNil: [stamp _ tokens at: (anIndex + 1)]. tokens second == #methodsFor: ifTrue: [^ self scanCategory: tokens third class: tokens first meta: false stamp: stamp]. tokens third == #methodsFor: ifTrue: [^ self scanCategory: tokens fourth class: tokens first meta: true stamp: stamp]]. tokens second == #commentStamp: ifTrue: [stamp _ tokens third. self addItem: (ChangeRecord new file: file position: file position type: #classComment class: tokens first category: nil meta: false stamp: stamp) text: 'class comment for ' , tokens first, (stamp isEmpty ifTrue: [''] ifFalse: ['; ' , stamp]). file nextChunk. ^ file skipStyleChunk]! ! !ChangeList methodsFor: 'scanning' stamp: 'di 1/13/98 16:56'! scanCategory: category class: class meta: meta stamp: stamp | itemPosition method | [itemPosition _ file position. method _ file nextChunk. file skipStyleChunk. 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 1/13/98 16:57'! scanFile: aFile from: startPosition to: stopPosition | itemPosition item prevChar | file _ aFile. changeList _ OrderedCollection new. list _ OrderedCollection new. listIndex _ 0. file position: startPosition. 'Scanning changes...' displayProgressAt: Sensor cursorPoint from: startPosition to: stopPosition during: [:bar | [file position < stopPosition] whileTrue: [bar value: file position. [file atEnd not and: [file peek isSeparator]] whileTrue: [prevChar _ file next]. (file peekFor: $!!) ifTrue: [prevChar = Character cr ifTrue: [self scanCategory]] ifFalse: [itemPosition _ file position. item _ file nextChunk. file skipStyleChunk. item size > 0 ifTrue: [self addItem: (ChangeRecord new file: file position: itemPosition type: #doIt) text: 'do it: ' , (item contractTo: 50)]]]]. listSelections _ Array new: list size withAll: false! ! !ChangeList methodsFor: 'scanning' stamp: 'di 5/17/1998 12:01'! 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]]. method fileIndex == 0 ifTrue: [self inform: 'Not Logged, no versions'. ^ nil]. 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 _ ''. (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: 'scanning' stamp: 'tk 4/24/1998 23:32'! toggleListIndex: newListIndex (listIndex ~= 0 and: [listIndex ~= newListIndex]) ifTrue: [listSelections at: listIndex put: false]. "turn off old selection if was on" newListIndex = 0 ifTrue: [listIndex _ 0] ifFalse: [ listSelections at: newListIndex "Complement selection state" put: (listSelections at: newListIndex) not. listIndex _ (listSelections at: newListIndex) ifTrue: [newListIndex] "and set selection index accordingly" ifFalse: [0]]. self changed: #listIndex. self changed: #contents! ! !ChangeList methodsFor: 'menu actions' stamp: 'jm 5/3/1998 19:15'! acceptFrom: aView aView controller text = aView controller initialText ifFalse: [ aView flash. ^ self inform: 'You can only accept this version as-is. If you want to edit, copy the text to a browser']. (aView setText: aView controller text from: self) ifTrue: [aView ifNotNil: [aView controller accept]]. "initialText" ! ! !ChangeList methodsFor: 'menu actions' stamp: 'tk 4/6/98 11:33'! changeListMenu: aMenu ^ aMenu labels: 'fileIn selections fileOut selections... select conflicts select conflicts with select unchanged methods select all deselect all remove doIts remove older versions remove selections' lines: #(2 6) selections: #(fileInSelections fileOutSelections selectConflicts selectConflictsWith selectUnchangedMethods selectAll deselectAll removeDoIts removeOlderMethodVersions removeSelections) ! ! !ChangeList methodsFor: 'menu actions'! deselectAll listIndex _ 0. listSelections atAllPut: false. self changed: #allSelections! ! !ChangeList methodsFor: 'menu actions'! fileInSelections listSelections with: changeList do: [:selected :item | selected ifTrue: [item fileIn]]! ! !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: 'tk 4/21/1998 09:56'! perform: selector orSendTo: otherTarget "Selector was just chosen from a menu by a user. If I can respond, then perform it on myself. If not, send it to otherTarget, presumably the editPane from which the menu was invoked." (#accept == selector) ifTrue: [^ self acceptFrom: otherTarget view]. ^ super perform: selector orSendTo: otherTarget! ! !ChangeList methodsFor: 'menu actions' stamp: 'tk 4/8/98 12:38'! removeDoIts "Remove doits from the receiver, other than initializes. 1/26/96 sw" | newChangeList newList | newChangeList _ OrderedCollection new. newList _ OrderedCollection new. changeList with: list do: [:chRec :str | (chRec type ~~ #doIt or: [str endsWith: 'initialize']) ifTrue: [newChangeList add: chRec. newList add: str]]. newChangeList size < changeList size ifTrue: [changeList _ newChangeList. list _ newList. listIndex _ 0. listSelections _ Array new: list size withAll: false]. self changed: #list. ! ! !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: 'menu actions'! removeSelections "Remove the selected items from the receiver. 9/18/96 sw" | newChangeList newList | newChangeList _ OrderedCollection new. newList _ OrderedCollection new. 1 to: changeList size do: [:i | (listSelections at: i) ifFalse: [newChangeList add: (changeList at: i). newList add: (list at: i)]]. newChangeList size < changeList size ifTrue: [changeList _ newChangeList. list _ newList. listIndex _ 0. listSelections _ Array new: list size withAll: false]. self changed: #list ! ! !ChangeList methodsFor: 'menu actions'! selectAll listIndex _ 0. listSelections atAllPut: true. self changed: #allSelections! ! !ChangeList methodsFor: 'menu actions'! selectConflicts "Selects all method definitions for which there is ALSO an entry in changes" | change class systemChanges | Cursor read showWhile: [1 to: changeList size do: [:i | change _ changeList at: i. listSelections at: i put: (change type = #method and: [(class _ change methodClass) notNil and: [(Smalltalk changes atSelector: change methodSelector class: class) ~~ #none]])]]. self changed: #allSelections! ! !ChangeList methodsFor: 'menu actions'! selectConflicts: changeSetOrList "Selects all method definitions for which there is ALSO an entry in the specified changeSet or changList" | change class systemChanges | Cursor read showWhile: [(changeSetOrList isKindOf: ChangeSet) ifTrue: [ 1 to: changeList size do: [:i | change _ changeList at: i. listSelections at: i put: (change type = #method and: [(class _ change methodClass) notNil and: [(changeSetOrList atSelector: change methodSelector class: class) ~~ #none]])]] ifFalse: ["a ChangeList" 1 to: changeList size do: [:i | change _ changeList at: i. listSelections at: i put: (change type = #method and: [(class _ change methodClass) notNil and: [changeSetOrList list includes: (list at: i)]])]] ]. self changed: #allSelections! ! !ChangeList methodsFor: 'menu actions' stamp: 'jm 5/22/1998 11:31'! selectConflictsWith "Selects all method definitions for which there is ALSO an entry in the specified changeSet or changList chosen by the user. 4/11/96 tk" | aStream all index | aStream _ WriteStream on: (String new: 200). all _ ChangeSet allInstances asOrderedCollection. all do: [:sel | aStream nextPutAll: (sel name contractTo: 40); cr]. ChangeList allInstancesDo: [:sel | aStream nextPutAll: (sel file name); cr. all addLast: sel]. aStream skip: -1. index _ (PopUpMenu labels: aStream contents) startUp. index > 0 ifTrue: [ self selectConflicts: (all at: index)]. ! ! !ChangeList methodsFor: 'menu actions' stamp: 'tk 1/7/98 10:12'! selectUnchangedMethods "Selects all method definitions for which there is already a method in the current image, whose source is exactly the same. 9/18/96 sw" | change class | Cursor read showWhile: [1 to: changeList size do: [:i | change _ changeList at: i. listSelections at: i put: ((change type = #method and: [(class _ change methodClass) notNil]) and: [(class includesSelector: change methodSelector) and: [change string = (class sourceCodeAt: change methodSelector) asString]])]]. self changed: #allSelections! ! !ChangeList methodsFor: 'viewing access' stamp: 'sw 1/15/98 22:45'! contents ^ listIndex = 0 ifTrue: [''] ifFalse: [(changeList at: listIndex) text]! ! !ChangeList methodsFor: 'viewing access' stamp: 'tk 4/10/1998 09:25'! contents: aString listIndex = 0 ifTrue: [self changed: #flash. ^ false]. lostMethodPointer ifNotNil: [^ self restoreDeletedMethod]. self okToChange "means not dirty" ifFalse: ["is dirty" self inform: 'This is a view of a method on a file.\Please cancel your changes. You may\accept, but only when the method is untouched.' withCRs. ^ false]. "Can't accept changes here. Method text must be unchanged!!" (changeList at: listIndex) fileIn. ^ true! ! !ChangeList methodsFor: 'viewing access'! defaultBackgroundColor ^ #lightBlue! ! !ChangeList methodsFor: 'viewing access'! list ^ list! ! !ChangeList methodsFor: 'viewing access'! listIndex ^ listIndex! ! !ChangeList methodsFor: 'viewing access'! listSelectionAt: index ^ listSelections at: index! ! !ChangeList methodsFor: 'viewing access'! listSelectionAt: index put: value listIndex _ 0. ^ listSelections at: index put: value! ! !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: 'viewing access' stamp: 'tk 4/18/1998 09:46'! selectedMessageName ^ (changeList at: listIndex) methodSelector " change _ changeList at: i. ((change type = #method and: [(class _ change methodClass) notNil]) and: [(class includesSelector: change methodSelector "! ! !ChangeList methodsFor: 'accessing'! changeList ^ changeList! ! !ChangeList methodsFor: 'accessing'! file ^file! ! !ChangeList methodsFor: 'accessing' stamp: 'di 6/15/97 15:13'! setLostMethodPointer: sourcePointer lostMethodPointer _ sourcePointer! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ChangeList class instanceVariableNames: ''! !ChangeList class methodsFor: 'public access' stamp: 'di 5/16/1998 21:53'! browseFile: fileName "ChangeList browseFile: 'AutoDeclareFix.st'" "Opens a changeList on the file named fileName" | changesFile changeList | changesFile _ FileStream readOnlyFileNamed: fileName. Cursor read showWhile: [changeList _ self new scanFile: changesFile from: 0 to: changesFile size]. changesFile close. self open: changeList name: fileName , ' log' multiSelect: true! ! !ChangeList class methodsFor: 'public access' stamp: 'di 5/16/1998 21:53'! browseRecent: charCount "ChangeList browseRecent: 5000" "Opens a changeList on the end of the changes log file" | changesFile changeList end | changesFile _ (SourceFiles at: 2) readOnlyCopy. end _ changesFile size. Cursor read showWhile: [changeList _ self new scanFile: changesFile from: (0 max: end-charCount) to: end]. changesFile close. self open: changeList name: 'Recent changes' multiSelect: true! ! !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: 'tk 5/19/1998 14:24'! browseStream: changesFile "Opens a changeList on a fileStream" | changeList | changesFile readOnly. Cursor read showWhile: [changeList _ self new scanFile: changesFile from: 0 to: changesFile size]. changesFile close. self open: changeList name: changesFile localName , ' log' multiSelect: true! ! !ChangeList class methodsFor: 'public access' stamp: 'di 5/16/1998 21:56'! browseVersionsOf: method class: class meta: meta category: category selector: selector | changeList | Cursor read showWhile: [changeList _ self new scanVersionsOf: method class: class meta: meta category: category selector: selector]. changeList ifNotNil: [self open: changeList name: 'Recent versions of ' , selector multiSelect: false]! ! !ChangeList class methodsFor: 'public access' stamp: 'di 5/16/1998 21:56'! 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 open: changeList name: 'Recent versions of ' , selector multiSelect: false! ! !ChangeList class methodsFor: 'public access'! versionCountForSelector: aSelector class: aClass "Answer the number of versions known to the system for the given class and method, including the current version. A result of greater than one means that there is at least one superseded version. 6/28/96 sw" | method | method _ aClass compiledMethodAt: aSelector. ^ (self new scanVersionsOf: method class: aClass meta: aClass isMeta category: nil selector: aSelector) list size! ! !ChangeList class methodsFor: 'instance creation' stamp: 'di 5/17/1998 22:49'! open: aChangeList name: aString multiSelect: multiSelect "Create a standard system view for the messageSet, whose label is aString. The listView may be either single or multiple selection type" | topView aBrowserCodeView aListView | World ifNotNil: [^ self openAsMorph: aChangeList name: aString multiSelect: multiSelect]. topView _ (StandardSystemView new) model: aChangeList. topView label: aString. topView minimumSize: 180 @ 120. topView borderWidth: 1. aListView _ (multiSelect ifTrue: [PluggableListViewOfMany] ifFalse: [PluggableListView]) on: aChangeList list: #list selected: #listIndex changeSelected: #toggleListIndex: menu: #changeListMenu: keystroke: #messageListKey:from:. aListView window: (0 @ 0 extent: 180 @ 100). topView addSubView: aListView. aBrowserCodeView _ PluggableTextView on: aChangeList text: #contents accept: #contents: readSelection: #contentsSelection menu: #codePaneMenu:shifted:. aBrowserCodeView controller: ReadOnlyTextController new. aBrowserCodeView window: (0 @ 0 extent: 180 @ 300). topView addSubView: aBrowserCodeView below: aListView. topView controller open! ! !ChangeList class methodsFor: 'instance creation' stamp: 'di 5/16/1998 22:15'! openAsMorph: aChangeList name: labelString multiSelect: multiSelect "Open a morphic view for the messageSet, whose label is labelString. The listView may be either single or multiple selection type" | window listView textMorph | window _ (SystemWindow labelled: labelString) model: aChangeList. window addMorph: (listView _ PluggableListMorph on: aChangeList list: #list selected: #listIndex changeSelected: #toggleListIndex: menu: #changeListMenu: keystroke: #messageListKey:from:) frame: (0@0 corner: 1@0.3). " multiSelect ifTrue: [listView controller: PluggableListControllerOfMany new]. " window addMorph: (textMorph _ PluggableTextMorph on: aChangeList text: #contents accept: #contents: readSelection: #contentsSelection menu: #codePaneMenu:shifted:) frame: (0@0.3 corner: 1@1). " textMorph controller: ReadOnlyTextController new. " ^ window openInWorld! ! Object subclass: #ChangeRecord instanceVariableNames: 'file position type class category meta stamp ' classVariableNames: '' poolDictionaries: '' category: 'Interface-Changes'! !ChangeRecord commentStamp: 'di 5/22/1998 16:32' prior: 0! ChangeRecord comment: 'A ChangeRecord represents a change recorded on a file in fileOut format. It includes a type (more needs to be done here), and additional information for certain types such as method defs which need class and category.'! !ChangeRecord methodsFor: 'access' stamp: 'sw 1/15/98 22:46'! fileIn | methodClass | Cursor read showWhile: [(methodClass _ self methodClass) notNil ifTrue: [methodClass compile: self text classified: category withStamp: stamp notifying: nil]. (type == #doIt) ifTrue: [Compiler evaluate: self string]. (type == #classComment) ifTrue: [(Smalltalk at: class asSymbol) comment: self text]]! ! !ChangeRecord methodsFor: 'access' stamp: 'sw 1/15/98 22:09'! fileOutOn: f type == #method ifTrue: [f nextPut: $!!. f nextChunkPut: class asString , (meta ifTrue: [' class methodsFor: '] ifFalse: [' methodsFor: ']) , category asString printString. f cr]. type == #preamble ifTrue: [f nextPut: $!!]. type == #classComment ifTrue: [f nextPut: $!!. f nextChunkPut: class asString, ' commentStamp: ', stamp storeString. f cr]. f nextChunkPut: self string. type == #method ifTrue: [f nextChunkPut: ' ']. f cr! ! !ChangeRecord methodsFor: 'access'! methodClass | methodClass | type == #method ifFalse: [^ nil]. (Smalltalk includesKey: class asSymbol) ifFalse: [^ nil]. methodClass _ Smalltalk at: class asSymbol. meta ifTrue: [^ methodClass class] ifFalse: [^ methodClass]! ! !ChangeRecord methodsFor: 'access'! methodSelector type == #method ifFalse: [^ nil]. ^ Parser new parseSelector: self string! ! !ChangeRecord methodsFor: 'access' stamp: '6/6/97 08:56 dhhi'! stamp ^ stamp! ! !ChangeRecord methodsFor: 'access' stamp: 'di 1/13/98 16:57'! string | string | file openReadOnly. file position: position. string _ file nextChunk. file close. ^ string! ! !ChangeRecord methodsFor: 'access' stamp: 'sw 1/15/98 22:35'! text | text | file openReadOnly. file position: position. text _ file nextChunkText. file close. ^ text! ! !ChangeRecord methodsFor: 'access'! type ^ type! ! !ChangeRecord methodsFor: 'initialization'! file: f position: p type: t file _ f. position _ p. type _ t! ! !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! ! Object subclass: #ChangeSet instanceVariableNames: 'classChanges methodChanges classRemoves methodRemoves name preamble postscript ' classVariableNames: '' poolDictionaries: '' category: 'Interface-Changes'! !ChangeSet commentStamp: 'di 5/22/1998 16:32' prior: 0! 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: 'tk 5/4/1998 16:41'! editPostscript "edit the receiver's postscript, in a separate window. " self assurePostscriptExists. postscript openLabel: 'Postscript for ChangeSet named ', name! ! !ChangeSet methodsFor: 'initialize-release' stamp: 'di 5/21/1998 20:50'! initialize "Reset the receiver to be empty." self wither. "Avoid duplicate entries in AllChangeSets if initialize gets called twice" name _ ChangeSet defaultName! ! !ChangeSet methodsFor: 'initialize-release'! isMoribund "Answer whether the receiver is obsolete and about to die; part of an effort to get such guys cleared out from the change sorter. 2/7/96 sw" ^ name == nil ! ! !ChangeSet methodsFor: 'initialize-release' stamp: 'di 5/21/1998 20:50'! wither "The receiver is to be clobbered. Clear it out. 2/7/96 sw" classChanges _ Dictionary new. methodChanges _ Dictionary new. classRemoves _ Set new. methodRemoves _ Dictionary new. name _ nil! ! !ChangeSet methodsFor: 'testing' stamp: 'jm 5/22/1998 11:33'! belongsToAProject Project allInstancesDo: [:proj | proj projectChangeSet == self ifTrue: [^ true]]. ^ false ! ! !ChangeSet methodsFor: 'testing' stamp: 'tk 5/7/1998 12:57'! classChangeAt: className "Return what we know about class changes to this class." | this | this _ classChanges at: className ifAbsent: [Set new]. (classRemoves includes: className) ifTrue: [this add: #remove]. ^ this! ! !ChangeSet methodsFor: 'testing'! classRemoves ^ classRemoves! ! !ChangeSet methodsFor: 'testing'! isEmpty "Answer whether the receiver contains any elements." ^(methodChanges isEmpty and: [classChanges isEmpty]) and: [classRemoves isEmpty]! ! !ChangeSet methodsFor: 'testing'! methodChangesAtClass: className "Return what we know about method changes to this class." ^ methodChanges at: className ifAbsent: [Dictionary new].! ! !ChangeSet methodsFor: 'testing'! name "The name of this changeSet. 2/7/96 sw: If name is nil, we've got garbage. Help to identify." ^ name == nil ifTrue: [''] ifFalse: [name]! ! !ChangeSet methodsFor: 'testing' stamp: 'sw 10/1/97 17:59'! okayToRemove | aName | aName _ self name. self == Smalltalk changes ifTrue: [self inform: 'Cannot remove "', aName, '" because it is the current change set.'. ^ false]. self belongsToAProject ifTrue: [self inform: 'Cannot remove "', aName, '" because it belongs to a project.'. ^ false]. ^ true ! ! !ChangeSet methodsFor: 'converting'! asSortedCollection "Answer a SortedCollection whose elements are the elements of the receiver. The sort order is the default less than or equal ordering." | result | result _ SortedCollection new. classChanges associationsDo: [:clAssoc | clAssoc value do: [:changeType | result add: clAssoc key, ' - ', changeType]]. methodChanges associationsDo: [:clAssoc | clAssoc value associationsDo: [:mAssoc | result add: clAssoc key, ' ', mAssoc key, ' - ', mAssoc value]]. classRemoves do: [:cName | result add: cName , ' - ', 'remove']. ^ result! ! !ChangeSet methodsFor: 'change management' stamp: 'di 5/6/1998 16:39'! absorbChangesInChangeSetsNamed: nameList "Absorb into the receiver all the changes found in change sets of the given names. *** classes renamed in aChangeSet may have have problems" | aChangeSet | nameList do: [:aName | (aChangeSet _ ChangeSorter changeSetNamed: aName) ~~ nil ifTrue: [self assimilateAllChangesFoundIn: aChangeSet]]! ! !ChangeSet methodsFor: 'change management'! addClass: class "Include indication that a new class was created." self atClass: class add: #add! ! !ChangeSet methodsFor: 'change management' stamp: 'tk 5/7/1998 13:24'! assimilateAllChangesFoundIn: aChangeSet "Make all changes in aChangeSet take effect on self as if they happened just now. *** classes renamed in aChangeSet may have have problems" | cls info selector pair | aChangeSet changedClassNames do: [:className | (cls _ Smalltalk classNamed: className) ifNotNil: [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]]]]. classRemoves addAll: aChangeSet classRemoves. "names of them" ! ! !ChangeSet methodsFor: 'change management'! changeClass: class "Include indication that a class definition has been changed. 6/10/96 sw: don't accumulate this information for classes that don't want logging 7/12/96 sw: use wantsChangeSetLogging flag" class wantsChangeSetLogging ifTrue: [self atClass: class add: #change]! ! !ChangeSet methodsFor: 'change management'! changedClasses "Answer a OrderedCollection of changed or edited classes. Not including removed classes. Sort alphabetically by name." "Much faster to sort names first, then convert back to classes. Because metaclasses reconstruct their name at every comparison in the sorted collection. 8/91 sw chgd to filter out non-existent classes (triggered by problems with class-renames" classChanges == nil ifTrue: [^ OrderedCollection new]. ^ self changedClassNames collect: [:className | Smalltalk classNamed: className] thenSelect: [:aClass | aClass notNil]! ! !ChangeSet methodsFor: 'change management' stamp: 'tk 5/7/1998 12:55'! changedClassNames "Answer a OrderedCollection of the names of changed or edited classes. DOES include removed classes. Sort alphabetically." | classes | classes _ SortedCollection new: (methodChanges size + classChanges size) *2. methodChanges keys do: [:className | classes add: className]. classChanges keys do: [:className | (methodChanges includesKey: className) ifFalse: [ "avoid duplicates, faster than (classes addIfNotPresent: xx)" classes add: className]]. classRemoves do: [:className | classes addIfNotPresent: className]. ^ classes asOrderedCollection! ! !ChangeSet methodsFor: 'change management'! commentClass: class "Include indication that a class comment has been changed." self atClass: class add: #comment! ! !ChangeSet methodsFor: 'change management'! flushClassRemoves classRemoves _ Set new! ! !ChangeSet methodsFor: 'change management' stamp: 'sw 5/21/1998 18:30'! forgetAllChangesFoundIn: aChangeSet "Remove from the receiver all method changes found in aChangeSet. The intention is facilitate the process of factoring a large set of changes into disjoint change sets. To use: in a change sorter, copy over all the changes you want into some new change set, then use the subtract-other-side feature to subtract those changes from the larger change set, and continue in this manner. (But, remember that if a changeSet says #add, but the method is missing in the image, it won't file out!!)" | cls itsMethodChanges | aChangeSet == self ifTrue: [^ self]. aChangeSet changedClassNames do: [:className | (cls _ Smalltalk classNamed: className) ~~ nil ifTrue: [itsMethodChanges _ aChangeSet methodChanges at: className ifAbsent: [Dictionary new]. itsMethodChanges associationsDo: [:assoc | self undoChange: assoc value for: assoc key class: cls]. "try to undo the change found in aChangeSet" (aChangeSet hasClassChangesFor: className) ifTrue: [self removeClassChanges: cls]]]. classRemoves removeAllFoundIn: aChangeSet classRemoves. "names of them" ! ! !ChangeSet methodsFor: 'change management' stamp: 'sw 2/3/98 14:21'! hasClassChangesFor: aKey ^ classChanges includesKey: aKey! ! !ChangeSet methodsFor: 'change management' stamp: 'sw 9/17/97 20:47'! noteRemovalOf: aClass "The class is about to be removed from the system. Adjust the receiver to reflect that fact." classChanges removeKey: aClass name ifAbsent: []. methodChanges removeKey: aClass name ifAbsent: []. classChanges removeKey: aClass class name ifAbsent: []. methodChanges removeKey: aClass class name ifAbsent: []. classRemoves add: aClass name! ! !ChangeSet methodsFor: 'change management'! removeClassAndMetaClassChanges: class "Remove all memory of changes associated with this class and its metaclass. 7/18/96 sw" classChanges removeKey: class name ifAbsent: []. methodChanges removeKey: class name ifAbsent: []. classChanges removeKey: class class name ifAbsent: []. methodChanges removeKey: class class name ifAbsent: []. classRemoves remove: class name ifAbsent: [].! ! !ChangeSet methodsFor: 'change management'! removeClassChanges: class "Remove all memory of changes associated with this class" classChanges removeKey: class name ifAbsent: []. methodChanges removeKey: class name ifAbsent: []. classRemoves remove: class name ifAbsent: [].! ! !ChangeSet methodsFor: 'change management'! renameClass: class as: newName "Include indication that a class has been renamed." | value | (self atClass: class includes: #rename) ifFalse: [self atClass: class add: 'oldName: ', class name. "only original name matters" self atClass: class add: #rename]. "copy changes using new name (metaclass too)" (Array with: classChanges with: methodChanges) do: [:changes | (value _ changes at: class name ifAbsent: [nil]) == nil ifFalse: [changes at: newName put: value. changes removeKey: class name]. (value _ changes at: class class name ifAbsent: [nil]) == nil ifFalse: [changes at: (newName, ' class') put: value. changes removeKey: class class name]]! ! !ChangeSet methodsFor: 'change management'! reorganizeClass: class "Include indication that a class was reorganized." self atClass: class add: #reorganize! ! !ChangeSet methodsFor: 'method changes'! addSelector: selector class: class "Include indication that a method has been added. 5/16/96 sw: tell Utilities of the change so it can put up an in-order browser on recent submissions." Utilities noteMethodSubmission: selector forClass: class name. self atSelector: selector class: class put: #add! ! !ChangeSet methodsFor: 'method changes'! allMessagesForAddedClasses | messageList mAssoc | "Smalltalk changes allMessagesForAddedClasses" messageList _ SortedCollection new. classChanges associationsDo: [:clAssoc | (clAssoc value includes: #add) ifTrue: [(Smalltalk at: clAssoc key) selectorsDo: [:aSelector | messageList add: clAssoc key asString, ' ' , aSelector]. (Smalltalk at: clAssoc key) class selectorsDo: [:aSelector | messageList add: clAssoc key asString, ' class ' , aSelector]]]. ^ messageList asArray! ! !ChangeSet methodsFor: 'method changes'! browseMessagesWithPriorVersions "Open a message list browser on the new and changed methods in the receiver which have at least one prior version. 6/28/96 sw" | aList aSelector aClass | aList _ self changedMessageListAugmented select: [:msg | Utilities setClassAndSelectorFrom: msg in: [:cl :sl | aClass _ cl. aSelector _ sl]. (ChangeList versionCountForSelector: aSelector class: aClass) > 1]. aList size > 0 ifFalse: [self inform: 'None!!'. ^ nil]. Smalltalk browseMessageList: aList name: (self name, ' methods that have prior versions')! ! !ChangeSet methodsFor: 'method changes'! changedMessageList "Used by a message set browser to access the list view information." | messageList | messageList _ SortedCollection new. methodChanges associationsDo: [:clAssoc | clAssoc value associationsDo: [:mAssoc | mAssoc value = #remove ifFalse: [messageList add: clAssoc key asString, ' ' , mAssoc key]]]. ^messageList asArray! ! !ChangeSet methodsFor: 'method changes'! changedMessageListAugmented "In addition to changedMessageList, put all messages for all added classes in the ChangeSet." ^ self changedMessageList asArray, self allMessagesForAddedClasses! ! !ChangeSet methodsFor: 'method changes'! changeSelector: selector class: class "Include indication that a method has been edited. 5/16/96 sw: tell Utilities of the change so it can put up an in-order browser on recent submissions." Utilities noteMethodSubmission: selector forClass: class name. (self atSelector: selector class: class) = #add ifFalse: [self atSelector: selector class: class put: #change] "Don't forget a method is new just because it's been changed"! ! !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: 'method changes'! removeSelectorChanges: selector class: class "Remove all memory of changes associated with the argument, selector, in this class." | dictionary | dictionary _ methodChanges at: class name ifAbsent: [^self]. dictionary removeKey: selector ifAbsent: []. dictionary isEmpty ifTrue: [methodChanges removeKey: class name]! ! !ChangeSet methodsFor: 'method changes' stamp: 'sw 10/31/97 23:59'! selectorList "answer a set of all the selectors represented in the change set" "Smalltalk changes selectorList" | aList | aList _ OrderedCollection new. methodChanges associationsDo: [:clAssoc | clAssoc value associationsDo: [:mAssoc | (#(remove addedThenRemoved) includes: mAssoc value) ifFalse: [aList add: mAssoc key]]]. ^ aList asSet! ! !ChangeSet methodsFor: 'method changes'! selectorsInClass: aClass "Used by a ChangeSorter to access the list methods." "later include class changes" ^ (methodChanges at: aClass ifAbsent: [^#()]) keys! ! !ChangeSet methodsFor: 'method changes' stamp: 'tk 5/7/1998 15:26'! undoChange: action for: selector class: class "Try to undo the change. Remember that if a changeSet says #add, but the method is missing in the image, it won't file out!! Current cng: Add Remove Add+Remove undo: Add none Remove Remove undo: Remove Add none Add undo:Add+Rem none none none (none means the method is entirely deleted from the changeSet)" | dictionary prev | dictionary _ methodChanges at: class name ifAbsent: [^self]. prev _ dictionary at: selector ifAbsent: [^self]. action == #addedThenRemoved ifTrue: [ dictionary removeKey: selector ifAbsent: []. dictionary isEmpty ifTrue: [methodChanges removeKey: class name]. ^ self]. action == prev ifTrue: [dictionary removeKey: selector ifAbsent: []. dictionary isEmpty ifTrue: [methodChanges removeKey: class name]. ^ self]. action == #add ifTrue: [dictionary at: selector put: #remove]. action == #remove ifTrue: [dictionary at: selector put: #add]. dictionary isEmpty ifTrue: [methodChanges removeKey: class name]! ]style[(45 129 40 812)f1b,f1,f1u,f1! ! !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: 'tk 5/7/1998 14:23'! checkForSlips "Return a collection of method refs with possible debugging code in them." | slips tsRef changes method | slips _ OrderedCollection new. tsRef _ Smalltalk associationAt: #Transcript. self changedClasses do: [:aClass | changes _ methodChanges at: aClass name ifAbsent: [nil]. changes ifNotNil: [changes associationsDo: [:mAssoc | (#(remove addedThenRemoved) includes: mAssoc value) ifFalse: [method _ aClass compiledMethodAt: mAssoc key ifAbsent: [nil]. method ifNotNil: [((method hasLiteral: #halt) or: [method hasLiteral: tsRef]) ifTrue: [slips add: aClass name , ' ' , mAssoc key]]]]]]. ^ slips! ! !ChangeSet methodsFor: 'fileIn/Out' stamp: 'jm 3/27/98 08:26'! 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." | file slips | Cursor write showWhile: [ file _ FileStream newFileNamed: ((self name, FileDirectory dot, Utilities dateTimeSuffix, FileDirectory dot, 'cs') truncateTo: 27). file header; timeStamp. self fileOutPreambleOn: file. self fileOutOn: file. self fileOutPostscriptOn: file. file trailer; close]. Preferences suppressCheckForSlips ifTrue: [^ self]. "Can hard-code that pref if desired" slips _ self checkForSlips. (slips size > 0 and: [self confirm: 'Methods in this fileOut have halts or references to the Transcript in them. Would you like to browse them?']) ifTrue: [Smalltalk browseMessageList: slips name: 'References to #halt or Transcript']! ! !ChangeSet methodsFor: 'fileIn/Out'! fileOutChangesFor: class on: stream "Write out all the changes the receiver knows about this class. 5/15/96 sw: altered to call fileOutClassModifications:on: rather than fileOutClassChanges:on:, so that class headers won't go out as part of this process (they no go out at the beginning of the fileout" | changes | "first file out class changes" self fileOutClassModifications: class on: stream. "next file out changed methods" changes _ OrderedCollection new. (methodChanges at: class name ifAbsent: [^ self]) associationsDo: [:mAssoc | mAssoc value = #remove ifFalse: [changes add: mAssoc key]]. changes isEmpty ifFalse: [class fileOutChangedMessages: changes on: stream. stream cr]! ! !ChangeSet methodsFor: 'fileIn/Out' stamp: 'sw 9/17/97 21:01'! fileOutOn: stream "Write out all the changes the receiver knows about" | classList | self isEmpty ifTrue: [self notify: 'Warning: no changes to file out']. classList _ ChangeSet superclassOrder: self changedClasses asOrderedCollection. classList do: [:aClass | "if class defn changed, put it onto the file now" self fileOutClassDefinition: aClass on: stream]. classList do: [:aClass | "nb: he following no longer puts out class headers" self fileOutChangesFor: aClass on: stream]. stream cr. classList do: [:aClass | self fileOutPSFor: aClass on: stream]. classRemoves do: [:aClassName | stream nextChunkPut: 'Smalltalk removeClassNamed: #', aClassName; cr].! ! !ChangeSet methodsFor: 'fileIn/Out' stamp: 'sw 5/7/1998 12:14'! 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 5/7/1998 12:15'! 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 5/20/1998 02:59'! fileOutPSFor: class on: stream "Write out removals and initialization for this class." (methodChanges at: class name ifAbsent: [^ self]) associationsDo: [:mAssoc | (#(remove addedThenRemoved) includes: mAssoc value) ifTrue: [stream nextChunkPut: class name, ' removeSelector: ', mAssoc key storeString; cr] ifFalse: [(mAssoc key = #initialize and: [class isMeta]) ifTrue: [stream nextChunkPut: class soleInstance name, ' initialize'; cr]]]! ! !ChangeSet methodsFor: 'fileIn/Out' stamp: 'sw 5/7/1998 12:16'! postscriptString "Answer the string representing the postscript. " ^ postscript == nil ifTrue: [postscript] ifFalse: [postscript contents asString]! ! !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 5/7/1998 12:08'! preambleString "Answer the string representing the preamble" ^ preamble == nil ifTrue: [preamble] ifFalse: [preamble contents asString]! ! !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: '"'. ^ aStream contents "Smalltalk changes preambleTemplate"! ! !ChangeSet methodsFor: 'private'! atClass: class add: changeType (self isNew: class) ifFalse: "new classes don't matter" [(classChanges at: class name ifAbsent: [^classChanges at: class name put: (Set with: changeType)]) add: changeType]! ! !ChangeSet methodsFor: 'private'! atClass: class includes: changeType ^(classChanges at: class name ifAbsent: [^false]) includes: changeType! ! !ChangeSet methodsFor: 'private'! atSelector: selector class: class ^(methodChanges at: class name ifAbsent: [^#none]) at: selector ifAbsent: [#none]! ! !ChangeSet methodsFor: 'private'! atSelector: selector class: class put: changeType | dict | (self isNew: class) ifTrue: [^self]. "Don't keep method changes for new classes" (selector==#DoIt) | (selector==#DoItIn:) ifTrue: [^self]. (methodChanges at: class name ifAbsent: [dict _ IdentityDictionary new. methodChanges at: class name put: dict. dict]) at: selector put: changeType ! ! !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: 'tk 12/15/97 14:49'! 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." | commentRemoteStr header | (self atClass: class includes: #rename) ifTrue: [stream nextChunkPut: 'Smalltalk renameClassNamed: #', (self oldNameFor: class), ' as: #', class name; cr]. (self atClass: class includes: #comment) ifTrue: [commentRemoteStr _ class theNonMetaClass organization commentRemoteStr. commentRemoteStr ifNotNil: [ stream cr; nextPut: $!!. "directly" "Should be saying (file command: 'H3') for HTML, but ignoring it here" header _ String streamContents: [:strm | strm nextPutAll: class theNonMetaClass name; nextPutAll: ' commentStamp: '. Utilities changeStamp storeOn: strm. strm nextPutAll: ' prior: '; nextPutAll: '0']. stream nextChunkPut: header; cr. RemoteString newString: commentRemoteStr text onFileNumber: nil toFile: stream. stream cr]]. (self atClass: class includes: #reorganize) ifTrue: [class fileOutOrganizationOn: stream. stream cr]! ! !ChangeSet methodsFor: 'private'! inspectMethodChanges methodChanges inspect! ! !ChangeSet methodsFor: 'private'! isNew: class "Answer whether this class was added since the ChangeSet was cleared." (class isKindOf: Metaclass) ifTrue: [^self atClass: class soleInstance includes: #add "check class"] ifFalse: [^self atClass: class includes: #add]! ! !ChangeSet methodsFor: 'private'! oldNameFor: class | cName | cName _ (classChanges at: class name) asOrderedCollection detect: [:x | 'oldName: *' match: x]. ^ (Scanner new scanTokens: cName) last! ! !ChangeSet methodsFor: 'accessing' stamp: 'tk 5/4/1998 17:00'! editPreamble "edit the receiver's preamble, in a separate window. " self assurePreambleExists. preamble openLabel: 'Preamble for ChangeSet named ', name! ! !ChangeSet methodsFor: 'accessing'! methodChanges ^methodChanges! ! !ChangeSet methodsFor: 'accessing' stamp: 'di 6/15/97 09:45'! methodRemoves ^methodRemoves! ! !ChangeSet methodsFor: 'accessing'! name: anObject name _ anObject! ! !ChangeSet methodsFor: 'accessing'! printOn: aStream "2/7/96 sw: provide the receiver's name in the printout" super printOn: aStream. aStream nextPutAll: ' named ', self name! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ChangeSet class instanceVariableNames: ''! !ChangeSet class methodsFor: 'fileIn/Out'! superclassOrder: classes "Arrange the classes in the collection, classes, in superclass order so the classes can be properly filed in." | all list i aClass superClass | list _ classes copy. "list is indexable" all _ OrderedCollection new: list size. [list size > 0] whileTrue: [aClass _ list first. superClass _ aClass superclass. "Make sure it doesn't have an as yet uncollected superclass" [superClass == nil or: [list includes: superClass]] whileFalse: [superClass _ superClass superclass]. i _ 1. [superClass == nil] whileFalse: [i _ i + 1. aClass _ list at: i. superClass _ aClass superclass. "check as yet uncollected superclass" [superClass == nil or: [list includes: superClass]] whileFalse: [superClass _ superClass superclass]]. all addLast: aClass. list _ list copyWithout: aClass]. ^all! ! !ChangeSet class methodsFor: 'defaults' stamp: 'di 5/6/1998 16:40'! defaultName | namesInUse try | namesInUse _ ChangeSorter gatherChangeSets collect: [:each | each name]. 1 to: 999999 do: [:i | try _ 'Unnamed' , i printString. (namesInUse includes: try) ifFalse: [^ try]]! ! StringHolder subclass: #ChangeSorter instanceVariableNames: 'parent myChangeSet currentClassName currentSelector ' classVariableNames: 'AllChangeSets ' poolDictionaries: '' category: 'Interface-Changes'! !ChangeSorter commentStamp: 'di 5/22/1998 16:32' prior: 0! I display a ChangeSet. Two of me are in a DualChangeSorter.! !ChangeSorter methodsFor: 'creation' stamp: 'tk 4/29/1998 10:15'! defaultBackgroundColor ^ #lightBlue! ! !ChangeSorter methodsFor: 'creation' stamp: 'tk 5/12/1998 09:38'! open "ChangeSorterPluggable new open" | topView | World ifNotNil: [^ self openAsMorph]. Sensor leftShiftDown ifTrue: [^ self openAsMorph]. "testing" topView _ StandardSystemView new. topView model: self. myChangeSet ifNil: [self myChangeSet: Smalltalk changes]. topView label: self labelString. topView borderWidth: 1; minimumSize: 360@360. self openView: topView offsetBy: 0@0. topView controller open. ! ! !ChangeSorter methodsFor: 'creation' stamp: 'tk 5/12/1998 09:42'! openAsMorph "ChangeSorter new openAsMorph" | window | myChangeSet ifNil: [self myChangeSet: Smalltalk changes]. window _ (SystemWindow labelled: self labelString) model: self. self openAsMorphIn: window rect: (0@0 extent: 1@1). World ifNil: [^ window openInMVC]. "test" window openInWorld! ! !ChangeSorter methodsFor: 'creation' stamp: 'tk 5/12/1998 13:17'! openAsMorphIn: window rect: rect "Add a set of change sorter views to the given top view offset by the given amount. To create a single change sorter, call this once with an offset of 0@0. To create a dual change sorter, call it twice with offsets of 0@0 and 0.5@0." | buttonView col | contents _ ''. self addDependent: window. "so it will get changed: #relabel" buttonView _ PluggableButtonMorph on: self getState: #mainButtonState action: #changeSetMenuStart label: #mainButtonName menu: #changeSetMenu:. col _ Color perform: self defaultBackgroundColor. buttonView label: myChangeSet name; onColor: col offColor: col; triggerOnMouseDown: true; borderColor: window color. window addMorph: buttonView frame: (((0@0 extent: 1.0@0.06) scaleBy: rect extent) translateBy: rect origin). window addMorph: (PluggableListMorphByItem on: self list: #classList selected: #currentClassName changeSelected: #currentClassName: menu: #classMenu:) frame: (((0@0.06 extent: 0.5@0.3) scaleBy: rect extent) translateBy: rect origin). window addMorph: (PluggableListMorphByItem on: self list: #messageList selected: #currentSelector changeSelected: #currentSelector: menu: #messageMenu:shifted: keystroke: #messageListKey:from:) frame: (((0.5@0.06 extent: 0.5@0.3) scaleBy: rect extent) translateBy: rect origin). window addMorph: (PluggableTextMorph on: self text: #contents accept: #contents:notifying: readSelection: #contentsSelection menu: #codePaneMenu:shifted:) frame: (((0@0.36 corner: 1@1) scaleBy: rect extent) translateBy: rect origin). ! ! !ChangeSorter methodsFor: 'creation' stamp: 'di 5/6/1998 17:25'! openView: topView offsetBy: offset "Add a set of change sorter views to the given top view offset by the given amount. To create a single change sorter, call this once with an offset of 0@0. To create a dual change sorter, call it twice with offsets of 0@0 and 360@0." | classView messageView codeView buttonView | contents _ ''. self addDependent: topView. "so it will get changed: #relabel" buttonView _ PluggableButtonView on: self getState: #mainButtonState action: #changeSetMenuStart label: #mainButtonName menu: #changeSetMenu:. buttonView label: myChangeSet name; triggerOnMouseDown: true; borderWidth: 1; window: ((0 @ 0 extent: 360 @ 20) translateBy: offset). topView addSubView: buttonView. classView _ PluggableListViewByItem on: self list: #classList selected: #currentClassName changeSelected: #currentClassName: menu: #classMenu:. classView window: (0 @ 0 extent: 180 @ 160). topView addSubView: classView below: buttonView. messageView _ PluggableListViewByItem on: self list: #messageList selected: #currentSelector changeSelected: #currentSelector: menu: #messageMenu:shifted: keystroke: #messageListKey:from:. messageView window: (0 @ 0 extent: 180 @ 160). topView addSubView: messageView toRightOf: classView. codeView _ PluggableTextView on: self text: #contents accept: #contents:notifying: readSelection: #contentsSelection menu: #codePaneMenu:shifted:. codeView window: (0 @ 0 extent: 360 @ 180). topView addSubView: codeView below: classView.! ! !ChangeSorter methodsFor: 'access' stamp: 'tk 4/29/1998 08:22'! changeSet ^ myChangeSet! ! !ChangeSorter methodsFor: 'access' stamp: 'tk 4/30/1998 13:37'! label ^ self labelString! ! !ChangeSorter methodsFor: 'access' stamp: 'tk 4/30/1998 14:03'! labelString "The label for my entire window. The large button that displays my name is gotten via mainButtonName" ^ parent ifNil: [Smalltalk changes == myChangeSet ifTrue: ['Changes go to "', myChangeSet name, '"'] ifFalse: ['ChangeSet: ', myChangeSet name]] ifNotNil: ['Changes go to "', (Smalltalk changes name), '"']! ! !ChangeSorter methodsFor: 'access' stamp: 'tk 4/24/1998 09:10'! myChangeSet ^ myChangeSet! ! !ChangeSorter methodsFor: 'access' stamp: 'tk 4/24/1998 08:43'! myChangeSet: anObject myChangeSet _ anObject! ! !ChangeSorter methodsFor: 'access' stamp: 'tk 4/24/1998 08:42'! parent ^ parent! ! !ChangeSorter methodsFor: 'access' stamp: 'tk 4/24/1998 08:42'! parent: anObject parent _ anObject! ! !ChangeSorter methodsFor: 'access' stamp: 'tk 5/19/1998 16:23'! showChangeSet: chgSet myChangeSet == chgSet ifFalse: [ myChangeSet _ chgSet. currentClassName _ nil. currentSelector _ nil]. self changed: #relabel. self changed: #mainButtonName. self changed: #classList. self changed: #messageList. self setContents. self changed: #contents.! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'tk 4/24/1998 13:27'! browseChangeSet "Open a message list browser on the new and changed methods in the current change set" ChangedMessageSet openFor: myChangeSet ! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'tk 4/29/1998 08:20'! changeSetMenu: aMenu "Could be for a single or double changeSorter" parent ifNotNil: [ ^ aMenu labels: 'make changes go to me new... file into new... show... update fileOut browse rename copy all to other side submerge into other side subtract other side edit preamble... edit postscript... clear remove' lines: #(1 3 8 11 13 ) selections: #(newCurrent newSet fileIntoNewChangeSet chooseCngSet update fileOut browseChangeSet rename copyAllToOther submergeIntoOtherSide subtractOtherSide editPreamble editPostscript clearChangeSet remove )] ifNil: ["Single ChangeSorter" ^ aMenu labels: 'make changes go to me new... file into new... show... update fileOut browse rename edit preamble... edit postscript... clear remove' lines: #(1 3 8 10) selections: #(newCurrent newSet fileIntoNewChangeSet chooseCngSet update fileOut browseChangeSet rename editPreamble editPostscript clearChangeSet remove )]! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'jm 5/20/1998 12:15'! changeSetMenuStart | menu | menu _ self changeSetMenu: CustomMenu new. menu ifNotNil: [menu invokeOn: self]. ! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'tk 4/28/1998 09:15'! chooseCngSet "Put up a list of them" | index | self okToChange ifFalse: [^ self]. ChangeSet instanceCount > AllChangeSets size ifTrue: [self class gatherChangeSets]. index _ (PopUpMenu labels: (AllChangeSets collect: [:each | each name]) asStringWithCr) startUp. index = 0 ifFalse: [self showChangeSet: (AllChangeSets at: index)].! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'tk 4/28/1998 09:06'! clearChangeSet "Clear out the current change set, after getting a confirmation." | message | self okToChange ifFalse: [^ self]. myChangeSet isEmpty ifFalse: [message _ 'Are you certain that you want to\forget all the changes in this set?' withCRs. (self confirm: message) ifFalse: [^ self]]. myChangeSet clear. self changed: #classList. self changed: #messageList. self setContents. self changed: #contents. ! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'tk 4/29/1998 08:29'! copyAllToOther "Copy this entire change set into the one on the other side" | other nextToView ii | other _ (parent other: self) myChangeSet. other assimilateAllChangesFoundIn: myChangeSet. (parent other: self) changed: #classList. "Later the changeSet itself will notice..." (parent other: self) changed: #messageList. nextToView _ ((AllChangeSets includes: myChangeSet) and: [(ii _ AllChangeSets indexOf: myChangeSet) < AllChangeSets size]) ifTrue: [AllChangeSets at: ii+1] ifFalse: [myChangeSet]. self showChangeSet: nextToView! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'tk 4/28/1998 08:06'! editPostscript "Allow the user to edit the receiver's change-set's postscript -- in a separate window" myChangeSet editPostscript! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'tk 4/28/1998 08:06'! editPreamble "Allow the user to edit the receiver's change-set's preamble -- in a separate window." myChangeSet editPreamble! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'tk 4/28/1998 09:16'! fileIntoNewChangeSet "Obtain a file designation from the user, and file its contents into a new change set whose name is a function of the filename. Show the new set and leave the current changeSet unaltered." | aFileName aNewChangeSet | self okToChange ifFalse: [^ self]. aFileName _ FillInTheBlank request: 'Name of file to be imported: '. aFileName size == 0 ifTrue: [^ self]. (FileDirectory default fileExists: aFileName) ifFalse: [^ self inform: 'Sorry -- cannot find that file']. aNewChangeSet _ self class newChangesFromStream: (FileStream oldFileNamed: aFileName) named: aFileName. aNewChangeSet ifNotNil: [self showChangeSet: aNewChangeSet]! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'tk 4/24/1998 13:26'! fileOut "File out the current change set." myChangeSet fileOut! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'tk 4/24/1998 13:10'! mainButtonName ^ myChangeSet name! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'tk 4/24/1998 10:11'! mainButtonState "The button activates the menu, but does not stay on" ^ false! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'tk 4/30/1998 13:47'! newCurrent "make my change set be the current one that changes go into" Smalltalk newChanges: myChangeSet. self changed: #relabel.! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'tk 4/28/1998 09:16'! newSet "Create a new changeSet and show it. make the new guy the current one. Also, reject name if already in use." | newName newSet | self okToChange ifFalse: [^ self]. newName _ FillInTheBlank request: 'A name for the new change set' initialAnswer: ChangeSet defaultName. newName isEmpty ifTrue: [^ self]. (self class changeSetNamed: newName) ifNotNil: [^ self inform: 'Sorry that name is already used']. newSet _ ChangeSet new initialize name: newName. AllChangeSets add: newSet. self showChangeSet: newSet. self newCurrent. ! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'tk 4/28/1998 09:07'! remove "Completely destroy my change set. Check if it's OK first" self okToChange ifFalse: [^ self]. self removePrompting: true! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'tk 4/24/1998 13:48'! removePrompting: doPrompt "Completely destroy my change set. Check if it's OK first, and if doPrompt is true, get the user to confirm his intentions first" | message aName | aName _ myChangeSet name. myChangeSet okayToRemove ifFalse: [^ self]. "forms current changes for some project" (myChangeSet isEmpty or: [doPrompt not]) ifFalse: [message _ 'Are you certain that you want to remove (destroy) the change set named "', aName, '" ?'. (self confirm: message) ifFalse: [^ self]]. "Go ahead and remove the change set" AllChangeSets remove: myChangeSet. myChangeSet wither. "clear out its contents" self showChangeSet: Smalltalk changes.! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'tk 4/28/1998 08:38'! rename "Store a new name string into the selected ChangeSet. reject duplicate name; allow user to back out" | newName | newName _ FillInTheBlank request: 'New name for this change set' initialAnswer: myChangeSet name. (newName = myChangeSet name or: [newName size == 0]) ifTrue: [^ self inform: 'No change made']. (self class changeSetNamed: newName) ifNotNil: [^ Utilities inform: 'Sorry that name is already used']. myChangeSet name: newName. self changed: #mainButtonName. self changed: #relabel.! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'tk 4/29/1998 08:26'! submergeIntoOtherSide "Copy the contents of the receiver to the other side, then remove the receiver -- all after checking that all is well." | other message nextToView i | self okToChange ifFalse: [^ self]. other _ (parent other: self) changeSet. other == myChangeSet ifTrue: [^ self inform: 'Both sides are the same!!']. myChangeSet isEmpty ifTrue: [^ self inform: 'Nothing to copy. To remove, simply choose "remove".']. myChangeSet okayToRemove ifFalse: [^ self]. message _ 'Please confirm: copy all changes in "', myChangeSet name, '" into "', other name, '" and then destroy the change set named "', myChangeSet name, '"?'. (self confirm: message) ifFalse: [^ self]. other assimilateAllChangesFoundIn: myChangeSet. nextToView _ ((AllChangeSets includes: myChangeSet) and: [(i _ AllChangeSets indexOf: myChangeSet) < AllChangeSets size]) ifTrue: [AllChangeSets at: i+1] ifFalse: [other]. self removePrompting: false. self showChangeSet: nextToView. self class gatherChangeSets. (parent other: self) changed: #classList. (parent other: self) changed: #messageList.! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'tk 4/29/1998 08:33'! subtractOtherSide "Subtract the changes found on the other side from the requesting side." myChangeSet forgetAllChangesFoundIn: ((parent other: self) changeSet). self showChangeSet: myChangeSet! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'tk 4/28/1998 20:58'! update "recompute all of my panes" self okToChange ifFalse: [^ self]. self showChangeSet: myChangeSet. parent ifNotNil: [ (parent other: self) okToChange ifTrue: [ (parent other: self) showChangeSet: (parent other: self) myChangeSet]].! ! !ChangeSorter methodsFor: 'class list' stamp: 'tk 5/7/1998 13:01'! classList "Computed. View should try to preserve selections, even though index changes" ^ myChangeSet changedClassNames ! ! !ChangeSorter methodsFor: 'class list' stamp: 'tk 4/29/1998 09:57'! classMenu: aMenu "Could be for a single or double changeSorter" parent ifNotNil: [ ^ aMenu labels: 'copy to other side delete from this change set browse full inst var refs... inst var defs... class var refs... class vars' lines: #(2 3 ) selections: #(copyClassToOther forgetClass browseMethodFull browseInstVarRefs browseInstVarDefs browseClassVarRefs browseClassVariables)] ifNil: [ ^ aMenu labels: 'delete from this change set browse full inst var refs... inst var defs... class var refs... class vars' lines: #(1 2 ) selections: #(forgetClass browseMethodFull browseInstVarRefs browseInstVarDefs browseClassVarRefs browseClassVariables)]! ! !ChangeSorter methodsFor: 'class list' stamp: 'tk 5/7/1998 14:29'! copyClassToOther "Place these changes in the other changeSet also" | other info cls | other _ (parent other: self) changeSet. (myChangeSet classRemoves includes: currentClassName) ifTrue: [ ^ other noteRemovalOf: currentClassName]. info _ myChangeSet classChangeAt: (cls _ self selectedClassOrMetaClass) name. info do: [:each | other atClass: cls add: each]. info _ myChangeSet methodChanges at: cls name ifAbsent: [Dictionary new]. info associationsDo: [:ass | other atSelector: ass key class: cls put: ass value]. (parent other: self) showChangeSet: other.! ! !ChangeSorter methodsFor: 'class list' stamp: 'tk 4/24/1998 09:14'! currentClassName ^ currentClassName! ! !ChangeSorter methodsFor: 'class list' stamp: 'tk 5/19/1998 12:41'! currentClassName: aString currentClassName _ aString. currentSelector _ nil. "fix by wod" self changed: #currentClassName. self changed: #messageList. self setContents. self changed: #contents.! ! !ChangeSorter methodsFor: 'class list' stamp: 'tk 5/20/1998 17:20'! forgetClass "Remove all mention of this class from the changeSet" self okToChange ifFalse: [^ self]. currentClassName ifNotNil: [ myChangeSet removeClassChanges: self selectedClassOrMetaClass. currentClassName _ nil. currentSelector _ nil. self showChangeSet: myChangeSet]. ! ! !ChangeSorter methodsFor: 'class list' stamp: 'tk 4/24/1998 10:48'! selectedClass ^ currentClassName ifNil: [nil] ifNotNil: [self selectedClassOrMetaClass theNonMetaClass]! ! !ChangeSorter methodsFor: 'class list' stamp: 'tk 5/7/1998 13:48'! selectedClassOrMetaClass "Careful, the class may have been removed!!" | cName | currentClassName ifNil: [^ nil]. (currentClassName endsWith: ' class') ifTrue: [cName _ (currentClassName copyFrom: 1 to: currentClassName size-6) asSymbol. ^ (Smalltalk at: cName ifAbsent: [^nil]) class] ifFalse: [cName _ currentClassName asSymbol. ^ Smalltalk at: cName ifAbsent: [nil]]! ! !ChangeSorter methodsFor: 'message list' stamp: 'tk 4/28/1998 18:49'! browseVersions "Create and schedule a changelist browser on the versions of the selected message." | class selector method category pair sourcePointer | (selector _ self selectedMessageName) ifNil: [^ self]. class _ self selectedClassOrMetaClass. (class includesSelector: selector) ifTrue: [method _ class compiledMethodAt: selector. category _ class whichCategoryIncludesSelector: selector. sourcePointer _ nil] ifFalse: [pair _ myChangeSet methodRemoves at: (Array with: class name with: selector) ifAbsent: [^ nil]. sourcePointer _ pair first. method _ CompiledMethod toReturnSelf setSourcePointer: sourcePointer. category _ pair last]. ChangeList browseVersionsOf: method class: self selectedClass meta: class isMeta category: category selector: selector lostMethodPointer: sourcePointer. ! ! !ChangeSorter methodsFor: 'message list' stamp: 'tk 4/29/1998 10:08'! copyMethodToOther "Place this change in the other changeSet also" | other info cls sel | currentSelector ifNotNil: [ other _ (parent other: self) changeSet. cls _ self selectedClassOrMetaClass. sel _ currentSelector asSymbol. info _ myChangeSet methodChanges at: cls name ifAbsent: [Dictionary new]. other atSelector: sel class: cls put: (info at: sel). (parent other: self) showChangeSet: other] ! ! !ChangeSorter methodsFor: 'message list' stamp: 'tk 4/24/1998 09:15'! currentSelector ^ currentSelector! ! !ChangeSorter methodsFor: 'message list' stamp: 'tk 4/28/1998 20:48'! currentSelector: messageName currentSelector _ messageName. self changed: #currentSelector. self setContents. self changed: #contents.! ! !ChangeSorter methodsFor: 'message list' stamp: 'tk 4/29/1998 10:11'! forget "Drop this method from the changeSet" self okToChange ifFalse: [^ self]. currentSelector ifNotNil: [ myChangeSet removeSelectorChanges: self selectedMessageName class: self selectedClassOrMetaClass. self showChangeSet: myChangeSet]! ! !ChangeSorter methodsFor: 'message list' stamp: 'tk 4/26/1998 22:34'! messageList | probe | currentClassName ifNil: [^ #()]. probe _ (currentClassName endsWith: ' class') ifTrue: [currentClassName] ifFalse: [currentClassName asSymbol]. ^ ((myChangeSet selectorsInClass: probe) collect: [:each | each printString]) asSortedCollection ! ! !ChangeSorter methodsFor: 'message list' stamp: 'tk 4/29/1998 10:03'! messageMenu: aMenu shifted: shifted "Could be for a single or double changeSorter" shifted ifTrue: [^ self shiftedMessageMenu: aMenu]. parent ifNotNil: [ ^ aMenu labels: 'copy method to other side delete method from change set remove method from system browse full fileOut printOut senders of... implementors of... versions more...' lines: #(1 3 6 9 ) selections: #(copyMethodToOther forget removeMessage browseMethodFull fileOutMessage printOutMessage browseSendersOfMessages browseMessages browseVersions shiftedYellowButtonActivity )] ifNil: [^ aMenu labels: 'delete method from change set remove method from system browse full fileOut printOut senders of... implementors of... versions more...' lines: #(2 5 8 ) selections: #( forget removeMessage browseMethodFull fileOutMessage printOutMessage browseSendersOfMessages browseMessages browseVersions shiftedYellowButtonActivity )] ! ! !ChangeSorter methodsFor: 'message list' stamp: 'tk 5/18/1998 10:23'! removeMessage "Remove the selected msg from the system. Real work done by the parent, a ChangeSorter" | confirmation sel | self okToChange ifFalse: [^ self]. currentSelector ifNotNil: [ confirmation _ self selectedClassOrMetaClass confirmRemovalOf: (sel _ self selectedMessageName). confirmation == 3 ifTrue: [^ self]. myChangeSet removeSelectorChanges: sel class: self selectedClassOrMetaClass. self selectedClassOrMetaClass removeSelector: sel. self update. " self changed: #messageList. self setContents. self changed: #contents. " confirmation == 2 ifTrue: [Smalltalk browseAllCallsOn: sel]]! ! !ChangeSorter methodsFor: 'message list' stamp: 'jm 5/4/1998 07:32'! selectedMessageName currentSelector ifNil: [^ nil]. ^ currentSelector asSymbol! ! !ChangeSorter methodsFor: 'message list' stamp: 'tk 4/28/1998 19:02'! shiftedMessageMenu: aMenu ^ aMenu labels: 'browse class hierarchy browse class browse method implementors of sent messages change sets with this method inspect instances inspect subinstances more...' lines: #(5 7 10) selections: #(classHierarchy browseClass buildMessageBrowser browseAllMessages findMethodInChangeSets inspectInstances inspectSubInstances unshiftedYellowButtonActivity)! ! !ChangeSorter methodsFor: 'message list' stamp: 'tk 4/28/1998 19:03'! shiftedYellowButtonActivity "Invoke the model's other menu. Just do what the controller would have done." | menu | menu _ self messageMenu: (CustomMenu new) shifted: true. menu == nil ifTrue: [Sensor waitNoButton] ifFalse: [menu invokeOn: self]. ! ! !ChangeSorter methodsFor: 'message list' stamp: 'tk 4/28/1998 19:16'! unshiftedYellowButtonActivity "Invoke the model's other menu. Just do what the controller would have done." | menu | menu _ self messageMenu: (CustomMenu new) shifted: false. menu == nil ifTrue: [Sensor waitNoButton] ifFalse: [menu invokeOn: self]. ! ! !ChangeSorter methodsFor: 'code pane' stamp: 'tk 5/18/1998 11:43'! 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 | (class _ self selectedClassOrMetaClass) ifNil: [^ false]. oldSelector _ self selectedMessageName. category _ class organization categoryOfElement: oldSelector. selector _ class compile: aString classified: category notifying: aController. selector ifNil: [^ false]. (self messageList includes: selector) ifTrue: [self currentSelector: selector] ifFalse: [self currentSelector: oldSelector]. self update. ^ true! ! !ChangeSorter methodsFor: 'code pane' stamp: 'tk 5/18/1998 14:40'! setContents "return the source code that shows in the bottom pane" | sel class strm changeType | self clearUserEditFlag. currentClassName ifNil: [^ contents _ '']. class _ self selectedClassOrMetaClass. (sel _ currentSelector) == 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 ifNil: [^ contents _ 'Method was added, but cannot be found!!']. (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: currentClassName) 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 methodsFor: 'code pane' stamp: 'di 5/22/1998 14:09'! spawn: aString "Create and schedule a message browser for the receiver in which the argument, aString, contains characters to be edited in the text view." currentSelector ifNil: [^ self]. ^ Browser openMessageBrowserForClass: self selectedClassOrMetaClass selector: self selectedMessageName editString: aString! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ChangeSorter class instanceVariableNames: ''! !ChangeSorter class methodsFor: 'all' stamp: 'tk 5/1/1998 15:26'! allChangeSetNames ^ self gatherChangeSets collect: [:c | c name]! ! !ChangeSorter class methodsFor: 'all' stamp: 'di 5/6/1998 16:40'! browseChangeSetsWithClass: class selector: selector | hits index | hits _ self gatherChangeSets select: [:cs | (cs atSelector: selector class: class) ~~ #none]. hits isEmpty ifTrue: [^ PopUpMenu notify: class name,'.',selector , ' is not in any change set']. index _ hits size == 1 ifTrue: [1] ifFalse: [(PopUpMenu labelArray: (hits collect: [:cs | cs name]) lines: #()) startUp]. index = 0 ifTrue: [^ self]. (ChangeSorter new myChangeSet: (hits at: index)) open. ! ! !ChangeSorter class methodsFor: 'all' stamp: 'tk 4/24/1998 16:42'! changeSetNamed: aName "Return the change set of the given name, or nil if none found. 1/22/96 sw" self gatherChangeSets. AllChangeSets do: [:aChangeSet | aChangeSet name = aName ifTrue: [^ aChangeSet]]. ^ nil! ! !ChangeSorter class methodsFor: 'all' stamp: 'tk 4/24/1998 13:51'! gatherChangeSets "Collect any change sets created in other projects" ChangeSet allInstancesDo: [:each | (AllChangeSets includes: each) ifFalse: [AllChangeSets add: each]]. ^ AllChangeSets _ AllChangeSets select: [:each | each isMoribund not] "ChangeSorter gatherChangeSets"! ! !ChangeSorter class methodsFor: 'all' stamp: 'tk 5/1/1998 22:34'! highestNumberedChangeSet "ChangeSorter highestNumberedChangeSet" ^ (self allChangeSetNames select: [:aString | aString startsWithDigit] thenCollect: [:aString | aString initialInteger]) max ! ! !ChangeSorter class methodsFor: 'all' stamp: 'tk 4/24/1998 13:52'! initialize AllChangeSets == nil ifTrue: [AllChangeSets _ OrderedCollection new]. self gatherChangeSets. ! ! !ChangeSorter class methodsFor: 'all' stamp: 'tk 4/24/1998 13:19'! 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." | 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. Smalltalk newChanges: aNewChangeSet. aFileStream fileIn. Transcript cr; show: 'File ', aFileName, ' successfully filed in to change set ', newName. Smalltalk newChanges: existingChanges. ^ aNewChangeSet! ! !ChangeSorter class methodsFor: 'all' stamp: 'jm 5/22/1998 11:33'! removeChangeSetsBefore: stopName "Remove all change sets before the one with the given name." "ChangeSorter removeChangeSetsBefore: 'Beyond'" | stop | (self confirm: 'Really remove all change sets before "', stopName, '"?') ifFalse: [^ self]. self gatherChangeSets. stop _ false. ChangeSet allInstancesDo: [:changeSet | changeSet name = stopName ifTrue: [stop _ true]. stop ifFalse: [ changeSet okayToRemove ifTrue: [ AllChangeSets remove: changeSet ifAbsent: []. changeSet wither]]]. Smalltalk garbageCollect. AllChangeSets _ OrderedCollection new. self gatherChangeSets. ! ! !ChangeSorter class methodsFor: 'all' stamp: 'di 5/12/1998 12:20'! removeChangeSetsNamedSuchThat: nameBlock "ChangeSorter removeChangeSetsNamedSuchThat: [:name | name first isDigit and: [name initialInteger >= 275]]" self allChangeSetNames do: [:csName | (nameBlock value: csName) ifTrue: [AllChangeSets remove: (self changeSetNamed: csName) wither]]! ! !ChangeSorter class methodsFor: 'all' stamp: 'jm 5/20/1998 10:40'! removeOldChangeSets "Ask the user to select a change set from a menu, then remove all change sets before the selected one." "ChangeSorter removeOldChangeSets" | names stopName | self gatherChangeSets. names _ AllChangeSets collect: [:each | each name]. stopName _ (SelectionMenu labelList: names selections: names) startUp. stopName ifNotNil: [self removeChangeSetsBefore: stopName]. ! ! !ChangeSorter class methodsFor: 'all' stamp: 'tk 4/30/1998 13:43'! 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]! ! MessageSet subclass: #ChangedMessageSet instanceVariableNames: 'changeSet ' classVariableNames: '' poolDictionaries: '' category: 'Interface-Browser'! !ChangedMessageSet methodsFor: 'everything'! changeSet: aChangeSet changeSet _ aChangeSet! ! !ChangedMessageSet methodsFor: 'everything' stamp: 'tk 4/26/1998 09:20'! contents: aString notifying: aController | selectedMessageName selector oldMessageList cls | selectedMessageName _ self selectedMessageName. oldMessageList _ self messageList. contents _ nil. selector _ self selectedClassOrMetaClass compile: aString classified: self selectedMessageCategoryName notifying: aController. selector == nil ifTrue: [^ false]. cls _ self selectedClassOrMetaClass. contents _ aString copy. selector ~~ selectedMessageName ifTrue: [(oldMessageList includes: selector) ifFalse: [ self initializeMessageList: changeSet changedMessageListAugmented. self changed: #messageList]. self messageListIndex: (self messageList indexOf: (cls name, ' ', selector))]. ^ true! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ChangedMessageSet class instanceVariableNames: ''! !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)! ! Object subclass: #CharRecog instanceVariableNames: 'mp p sts pts bmin bmax op cPat in dirs ftrs prevFeatures ' classVariableNames: 'CharacterDictionary ' poolDictionaries: 'TextConstants ' category: 'System-Support'! !CharRecog commentStamp: 'di 5/22/1998 16:32' prior: 0! CharRecog comment: 'Alan Kay''s "one-page" character recognizer. Currently hooked up to text panes, such that you can get it started by hitting cmd-r in any pane. To reinitialize the recognition dictionary, evaluate CharRecog reinitializeCharacterDictionary '! !CharRecog methodsFor: 'recognizer'! directionFrom: p1 to: p2 | ex | "This does 8 directions and is not used in current recognizer" "get the bounding box" ex _ p2 - p1. "unlike bmax-bmin, this can have negatives" "Look for degenerate forms first: . - |" "look for a dot" ex abs < (3@3) ifTrue: [^' dot... ']. "look for hori line" ((ex y = 0) or: [(ex x/ex y) abs > 2]) ifTrue: "look for w-e" [ex x > 0 ifTrue:[^' we-- '] "it's an e-w" ifFalse:[^' ew-- ']]. "look for vertical line" ((ex x = 0) or: [(ex y/ex x) abs > 2]) ifTrue: "look for n-s" [(ex y > 0) ifTrue:[ ^' ns||'] "it's a s-n" ifFalse:[^' sn|| ']]. "look for a diagonal" (ex x/ex y) abs <= 2 ifTrue: "se or ne" [ex x > 0 ifTrue:[ex y > 0 ifTrue:[^' se// ']. ^' ne// ']. "sw or nw" ex y > 0 ifTrue:[^' sw// ']. ^' nw// ']. ! ! !CharRecog methodsFor: 'recognizer'! extractFeatures | xl xr yl yh reg px py | "get extent bounding box" in _ bmax - bmin. "Look for degenerate forms first: . - |" "look for a dot" in < (3@3) ifTrue: [^' dot... ']. "Feature 5: turns (these are already in ftrs)" "Feature 4: absolute size" in < (10@10) ifTrue: [ftrs _ 'SML ', ftrs] ifFalse: [in <= (70@70) ifTrue: [ftrs _ 'REG ', ftrs] ifFalse: [in > (70@70) ifTrue: [ftrs _ 'LRG ', ftrs]]]. "Feature 3: aspect ratio" "horizontal shape" ((in y = 0) or: [(in x/in y) abs > 3]) ifTrue: [ftrs _ 'HOR ', ftrs] ifFalse: "vertical shape" [((in x = 0) or: [(in y/in x) abs >= 3]) ifTrue: [ftrs _ 'VER ', ftrs] ifFalse: "boxy shape" [((in x/in y) abs <= 3) ifTrue: [ftrs _ 'BOX ', ftrs. "Now only for boxes" "Feature 2: endstroke reg" ftrs _ (self regionOf: (pts last)), ftrs. "Feature 1: startstroke reg" ftrs _ (self regionOf: (pts contents at: 1)), ftrs.]]]. ^ftrs ! ! !CharRecog methodsFor: 'recognizer'! fourDirsFrom: p1 to: p2 | ex | "get the bounding box" ex _ p2 - p1. "unlike bmax-bmin, this can have negatives" "Look for degenerate forms first: . - |" "look for a dot" ex abs < (3@3) ifTrue: [^' dot... ']. "look for hori line" ((ex y = 0) or: [(ex x/ex y) abs > 1]) ifTrue: "look for w-e" [ex x > 0 ifTrue:[^'WE '] "it's an e-w" ifFalse:[^'EW ']]. "look for vertical line" ((ex x = 0) or: [(ex y/ex x) abs >= 1]) ifTrue: "look for n-s" [(ex y > 0) ifTrue:[ ^'NS '] "it's a s-n" ifFalse:[^'SN ']]. "look for a diagonal (ex x/ex y) abs <= 2 ifTrue:" "se or ne [ex x > 0 ifTrue:[ex y > 0 ifTrue:[^' se// ']. ^' ne// ']." "sw or nw ex y > 0 ifTrue:[^' sw// ']. ^' nw// ']." ! ! !CharRecog methodsFor: 'recognizer' stamp: 'jm 4/28/1998 05:37'! learnPrev "The character recognized before this one was wrong. (Got here via the gesture for 'wrong'.) Bring up a dialog box on that char. 8/21/96 tk" | old result | old _ CharacterDictionary at: prevFeatures ifAbsent: [^ '']. "get right char from user" result _ FillInTheBlank request: ('Redefine the gesture we thought was "', old asString, '".', ' (Letter or: tab cr wrong bs select caret) ', prevFeatures). "ignore or..." (result = '~' | result = '') ifTrue: [''] "...enter new char" ifFalse: [ CharacterDictionary at: prevFeatures put: result]. "caller erases bad char" "good char" ^ result! ! !CharRecog methodsFor: 'recognizer'! recognize | prv cdir result features char r s t dir | "Alan Kay's recognizer as of 1/31/96. This version preserved for historical purposes, and also because it's still called by the not-yet-deployed method recogPar. Within the current image, the recognizer is now called via #recognizeAndDispatch:until:" "Inits" (p _ Pen new) defaultNib: 1; down. "for points" pts _ ReadWriteStream on: #(). "Event Loop" [(Sensor mousePoint x) < 50] whileFalse: "First-Time" [pts reset. "will hold features" ftrs _ ''. (Sensor anyButtonPressed) ifTrue: [pts nextPut: (bmin _ bmax _ t _ s _ sts _ Sensor mousePoint). p place: sts. cdir _ nil. "Each-Time" [Sensor anyButtonPressed] whileTrue: [ "ink raw input" p goto: (r _ Sensor mousePoint). "smooth it" s _ (0.5*s) + (0.5*r). "thin the stream" ((s x - t x) abs > 3 or:[(s y - t y) abs > 3]) ifTrue: [ pts nextPut: t. "bounding box" bmin _ bmin min: s. bmax _ bmax max: s. "get current dir" dir _ (self fourDirsFrom: t to: s). t _ s. dir ~= ' dot... ' ifTrue: [ "store new dirs" cdir ~= dir ifTrue: [ftrs _ ftrs, (cdir _ dir)]]. "for inked t's" p place: t; go: 1; place: r. ]. "End Each-Time Loop" ]. "Last-Time" "save last points" pts nextPut: t; nextPut: r. "find rest of features" features _ self extractFeatures. "find char..." char _ CharacterDictionary at: features ifAbsent: "...or get from user" [ result _ FillInTheBlank request: 'Not recognized. type char, or type ~: ', features. "ignore or..." result = '~' ifTrue: [''] "...enter new char" ifFalse: [CharacterDictionary at: features put: result. result]]. "control the editor" (char = 'cr' ifTrue: [Transcript cr] ifFalse: [char = 'bs' ifTrue: [Transcript bs] ifFalse: [char = 'tab' ifTrue:[Transcript tab] ifFalse: [Transcript show: char]]]). "End First-Time Loop" ]. "End Event-Loop" ]. ! ! !CharRecog methodsFor: 'recognizer'! recognizeAndDispatch: charDispatchBlock ifUnrecognized: unrecognizedFeaturesBlock until: terminationBlock "Recognize characters, and dispatch each one found by evaluating charDispatchBlock; proceed until terminationBlock is true. This method derives directly from Alan's 1/96 #recognize method, but factors out the character dispatch and the termination condition from the main body of the method. 2/2/96 sw. 2/5/96 sw: switch to using a class variable for the character dictionary, and don't put vacuous entries in the dictionary if the user gives an empty response to the prompt, and don't send empty characters onward, and use a variant of the FillInTheBlank that keeps the prompt clear of the working window. 8/17/96 tk: Turn cr, tab, bs into strings so they work. 9/18/96 sw: in this variant, the block for handling unrecognized features is handed in as an argument, so that in some circumstances we can avoid putting up a prompt. unrecognizedFeaturesBlock should be a one-argument block, which is handed in the features and which is expected to return a string which indicates the determined translation -- empty if none." | prv cdir features char r s t dir | "Inits" (p _ Pen new) defaultNib: 1; down. "for points" pts _ ReadWriteStream on: #(). "Event Loop" [terminationBlock value] whileFalse: "First-Time" [pts reset. "will hold features" ftrs _ ''. (Sensor anyButtonPressed) ifTrue: [pts nextPut: (bmin _ bmax _ t _ s _ sts _ Sensor mousePoint). p place: sts. cdir _ nil. "Each-Time" [Sensor anyButtonPressed] whileTrue: "ink raw input" [p goto: (r _ Sensor mousePoint). "smooth it" s _ (0.5*s) + (0.5*r). "thin the stream" ((s x - t x) abs > 3 or:[(s y - t y) abs > 3]) ifTrue: [pts nextPut: t. "bounding box" bmin _ bmin min: s. bmax _ bmax max: s. "get current dir" dir _ (self fourDirsFrom: t to: s). t _ s. dir ~= ' dot... ' ifTrue: "store new dirs" [cdir ~= dir ifTrue: [ftrs _ ftrs, (cdir _ dir)]]. "for inked t's" p place: t; go: 1; place: r]]. "End Each-Time Loop" "Last-Time" "save last points" pts nextPut: t; nextPut: r. "find rest of features" features _ self extractFeatures. "find char..." char _ CharacterDictionary at: features ifAbsent: [unrecognizedFeaturesBlock value: features]. "special chars" char size > 0 ifTrue: [char = 'tab' ifTrue: [char _ Tab]. char = 'cr' ifTrue: [char _ CR]. "must be a string" char class == Character ifTrue: [char _ String with: char]. char = 'bs' ifTrue: [char _ BS]. "control the editor" charDispatchBlock value: char]]] ! ! !CharRecog methodsFor: 'recognizer'! recognizeAndDispatch: charDispatchBlock until: terminationBlock "Recognize characters, and dispatch each one found by evaluating charDispatchBlock; proceed until terminationBlock is true. 9/18/96 sw" ^ self recognizeAndDispatch: charDispatchBlock ifUnrecognized: [:features | self stringForUnrecognizedFeatures: features] until: terminationBlock ! ! !CharRecog methodsFor: 'recognizer'! recognizeAndPutInTranscript "Call Alan's recognizer repeatedly until the mouse is near the left edge of the screen, and dispatch keystrokes inferred to the Trancript. 2/2/96 sw" ^ self recognizeAndDispatch: [:char | (char = 'cr') ifTrue: [Transcript cr] ifFalse: [char = 'bs' ifTrue: [Transcript bs] ifFalse: [char = 'tab' ifTrue:[Transcript tab] ifFalse: [Transcript show: char]]]] until: [Sensor mousePoint x < 50] "CharRecog new recognizeAndPutInTranscript"! ! !CharRecog methodsFor: 'recognizer'! recogPar | prv cdir result features char r s t dir | "Inits" (p _ Pen new) defaultNib: 1; down. "for points" pts _ ReadWriteStream on: #(). "Event Loop" [Sensor anyButtonPressed] whileFalse: [(Sensor mousePoint x < 50) ifTrue: [^''].]. "First-Time" pts reset. "will hold features" ftrs _ ''. (Sensor anyButtonPressed) ifTrue: [pts nextPut: (bmin _ bmax _ t _ s _ sts _ Sensor mousePoint). p place: sts. cdir _ nil. "Each-Time" [Sensor anyButtonPressed] whileTrue: [ "ink raw input" p goto: (r _ Sensor mousePoint). "smooth it" s _ (0.5*s) + (0.5*r). "thin the stream" ((s x - t x) abs > 3 or:[(s y - t y) abs > 3]) ifTrue: [ pts nextPut: t. "bounding box" bmin _ bmin min: s. bmax _ bmax max: s. "get current dir" dir _ (self fourDirsFrom: t to: s). t _ s. dir ~= ' dot... ' ifTrue: [ "store new dirs" cdir ~= dir ifTrue: [ftrs _ ftrs, (cdir _ dir)]]. "for inked t's" p place: t; go: 1; place: r. ]. "End Each-Time Loop" ]. "Last-Time" "start a new recog for next point" [CharRecog new recognize] fork. "save last points" pts nextPut: t; nextPut: r. "find rest of features" features _ self extractFeatures. "find char..." char _ CharacterDictionary at: features ifAbsent: "...or get from user" [ result _ FillInTheBlank request: 'Not recognized. type char, or type ~: ', features. "ignore or..." result = '~' ifTrue: [''] "...enter new char" ifFalse: [CharacterDictionary at: features put: result. result]]. "control the editor" (char = 'cr' ifTrue: [Transcript cr] ifFalse: [char = 'bs' ifTrue: [Transcript bs] ifFalse: [char = 'tab' ifTrue:[Transcript tab] ifFalse: [Transcript show: char]]]). "End First-Time Loop" ]. ! ! !CharRecog methodsFor: 'recognizer'! regionOf: pt | px py reg xl yl yh xr rg | "it's some other character" rg _ in/3. xl _ bmin x + rg x. xr _ bmax x - rg x. "divide box into 9 regions" yl _ bmin y + rg y. yh _ bmax y - rg y. px _ pt x. py _ pt y. reg _ (px < xl ifTrue: [py < yl ifTrue: ['NW '] "py >= yl" ifFalse:[ py < yh ifTrue:['W '] ifFalse: ['SW ']]] ifFalse: [px < xr ifTrue: [py < yl ifTrue: ['N '] ifFalse: [py < yh ifTrue: ['C '] ifFalse: ['S ']]] ifFalse: [py < yl ifTrue: ['NE '] ifFalse: [py < yh ifTrue: ['E '] ifFalse: ['SE ']]]]). ^reg. ! ! !CharRecog methodsFor: 'recognizer' stamp: 'jm 4/28/1998 05:37'! stringForUnrecognizedFeatures: features "Prompt the user for what string the current features represent, and return the result. 9/18/96 sw" | result | result _ FillInTheBlank request: ('Not recognized. type char, or "tab", "cr" or "bs", or hit return to ignore ', features). ^ (result = '~' | result = '') ifTrue: [''] ifFalse: [CharacterDictionary at: features put: result. result]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! CharRecog class instanceVariableNames: ''! !CharRecog class methodsFor: 'initialization'! initialize "Iniitialize the character dictionary if it doesn't exist yet. 2/5/96 sw" CharacterDictionary == nil ifTrue: [CharacterDictionary _ Dictionary new]! ! !CharRecog class methodsFor: 'initialization'! reinitializeCharacterDictionary "Reset the character dictionary to be empty, ready for a fresh start. 2/5/96 sw" CharacterDictionary _ Dictionary new "CharRecog reinitializeCharacterDictionary" ! ! !CharRecog class methodsFor: 'saving dictionary'! readRecognizerDictionaryFrom: aFileName "Read a fresh version of the Recognizer dictionary in from a file of the given name. 7/26/96 sw" "CharRecog readRecognizerDictionaryFrom: 'RecogDictionary.2 fixed'" | aReferenceStream | aReferenceStream _ ReferenceStream fileNamed: aFileName. CharacterDictionary _ aReferenceStream next. aReferenceStream close. ! ! !CharRecog class methodsFor: 'saving dictionary'! saveRecognizerDictionaryTo: aFileName "Save the current state of the Recognizer dictionary to disk. 7/26/96 sw" | aReferenceStream | aReferenceStream _ ReferenceStream fileNamed: aFileName. aReferenceStream nextPut: CharacterDictionary. aReferenceStream close! ! Magnitude subclass: #Character instanceVariableNames: 'value ' classVariableNames: 'CharacterTable ' poolDictionaries: '' category: 'Collections-Text'! !Character commentStamp: 'di 5/22/1998 16:32' prior: 0! Character comment: 'I represent a character by storing its associated ASCII code (extended to 256 codes). My instances are created uniquely, so that all instances of a character ($R, for example) are identical.'! !Character methodsFor: 'accessing'! asciiValue "Answer the value of the receiver that represents its ascii encoding." ^value! ! !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: 'comparing'! < aCharacter "Answer true if the receiver's value < aCharacter's value." ^self asciiValue < aCharacter asciiValue! ! !Character methodsFor: 'comparing'! = aCharacter "Primitive. Answer true if the receiver and the argument are the same object (have the same object pointer) and false otherwise. Optional. See Object documentation whatIsAPrimitive." ^self == aCharacter! ! !Character methodsFor: 'comparing'! > aCharacter "Answer true if the receiver's value > aCharacter's value." ^self asciiValue > aCharacter asciiValue! ! !Character methodsFor: 'comparing'! hash "Hash is reimplemented because = is implemented." ^value! ! !Character methodsFor: 'testing'! isAlphaNumeric "Answer whether the receiver is a letter or a digit." ^self isLetter or: [self isDigit]! ! !Character methodsFor: 'testing'! isDigit "Answer whether the receiver is a digit." ^value >= 48 and: [value <= 57]! ! !Character methodsFor: 'testing'! isLetter "Answer whether the receiver is a letter." ^(8r141 <= value and: [value <= 8r172]) or: [8r101 <= value and: [value <= 8r132]]! ! !Character methodsFor: 'testing'! isLowercase "Answer whether the receiver is a lowercase letter. (The old implementation answered whether the receiver is not an uppercase letter.)" ^8r141 <= value and: [value <= 8r172]! ! !Character methodsFor: 'testing'! isSeparator "Answer whether the receiver is one of the separator characters--space, cr, tab, line feed, or form feed." value = 32 ifTrue: [^true]. "space" value = 13 ifTrue: [^true]. "cr" value = 9 ifTrue: [^true]. "tab" value = 10 ifTrue: [^true]. "line feed" value = 12 ifTrue: [^true]. "form feed" ^false! ! !Character methodsFor: 'testing'! isSpecial "Answer whether the receiver is one of the special characters" ^'+/\*~<>=@%|&?!!' includes: self! ! !Character methodsFor: 'testing'! isUppercase "Answer whether the receiver is an uppercase letter. (The old implementation answered whether the receiver is not a lowercase letter.)" ^8r101 <= value and: [value <= 8r132]! ! !Character methodsFor: 'testing'! isVowel "Answer whether the receiver is one of the vowels, AEIOU, in upper or lower case." ^'AEIOU' includes: self asUppercase! ! !Character methodsFor: 'testing'! tokenish "Answer whether the receiver is a valid token-character--letter, digit, or colon." ^self isLetter or: [self isDigit or: [self = $:]]! ! !Character methodsFor: 'copying'! copy "Answer with the receiver because Characters are unique."! ! !Character methodsFor: 'copying'! deepCopy "Answer with the receiver because Characters are unique."! ! !Character methodsFor: 'printing'! hex ^ String with: ('0123456789ABCDEF' at: value//16+1) with: ('0123456789ABCDEF' at: value\\16+1)! ! !Character methodsFor: 'printing'! isLiteral ^true! ! !Character methodsFor: 'printing'! printOn: aStream aStream nextPut: $$. aStream nextPut: self! ! !Character methodsFor: 'printing'! storeOn: aStream "Character literals are preceded by '$'." aStream nextPut: $$; nextPut: self! ! !Character methodsFor: 'converting'! asCharacter "Answer the receiver itself." ^self! ! !Character methodsFor: 'converting'! asInteger "Answer the value of the receiver." ^value! ! !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 methodsFor: 'converting'! asString | cString | cString _ String new: 1. cString at: 1 put: self. ^ cString! ! !Character methodsFor: 'converting'! asSymbol "Answer a Symbol consisting of the receiver as the only element." ^Symbol internCharacter: self! ! !Character methodsFor: 'converting'! asUppercase "If the receiver is lowercase, answer its matching uppercase Character." (8r141 <= value and: [value <= 8r172]) "self isLowercase" ifTrue: [^ Character value: value - 8r40] ifFalse: [^ self]! ! !Character methodsFor: 'converting'! to: other "Answer with a collection in ascii order -- $a to: $z" ^ (self asciiValue to: other asciiValue) collect: [:ascii | Character value: ascii]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Character class instanceVariableNames: ''! !Character class methodsFor: 'class initialization'! initialize "Create the table of unique Characters. This code is not shown so that the user can not destroy the system by trying to recreate the table."! ! !Character class methodsFor: 'instance creation'! digitValue: x "Answer the Character whose digit value is x. For example, answer $9 for x=9, $0 for x=0, $A for x=10, $Z for x=35." | index | index _ x asInteger. ^CharacterTable at: (index < 10 ifTrue: [48 + index] ifFalse: [55 + index]) + 1! ! !Character class methodsFor: 'instance creation'! new "Creating new characters is not allowed." self error: 'cannot create new characters'! ! !Character class methodsFor: 'instance creation'! separators ^ #(32 "space" 13 "cr" 9 "tab" 10 "line feed" 12 "form feed") collect: [:v | Character value: v] ! ! !Character class methodsFor: 'instance creation'! value: anInteger "Answer the Character whose value is anInteger." ^CharacterTable at: anInteger + 1! ! !Character class methodsFor: 'accessing untypeable characters'! backspace "Answer the Character representing a backspace." ^self value: 8! ! !Character class methodsFor: 'accessing untypeable characters'! cr "Answer the Character representing a carriage return." ^self value: 13! ! !Character class methodsFor: 'accessing untypeable characters'! enter "Answer the Character representing enter." ^self value: 3! ! !Character class methodsFor: 'accessing untypeable characters'! linefeed "Answer the Character representing a linefeed." ^self value: 10! ! !Character class methodsFor: 'accessing untypeable characters'! newPage "Answer the Character representing a form feed." ^self value: 12! ! !Character class methodsFor: 'accessing untypeable characters'! space "Answer the Character representing a space." ^self value: 32! ! !Character class methodsFor: 'accessing untypeable characters'! tab "Answer the Character representing a tab." ^self value: 9! ! !Character class methodsFor: 'constants' stamp: 'tk 12/11/97 09:29'! alphabet ^ 'abdcefghijklmnopqrstuvwxyz'! ! !Character class methodsFor: 'constants'! characterTable "Answer the class variable in which unique Characters are stored." ^CharacterTable! ! Rectangle subclass: #CharacterBlock instanceVariableNames: 'stringIndex text textLine ' classVariableNames: '' poolDictionaries: 'TextConstants ' category: 'Graphics-Support'! !CharacterBlock commentStamp: 'di 5/22/1998 16:32' prior: 0! CharacterBlock comment: 'My instances contain information about displayed characters. They are used to return the results of methods: Paragraph characterBlockAtPoint: aPoint and Paragraph characterBlockForIndex: stringIndex. Any recomposition or movement of a Paragraph can make the instance obsolete.'! !CharacterBlock methodsFor: 'accessing'! stringIndex "Answer the position of the receiver in the string it indexes." ^stringIndex! ! !CharacterBlock methodsFor: 'accessing' stamp: 'di 12/2/97 14:33'! textLine ^ textLine! ! !CharacterBlock methodsFor: 'accessing' stamp: 'di 12/2/97 14:33'! textLine: aLine textLine _ aLine! ! !CharacterBlock methodsFor: 'comparing'! < aCharacterBlock "Answer whether the string index of the receiver precedes that of aCharacterBlock." ^stringIndex < aCharacterBlock stringIndex! ! !CharacterBlock methodsFor: 'comparing'! <= aCharacterBlock "Answer whether the string index of the receiver does not come after that of aCharacterBlock." ^(self > aCharacterBlock) not! ! !CharacterBlock methodsFor: 'comparing'! = aCharacterBlock self species = aCharacterBlock species ifTrue: [^stringIndex = aCharacterBlock stringIndex] ifFalse: [^false]! ! !CharacterBlock methodsFor: 'comparing'! > aCharacterBlock "Answer whether the string index of the receiver comes after that of aCharacterBlock." ^aCharacterBlock < self! ! !CharacterBlock methodsFor: 'comparing'! >= aCharacterBlock "Answer whether the string index of the receiver does not precede that of aCharacterBlock." ^(self < aCharacterBlock) not! ! !CharacterBlock methodsFor: 'printing' stamp: 'di 12/2/97 19:15'! printOn: aStream aStream nextPutAll: 'a CharacterBlock with index '. stringIndex printOn: aStream. (text ~~ nil and: [text size> 0 and: [stringIndex between: 1 and: text size]]) ifTrue: [aStream nextPutAll: ' and character '. (text at: stringIndex) printOn: aStream]. aStream nextPutAll: ' and rectangle '. super printOn: aStream. textLine ifNotNil: [aStream cr; nextPutAll: ' in '. textLine printOn: aStream]. ! ! !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' stamp: 'di 10/23/97 22:33'! stringIndex: anInteger text: aText topLeft: topLeft extent: extent stringIndex _ anInteger. text _ aText. super setOrigin: topLeft corner: topLeft + extent ! ! CharacterScanner subclass: #CharacterBlockScanner instanceVariableNames: 'characterPoint characterIndex lastCharacter lastCharacterExtent lastSpaceOrTabExtent nextLeftMargin specialWidth ' classVariableNames: '' poolDictionaries: 'TextConstants ' category: 'Graphics-Support'! !CharacterBlockScanner commentStamp: 'di 5/22/1998 16:32' prior: 0! CharacterBlockScanner comment: 'My instances are used to scan text to compute the CharacterBlock for a character specified by its index in the text or its proximity to the cursor location.'! !CharacterBlockScanner methodsFor: 'scanning'! characterBlockAtPoint: aPoint in: aParagraph "Answer a CharacterBlock for character in aParagraph at point aPoint. It is assumed that aPoint has been transformed into coordinates appropriate to the text's destination form rectangle and the composition rectangle." super initializeFromParagraph: aParagraph clippedBy: aParagraph clippingRectangle. characterPoint _ aPoint. ^self buildCharacterBlockIn: aParagraph! ! !CharacterBlockScanner methodsFor: 'scanning' stamp: 'di 12/2/97 14:30'! characterBlockAtPoint: aPoint index: index in: textLine | runLength lineStop done stopCondition | line _ textLine. characterIndex _ index. " == nil means scanning for point" characterPoint _ aPoint. (characterPoint == nil or: [characterPoint y > line bottom]) ifTrue: [characterPoint _ line bottomRight]. (text isEmpty or: [(characterPoint y < line top or: [characterPoint x < line left]) or: [characterIndex ~~ nil and: [characterIndex < line first]]]) ifTrue: [^ (CharacterBlock new stringIndex: line first text: text topLeft: line leftMargin@line top extent: 0 @ textStyle lineGrid) textLine: line]. rightMargin _ line rightMargin. destX _ leftMargin _ line leftMarginForAlignment: textStyle alignment. destY _ line top. 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 "scanning for point"]. runStopIndex _ lastIndex + (runLength - 1) min: 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 kern: kern displaying: false. "see setStopConditions for stopping conditions for character block operations." self lastCharacterExtentSetX: (specialWidth == nil ifTrue: [font widthOf: (text at: lastIndex)] ifFalse: [specialWidth]). (self perform: stopCondition) ifTrue: [^ (CharacterBlock new stringIndex: (characterIndex==nil ifTrue: [lastIndex] ifFalse: [characterIndex]) text: text topLeft: characterPoint extent: lastCharacterExtent) textLine: line]]! ! !CharacterBlockScanner methodsFor: 'scanning'! characterBlockForIndex: targetIndex in: aParagraph "Answer a CharacterBlock for character in aParagraph at targetIndex. The coordinates in the CharacterBlock will be appropriate to the intersection of the destination form rectangle and the composition rectangle." super initializeFromParagraph: aParagraph clippedBy: aParagraph clippingRectangle. characterIndex _ targetIndex. characterPoint _ aParagraph rightMarginForDisplay @ (aParagraph topAtLineIndex: (aParagraph lineIndexOfCharacterIndex: characterIndex)). ^self buildCharacterBlockIn: aParagraph! ! !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: 'scanning' stamp: 'di 11/12/97 19:34'! placeEmbeddedObject: anchoredMorph (super placeEmbeddedObject: anchoredMorph) ifFalse: [^ false]. specialWidth _ width. ^ true! ! !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' stamp: 'di 11/7/97 12:20'! 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)) ifTrue: [lastCharacter _ (text at: lastIndex). characterPoint _ destX @ destY. ^true]. lastIndex >= line last ifTrue: [lastCharacter _ (text at: line last). 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' stamp: 'di 11/11/97 08:50'! setFont specialWidth _ nil. super setFont! ! !CharacterBlockScanner methodsFor: 'stop conditions'! setStopConditions "Set the font and the stop conditions for the current run." self setFont. stopConditions at: (Space asciiValue + 1) put: (textStyle alignment = Justified ifTrue: [#paddedSpace] ifFalse: [nil])! ! !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' stamp: 'di 12/2/97 14:30'! buildCharacterBlockIn: para | lineIndex runLength lineStop done stopCondition | "handle nullText" (para numberOfLines = 0 or: [text size = 0]) ifTrue: [^ CharacterBlock new stringIndex: 1 "like being off end of string" text: para text topLeft: (para leftMarginForDisplayForLine: 1) @ para compositionRectangle top extent: 0 @ textStyle lineGrid]. "find the line" lineIndex _ para lineIndexOfTop: characterPoint y. destY _ para topAtLineIndex: lineIndex. line _ para lines at: lineIndex. rightMargin _ para rightMarginForDisplay. (lineIndex = para numberOfLines and: [(destY + line lineHeight) < characterPoint y]) ifTrue: ["if beyond lastLine, force search to last character" self characterPointSetX: rightMargin] ifFalse: [characterPoint y < (para compositionRectangle) top ifTrue: ["force search to first line" characterPoint _ (para compositionRectangle) topLeft]. characterPoint x > rightMargin ifTrue: [self characterPointSetX: rightMargin]]. destX _ leftMargin _ para leftMarginForDisplayForLine: lineIndex. nextLeftMargin_ para 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 kern: kern displaying: false. "see setStopConditions for stopping conditions for character block operations." self lastCharacterExtentSetX: (font widthOf: (text at: lastIndex)). (self perform: stopCondition) ifTrue: [^ CharacterBlock new stringIndex: lastIndex text: text 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! ! BitBlt subclass: #CharacterScanner instanceVariableNames: 'lastIndex xTable stopConditions text textStyle leftMargin rightMargin font line runStopIndex spaceCount spaceWidth emphasisCode kern ' classVariableNames: '' poolDictionaries: 'TextConstants ' category: 'Graphics-Support'! !CharacterScanner commentStamp: 'di 5/22/1998 16:32' prior: 0! CharacterScanner comment: 'My instances hold the state associated with scanning text. My subclasses scan characters for specified purposes, such as computing a CharacterBlock or placing characters into Forms.'! !CharacterScanner methodsFor: 'scanning' stamp: 'di 10/29/97 12:16'! characterNotInFont "All fonts have an illegal character to be used when a character is not within the font's legal range. When characters out of ranged are encountered in scanning text, then this special character indicates the appropriate behavior. The character is usually treated as a unary message understood by a subclass of CharacterScanner." | illegalAsciiString saveIndex stopCondition | saveIndex _ lastIndex. illegalAsciiString _ String with: (font maxAscii + 1) asCharacter. stopCondition _ self scanCharactersFrom: 1 to: 1 in: illegalAsciiString rightX: rightMargin stopConditions: stopConditions kern: kern displaying: self doesDisplaying. lastIndex _ saveIndex + 1. stopCondition ~= (stopConditions at: EndOfRun) ifTrue: [^self perform: stopCondition] ifFalse: [lastIndex = runStopIndex ifTrue: [^self perform: (stopConditions at: EndOfRun)]. ^false] ! ! !CharacterScanner methodsFor: 'scanning' stamp: 'jm 11/19/97 23:15'! ifCharIn: str at: i fits: segLen do: fonCharWidthBlock "Scan a character of text, tracking font changes, and return true, unless the character won't fit or it is off the end of the string." "No kerning yet..." | ascii char maxAscii | i > str size ifTrue: [^ false]. (runStopIndex == nil or: [i > runStopIndex]) ifTrue: [runStopIndex _ i + (text runLengthFor: i) - 1. lastIndex _ i. self setFont]. maxAscii _ xTable size-2. ascii _ (char _ str at: i) asciiValue min: maxAscii. width _ (xTable at: ascii + 2) - (xTable at: ascii + 1). width > segLen ifTrue: [^ false]. fonCharWidthBlock value: font value: char value: width. ^ true! ! !CharacterScanner methodsFor: 'scanning'! leadingTab "return true if only tabs lie to the left" line first to: lastIndex do: [:i | (text at: i) == Tab ifFalse: [^ false]]. ^ true! ! !CharacterScanner methodsFor: 'scanning' stamp: 'di 11/17/97 15:08'! placeEmbeddedObject: anchoredMorph "Place the anchoredMorph or return false if it cannot be placed. In any event, advance destX by its width." destX _ destX + (width _ anchoredMorph width). (destX > rightMargin and: [(leftMargin + width) <= rightMargin]) ifTrue: ["Won't fit, but would on next line" ^ false]. runStopIndex _ lastIndex. "Force new calc of emphasis" lastIndex _ lastIndex + 1. ^ true! ! !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 | 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: 'scanning' stamp: 'di 10/31/97 12:51'! scanCharactersFrom: startIndex to: stopIndex in: sourceString rightX: rightX stopConditions: stops kern: kernDelta displaying: display "This method will perform text scanning with non-zero kerning. It calls the faster primitive method, if the kern delta is zero. Some day we may want to put kerning into the primitive." | ascii nextDestX maxAscii fillBlt | kernDelta = 0 ifTrue: [^ self scanCharactersFrom: startIndex to: stopIndex in: sourceString rightX: rightX stopConditions: stops displaying: display]. display ifTrue: [fillBlt _ self fillBlt]. 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 fillBlt == nil ifFalse: [fillBlt destX: nextDestX destY: destY width: kernDelta height: height; copyBits]]. destX _ nextDestX + kernDelta. 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' stamp: 'di 10/29/97 11:58'! addKern: kernDelta "Set the current kern amount." kern _ kern + kernDelta! ! !CharacterScanner methodsFor: 'private' stamp: 'jm 11/19/97 21:56'! beginAt: startCharIndex lastIndex _ startCharIndex. runStopIndex _ lastIndex + (text runLengthFor: lastIndex) - 1. self setFont! ! !CharacterScanner methodsFor: 'private'! doesDisplaying ^false! ! !CharacterScanner methodsFor: 'private' stamp: 'jm 11/19/97 21:56'! ifNextCharFits: segLen do: fonCharWidthBlock! ! !CharacterScanner methodsFor: 'private'! initializeFromParagraph: aParagraph clippedBy: clippingRectangle text _ aParagraph text. textStyle _ aParagraph textStyle. destForm _ aParagraph destinationForm. self fillColor: aParagraph fillColor. "sets halftoneForm" self combinationRule: aParagraph rule. self clipRect: clippingRectangle. sourceY _ 0! ! !CharacterScanner methodsFor: 'private'! setActualFont: aFont "Set the basal font to an isolated font reference." font _ aFont! ! !CharacterScanner methodsFor: 'private' stamp: 'di 10/29/97 12:00'! setFont "Set the font and other emphasis." self setFont: 1. emphasisCode _ 0. kern _ 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' stamp: 'di 10/24/97 09:05'! setFont: fontNumber "Set the font by number from the textStyle." self setActualFont: (textStyle fontAt: fontNumber)! ! !CharacterScanner methodsFor: 'private' stamp: 'jm 11/19/97 20:51'! setFontAt: startCharIndex lastIndex _ startCharIndex. self setFont! ! !CharacterScanner methodsFor: 'private' stamp: 'di 10/22/97 11:52'! text: t textStyle: ts text _ t. textStyle _ ts! ! !CharacterScanner methodsFor: 'private'! textColor: ignored "Overridden in DisplayScanner"! ! ServerAction subclass: #ChatPage instanceVariableNames: 'current ' classVariableNames: '' poolDictionaries: '' category: 'PluggableWebServer'! !ChatPage commentStamp: 'di 5/22/1998 16:32' prior: 0! Simple ServerAction that allows a primitive chat session shown as a web page. It maintains a list of the 20 most recent submissions. There is a form on the page for typing your contribution to the session. The default Swiki has a chat page enabled. Get to the page by this URL: machine:80/chat! !ChatPage methodsFor: 'chat processing' stamp: 'mjg 11/25/97 13:33'! add: aMessage current isNil ifTrue: [current _ OrderedCollection new]. current add: aMessage. (current size > 20) ifTrue: [current _ current copyFrom: (current size - 20) to: (current size)]! ! !ChatPage methodsFor: 'chat processing' stamp: 'mjg 11/17/97 13:32'! current ^current ! ! !ChatPage methodsFor: 'URL processing' stamp: 'mjg 11/25/97 13:34'! process: request | author note | request fields isNil ifTrue: [current isNil ifTrue: [current _ OrderedCollection new]. request reply: (HTMLformatter evalEmbedded: (self fileContents: 'chat.html') with: current)] ifFalse: [author _ request fields at: 'author'. note _ request fields at: 'note'. self add: '' , author , ' ' , Time now printString , '-' , Date today printString , '

' , note , '

'. request fields at: 'current' put: current. request reply: (HTMLformatter evalEmbedded: (self fileContents: 'chat.html') with: request)]! ! Arc subclass: #Circle instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Graphics-Paths'! !Circle commentStamp: 'di 5/22/1998 16:32' prior: 0! Circle comment: 'I represent a full circle. I am made from four Arcs.'! !Circle methodsFor: 'displaying'! displayOn: aDisplayMedium at: aPoint clippingBox: clipRect rule: anInteger fillColor: aForm 1 to: 4 do: [:i | super quadrant: i. super displayOn: aDisplayMedium at: aPoint clippingBox: clipRect rule: anInteger fillColor: aForm]! ! !Circle methodsFor: 'displaying'! displayOn: aDisplayMedium transformation: aTransformation clippingBox: clipRect rule: anInteger fillColor: aForm 1 to: 4 do: [:i | super quadrant: i. super displayOn: aDisplayMedium transformation: aTransformation clippingBox: clipRect rule: anInteger fillColor: aForm]! ! !Circle methodsFor: 'display box access'! computeBoundingBox ^center - radius + form offset extent: form extent + (radius * 2) asPoint! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Circle class instanceVariableNames: ''! !Circle class methodsFor: 'examples'! exampleOne "Click any button somewhere on the screen. The point will be the center of the circcle of radius 150." | aCircle aForm | aForm _ Form extent: 1@30. aForm fillBlack. aCircle _ Circle new. aCircle form: aForm. aCircle radius: 150. aCircle center: Sensor waitButton. aCircle displayOn: Display "Circle exampleOne"! ! !Circle class methodsFor: 'examples'! exampleTwo "Designate a rectangular area that should be used as the brush for displaying the circle. Click any button at a point on the screen which will be the center location for the circle. The curve will be displayed with a long black form." | aCircle aForm | aForm _ Form fromUser. aCircle _ Circle new. aCircle form: aForm. aCircle radius: 150. aCircle center: Sensor waitButton. aCircle displayOn: Display at: 0 @ 0 rule: Form reverse "Circle exampleTwo"! ! ClassDescription subclass: #Class instanceVariableNames: 'name classPool sharedPools ' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Classes'! !Class commentStamp: 'di 5/22/1998 16:32' prior: 0! Class comment: 'My instances describe the representation and behavior of objects. I add more comprehensive programming support facilities to the basic attributes of Behavior and the descriptive facilities of ClassDescription. An example is accessing shared (pool) variables.'! !Class methodsFor: 'initialize-release'! declare: varString "Declare class variables common to all instances. Answer whether recompilation is advisable." | newVars conflicts assoc class | newVars _ (Scanner new scanFieldNames: varString) collect: [:x | x asSymbol]. newVars do: [:var | var first isLowercase ifTrue: [self error: var, ' class variable name should be capitalized; proceed to include anyway.']]. conflicts _ false. classPool == nil ifFalse: [(classPool keys reject: [:x | newVars includes: x]) do: [:var | self removeClassVarName: var]]. (newVars reject: [:var | self classPool includesKey: var]) do: [:var | "adding" "check if new vars defined elsewhere" (self scopeHas: var ifTrue: [:ignored | ignored]) ifTrue: [self error: var , ' is defined elsewhere'. conflicts _ true]]. newVars size > 0 ifTrue: [classPool _ self classPool. "in case it was nil" newVars do: [:var | classPool declare: var from: Undeclared]]. ^conflicts! ! !Class methodsFor: 'initialize-release'! obsolete "Change the receiver to an obsolete class by changing its name to have the prefix -AnObsolete-." name _ 'AnObsolete' , name. classPool _ Dictionary new. self class obsolete. super obsolete! ! !Class methodsFor: 'initialize-release'! removeFromSystem "Forget the receiver from the Smalltalk global dictionary. Any existing instances will refer to an obsolete version of the receiver." Smalltalk removeClassFromSystem: self. self obsolete! ! !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: 'initialize-release'! superclass: sup methodDict: md format: ft name: nm organization: org instVarNames: nilOrArray classPool: pool sharedPools: poolSet "Answer an instance of me, a new class, using the arguments of the message as the needed information." superclass _ sup. methodDict _ md. format _ ft. name _ nm. organization _ org. instanceVariables _ nilOrArray. classPool _ pool. sharedPools _ poolSet! ! !Class methodsFor: 'initialize-release'! validateFrom: oldClass in: environ instanceVariableNames: invalidFields methods: invalidMethods "Recompile the receiver and redefine its subclasses if necessary." super validateFrom: oldClass in: environ instanceVariableNames: invalidFields methods: invalidMethods. self ~~ oldClass ifTrue: [environ at: name put: self. oldClass obsolete]! ! !Class methodsFor: 'accessing'! classPool "Answer the dictionary of class variables." classPool == nil ifTrue: [^Dictionary new] ifFalse: [^classPool]! ! !Class methodsFor: 'accessing'! name "Answer the name of the receiver." name == nil ifTrue: [^super name] ifFalse: [^name]! ! !Class methodsFor: 'testing'! hasMethods "Answer a Boolean according to whether any methods are defined for the receiver (includes whether there are methods defined in the receiver's metaclass)." ^super hasMethods or: [self class hasMethods]! ! !Class methodsFor: 'copying'! copy | newClass | newClass _ self class copy new superclass: superclass methodDict: methodDict copy format: format name: name organization: organization copy instVarNames: instanceVariables copy classPool: classPool copy sharedPools: sharedPools. Class instSize+1 to: self class instSize do: [:offset | newClass instVarAt: offset put: (self instVarAt: offset)]. ^ newClass! ! !Class methodsFor: 'copying'! copyForValidation "Make a copy of the receiver (a class) but do not install the created class as a new class in the system. This is used for creating a new version of the receiver in which the installation is deferred until all changes are successfully completed." | newClass | newClass _ self class copy new superclass: superclass methodDict: methodDict copy format: format name: name organization: organization instVarNames: instanceVariables copy classPool: classPool sharedPools: sharedPools. Class instSize+1 to: self class instSize do: [:offset | newClass instVarAt: offset put: (self instVarAt: offset)]. ^ newClass! ! !Class methodsFor: 'copying' stamp: 'sw 6/12/96'! copyOfMethodDictionary "Return a copy of the receiver's method dictionary. " ^ methodDict copy! ! !Class methodsFor: 'class name' stamp: 'tk 3/10/98 08:15'! 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. ! ! !Class methodsFor: 'instance variables'! addInstVarName: aString "Add the argument, aString, as one of the receiver's instance variables." superclass class name: self name inEnvironment: Smalltalk subclassOf: superclass instanceVariableNames: self instanceVariablesString , aString variable: self isVariable words: self isWords pointers: self isPointers classVariableNames: self classVariablesString poolDictionaries: self sharedPoolsString category: self category comment: nil changed: false! ! !Class methodsFor: 'instance variables'! removeInstVarName: aString "Remove the argument, aString, as one of the receiver's instance variables." | newInstVarString | (self instVarNames includes: aString) ifFalse: [self error: aString , ' is not one of my instance variables']. newInstVarString _ ''. (self instVarNames copyWithout: aString) do: [:varName | newInstVarString _ newInstVarString , ' ' , varName]. superclass class name: self name inEnvironment: Smalltalk subclassOf: superclass instanceVariableNames: newInstVarString variable: self isVariable words: self isWords pointers: self isPointers classVariableNames: self classVariablesString poolDictionaries: self sharedPoolsString category: self category comment: nil changed: false! ! !Class methodsFor: 'class variables'! addClassVarName: aString "Add the argument, aString, as a class variable of the receiver. Signal an error if the first character of aString is not capitalized, or if it is already a variable named in the class." | symbol index | aString first isLowercase ifTrue: [^self error: aString, ' class variable name should be capitalized; proceed to include anyway.']. symbol _ aString asSymbol. self withAllSubclasses do: [:subclass | subclass scopeHas: symbol ifTrue: [:temp | ^ self error: aString , ' is already used as a variable name in class ' , subclass name]]. classPool == nil ifTrue: [classPool _ Dictionary new]. (classPool includesKey: symbol) ifFalse: ["Pick up any refs in Undeclared" classPool declare: symbol from: Undeclared. Smalltalk changes changeClass: self]! ! !Class methodsFor: 'class variables'! allClassVarNames "Answer a Set of the names of the receiver's class variables, including those defined in the superclasses of the receiver." | aSet | superclass == nil ifTrue: [^self classVarNames] "This is the keys so it is a new Set." ifFalse: [aSet _ superclass allClassVarNames. aSet addAll: self classVarNames. ^aSet]! ! !Class methodsFor: 'class variables'! classVarNames "Answer a Set of the names of the class variables defined in the receiver." ^self classPool keys! ! !Class methodsFor: 'class variables' stamp: 'tk 3/15/98 20:19'! ensureClassPool classPool ifNil: [classPool _ Dictionary new].! ! !Class methodsFor: 'class variables'! initialize "Typically used for the initialization of class variables and metaclass instance variables. Does nothing, but may be overridden in Metaclasses." ^self! ! !Class methodsFor: 'class variables'! removeClassVarName: aString "Remove the class variable whose name is the argument, aString, from the names defined in the receiver, a class. Create an error notification if aString is not a class variable or if it is still being used in the code of the class." | anAssoc aSymbol | aSymbol _ aString asSymbol. (classPool includesKey: aSymbol) ifFalse: [^self error: aString, ' is not a class variable']. anAssoc _ classPool associationAt: aSymbol. self withAllSubclasses do: [:subclass | (Array with: subclass with: subclass class) do: [:classOrMeta | (classOrMeta whichSelectorsReferTo: (classPool associationAt: aSymbol)) isEmpty ifFalse: [^self error: aString , ' is still used in code of class ' , classOrMeta name]]]. classPool removeKey: aSymbol! ! !Class methodsFor: 'pool variables'! addSharedPool: aDictionary "Add the argument, aDictionary, as one of the receiver's pool dictionaries. Create an error if the dictionary is already one of the pools." (self sharedPools includes: aDictionary) ifTrue: [^self error: 'The dictionary is already in my pool']. sharedPools == nil ifTrue: [sharedPools _ OrderedCollection with: aDictionary] ifFalse: [sharedPools add: aDictionary]! ! !Class methodsFor: 'pool variables'! allSharedPools "Answer a Set of the pools the receiver shares, including those defined in the superclasses of the receiver." | aSet | superclass == nil ifTrue: [^self sharedPools copy] ifFalse: [aSet _ superclass allSharedPools. aSet addAll: self sharedPools. ^aSet]! ! !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: 'pool variables'! sharedPools "Answer a Set of the pool dictionaries declared in the receiver." sharedPools == nil ifTrue: [^OrderedCollection new] ifFalse: [^sharedPools]! ! !Class methodsFor: 'compiling'! compileAllFrom: oldClass "Recompile all the methods in the receiver's method dictionary (not the subclasses). Also recompile the methods in the metaclass." super compileAllFrom: oldClass. self class compileAllFrom: oldClass class! ! !Class methodsFor: 'compiling'! possibleVariablesFor: misspelled continuedFrom: oldResults | results | results _ misspelled correctAgainstDictionary: self classPool continuedFrom: oldResults. self sharedPools do: [:pool | results _ misspelled correctAgainstDictionary: pool continuedFrom: results ]. superclass == nil ifTrue: [ ^ misspelled correctAgainstDictionary: Smalltalk continuedFrom: results ] ifFalse: [ ^ superclass possibleVariablesFor: misspelled continuedFrom: results ]! ! !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: 'subclass creation' stamp: 'sw 5/19/1998 09:07'! 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: 'UserObjects' "Point newSubclass new"! ! !Class methodsFor: 'subclass creation'! subclass: t instanceVariableNames: f classVariableNames: d poolDictionaries: s category: cat "This is the standard initialization message for creating a new class as a subclass of an existing class (the receiver)." self isVariable ifTrue: [self isPointers ifTrue: [^self variableSubclass: t instanceVariableNames: f classVariableNames: d poolDictionaries: s category: cat]. self isBytes ifTrue: [^self variableByteSubclass: t instanceVariableNames: f classVariableNames: d poolDictionaries: s category: cat]. ^self variableWordSubclass: t instanceVariableNames: f classVariableNames: d poolDictionaries: s category: cat]. ^self class name: t inEnvironment: Smalltalk subclassOf: self instanceVariableNames: f variable: false words: true pointers: true classVariableNames: d poolDictionaries: s category: cat comment: nil changed: false! ! !Class methodsFor: 'subclass creation'! variableByteSubclass: t instanceVariableNames: f classVariableNames: d poolDictionaries: s category: cat "This is the standard initialization message for creating a new class as a subclass of an existing class (the receiver) in which the subclass is to have indexable byte-sized nonpointer variables." self instSize > 0 ifTrue: [^self error: 'cannot make a byte subclass of a class with named fields']. (self isVariable and: [self isWords]) ifTrue: [^self error: 'cannot make a byte subclass of a class with word fields']. (self isVariable and: [self isPointers]) ifTrue: [^self error: 'cannot make a byte subclass of a class with pointer fields']. ^self class name: t inEnvironment: Smalltalk subclassOf: self instanceVariableNames: f variable: true words: false pointers: false classVariableNames: d poolDictionaries: s category: cat comment: nil changed: false! ! !Class methodsFor: 'subclass creation'! variableSubclass: t instanceVariableNames: f classVariableNames: d poolDictionaries: s category: cat "This is the standard initialization message for creating a new class as a subclass of an existing class (the receiver) in which the subclass is to have indexable pointer variables." self isBits ifTrue: [^self error: 'cannot make a pointer subclass of a class with non-pointer fields']. ^self class name: t inEnvironment: Smalltalk subclassOf: self instanceVariableNames: f variable: true words: true pointers: true classVariableNames: d poolDictionaries: s category: cat comment: nil changed: false! ! !Class methodsFor: 'subclass creation'! variableWordSubclass: t instanceVariableNames: f classVariableNames: d poolDictionaries: s category: cat "This is the standard initialization message for creating a new class as a subclass of an existing class (the receiver) in which the subclass is to have indexable word-sized nonpointer variables." self instSize > 0 ifTrue: [^self error: 'cannot make a word subclass of a class with named fields']. self isBytes ifTrue: [^self error: 'cannot make a word subclass of a class with byte fields']. (self isVariable and: [self isPointers]) ifTrue: [^self error: 'cannot make a word subclass of a class with pointer fields']. ^self class name: t inEnvironment: Smalltalk subclassOf: self instanceVariableNames: f variable: true words: true pointers: false classVariableNames: d poolDictionaries: s category: cat comment: nil changed: false! ! !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: 'jm 3/27/98 08:31'! fileOutAsHtml: useHtml "File a description of the receiver onto a new file whose base name is the name of the receiver." | fileStream | fileStream _ useHtml ifTrue: [(FileStream newFileNamed: self name, FileDirectory dot, 'html') asHtml] ifFalse: [FileStream newFileNamed: self name, FileDirectory dot, '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. ! ! !Class methodsFor: 'fileIn/Out'! 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." Transcript cr; show: name. super fileOutOn: aFileStream moveSource: moveSource toFile: fileIndex. self class nonTrivial ifTrue: [aFileStream cr; nextPutAll: '"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!!'; cr; cr. self class fileOutOn: aFileStream moveSource: moveSource toFile: fileIndex]! ! !Class methodsFor: 'fileIn/Out' stamp: 'ikp 1/3/98 22:45'! fileOutPool: aPool onFileStream: aFileStream | aPoolName aValue | aPoolName _ Smalltalk keyAtValue: aPool. Transcript cr; show: aPoolName. aFileStream nextPutAll: 'Transcript show: ''' , aPoolName , '''; cr!!'; cr. aFileStream nextPutAll: 'Smalltalk at: #' , aPoolName , ' put: Dictionary new!!'; cr. aPool keys asSortedCollection do: [ :aKey | aValue _ aPool at: aKey. aFileStream nextPutAll: aPoolName , ' at: #' , aKey asString , ' put: '. (aValue isKindOf: Number) ifTrue: [aValue printOn: aFileStream] ifFalse: [aFileStream nextPutAll: '('. aValue printOn: aFileStream. aFileStream nextPutAll: ')']. aFileStream nextPutAll: '!!'; cr]. aFileStream cr! ! !Class methodsFor: 'fileIn/Out'! fileOutSharedPoolsOn: aFileStream "file out the shared pools of this class after prompting the user about each pool" | poolsToFileOut | poolsToFileOut _ self sharedPools select: [:aPool | (self shouldFileOutPool: (Smalltalk keyAtValue: aPool))]. poolsToFileOut do: [:aPool | self fileOutPool: aPool onFileStream: aFileStream]. ! ! !Class methodsFor: 'fileIn/Out' stamp: 'tk 3/24/98 10:16'! objectToStoreOnDataStream "I am about to be written on an object file. Write a reference to a class in Smalltalk instead." ^ DiskProxy global: self theNonMetaClass name selector: #yourself args: (Array new)! ! !Class methodsFor: 'fileIn/Out'! reformatAll "Reformat all methods in this class. Leaves old code accessible to version browsing" super reformatAll. "me..." self class reformatAll "...and my metaclass"! ! !Class methodsFor: 'fileIn/Out'! removeFromChanges "References to the receiver, a class, and its metaclass should no longer be included in the system ChangeSet. 7/18/96 sw: call removeClassAndMetaClassChanges:" Smalltalk changes removeClassAndMetaClassChanges: self! ! !Class methodsFor: 'fileIn/Out'! shouldFileOutPool: aPoolName "respond with true if the user wants to file out aPoolName" ^self confirm: ('FileOut the sharedPool ', aPoolName, '?')! ! !Class methodsFor: 'fileIn/Out'! shouldFileOutPools "respond with true if the user wants to file out the shared pools" ^self confirm: 'FileOut selected sharedPools?'! ! !Class methodsFor: 'fileIn/Out' stamp: 'tk 3/26/98 10:18'! storeDataOn: aDataStream "I don't get stored. Use a DiskProxy" self error: 'use a DiskProxy to store a Class'! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Class class instanceVariableNames: ''! !Class class methodsFor: 'instance creation'! template: category "Answer an expression that can be edited and evaluated in order to define a new class." ^'Object subclass: #NameOfClass instanceVariableNames: ''instVarName1 instVarName2'' classVariableNames: ''ClassVarName1 ClassVarName2'' poolDictionaries: '''' category: ''' , category , ''''! ! !Class class methodsFor: 'fileIn/Out'! fileOutPool: aString "file out the global pool named aString" | f | f _ FileStream newFileNamed: aString, '.st'. self new fileOutPool: (Smalltalk at: aString asSymbol) onFileStream: f. f close. ! ! Object subclass: #ClassCategoryReader instanceVariableNames: 'class category changeStamp ' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Classes'! !ClassCategoryReader commentStamp: 'di 5/22/1998 16:32' prior: 0! ClassCategoryReader comment: 'I represent a mechanism for retrieving class descriptions stored on a file.'! !ClassCategoryReader methodsFor: 'fileIn/Out' stamp: 'tk 12/15/97 16:26'! scanFrom: aStream "File in methods from the stream, aStream." | methodText | [methodText _ aStream nextChunkText. methodText size > 0] whileTrue: [class compile: methodText 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 ! ! ClassCategoryReader subclass: #ClassCommentReader instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Classes'! !ClassCommentReader methodsFor: 'as yet unclassified' stamp: 'tk 12/15/97 15:56'! scanFrom: aStream "File in the class comment from aStream. Not string-i-fied, just a text, exactly as it is in the browser. Move to changes file." class theNonMetaClass classComment: (aStream nextChunkText). "Writes it on the disk and saves a RemoteString ref"! ! Behavior subclass: #ClassDescription instanceVariableNames: 'instanceVariables organization ' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Classes'! !ClassDescription commentStamp: 'di 5/22/1998 16:32' prior: 0! ClassDescription comment: 'I add a number of facilities to basic Behavior: Named instance variables Category organization for methods The notion of a name of this class (implemented as subclass responsibility) The maintenance of a ChangeSet, and logging changes on a file Most of the mechanism for fileOut. I am an abstract class, in particular, my facilities are intended for inheritance by two subclasses, Class and Metaclass.'! !ClassDescription methodsFor: 'initialize-release'! obsolete "Make the receiver obsolete." organization _ nil. super obsolete! ! !ClassDescription methodsFor: 'initialize-release' stamp: 'tk 3/19/98 10:18'! 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 ifNotNil: [superclass removeSubclass: self. "Object flushCache" "done in removeSubclass"]. 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'! classVersion "Default. Any class may return a later version to inform readers that use ReferenceStream. 8/17/96 tk" ^ 0! ! !ClassDescription methodsFor: 'accessing' stamp: 'tk 12/13/97 14:33'! comment "Answer the receiver's comment. (If old format, not a Text, unpack the old way.) " | aString | aString _ self theNonMetaClass organization classComment. (aString asString beginsWith: self name, ' comment:\''' withCRs) ifFalse: [^ self theNonMetaClass organization classComment] ifTrue: ["old format" aString size = 0 ifTrue: [^'']. "get string only of classComment, undoubling quotes" ^ String readFromString: aString]! ! !ClassDescription methodsFor: 'accessing' stamp: 'tk 12/16/97 07:49'! comment: aStringOrText "Set the receiver's comment to be the argument, aStringOrText." self theNonMetaClass classComment: aStringOrText. Smalltalk changes commentClass: self! ! !ClassDescription methodsFor: 'accessing'! isMeta ^ false! ! !ClassDescription methodsFor: 'accessing'! name "Answer a String that is the name of the receiver." self subclassResponsibility! ! !ClassDescription methodsFor: 'accessing'! theNonMetaClass "Sent to a class or metaclass, always return the class" ^self! ! !ClassDescription methodsFor: 'copying'! copy: sel from: class "Install the method associated with the first argument, sel, a message selector, found in the method dictionary of the second argument, class, as one of the receiver's methods. Classify the message under -As yet not classified-." self copy: sel from: class classified: nil! ! !ClassDescription methodsFor: 'copying'! copy: sel from: class classified: cat "Install the method associated with the first arugment, sel, a message selector, found in the method dictionary of the second argument, class, as one of the receiver's methods. Classify the message under the third argument, cat." | code category | "Useful when modifying an existing class" code _ class sourceMethodAt: sel. code == nil ifFalse: [cat == nil ifTrue: [category _ class organization categoryOfElement: sel] ifFalse: [category _ cat]. (methodDict includesKey: sel) ifTrue: [code asString = (self sourceMethodAt: sel) asString ifFalse: [self error: self name , ' ' , sel , ' will be redefined if you proceed.']]. self compile: code classified: category]! ! !ClassDescription methodsFor: 'copying'! copyAll: selArray from: class "Install all the methods found in the method dictionary of the second argument, class, as the receiver's methods. Classify the messages under -As yet not classified-." self copyAll: selArray from: class classified: nil! ! !ClassDescription methodsFor: 'copying'! copyAll: selArray from: class classified: cat "Install all the methods found in the method dictionary of the second argument, class, as the receiver's methods. Classify the messages under the third argument, cat." selArray do: [:s | self copy: s from: class classified: cat]! ! !ClassDescription methodsFor: 'copying'! copyAllCategoriesFrom: aClass "Specify that the categories of messages for the receiver include all of those found in the class, aClass. Install each of the messages found in these categories into the method dictionary of the receiver, classified under the appropriate categories." aClass organization categories do: [:cat | self copyCategory: cat from: aClass]! ! !ClassDescription methodsFor: 'copying'! copyCategory: cat from: class "Specify that one of the categories of messages for the receiver is cat, as found in the class, class. Copy each message found in this category." self copyCategory: cat from: class classified: cat! ! !ClassDescription methodsFor: 'copying'! copyCategory: cat from: aClass classified: newCat "Specify that one of the categories of messages for the receiver is the third argument, newCat. Copy each message found in the category cat in class aClass into this new category." self copyAll: (aClass organization listAtCategoryNamed: cat) from: aClass classified: newCat! ! !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'! instanceVariablesString "Answer a string of my instance variable names separated by spaces." | aStream names | aStream _ WriteStream on: (String new: 100). names _ self instVarNames. 1 to: names size do: [:i | aStream nextPutAll: (names at: i); space]. ^aStream contents! ! !ClassDescription methodsFor: 'printing'! printOn: aStream aStream nextPutAll: self name! ! !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: 'printing'! storeOn: aStream "Classes and Metaclasses have global names." aStream nextPutAll: self name! ! !ClassDescription methodsFor: 'instance variables'! addInstVarName: aString "Add the argument, aString, as one of the receiver's instance variables." self subclassResponsibility! ! !ClassDescription methodsFor: 'instance variables'! browseClassVariables "Put up a browser showing the receiver's class variables. 2/1/96 sw" self classPool inspectWithLabel: 'Class Variables in ', self name! ! !ClassDescription methodsFor: 'instance variables'! browseClassVarRefs "1/17/96 sw: moved here from Browser so that it could be used from a variety of places." | lines labelStream vars allVars index owningClasses | lines _ OrderedCollection new. allVars _ OrderedCollection new. owningClasses _ OrderedCollection new. labelStream _ WriteStream on: (String new: 200). self withAllSuperclasses reverseDo: [:class | vars _ class classVarNames asSortedCollection. vars do: [:var | labelStream nextPutAll: var; cr. allVars add: var. owningClasses add: class]. vars isEmpty ifFalse: [lines add: allVars size]]. labelStream skip: -1 "cut last CR". index _ (PopUpMenu labels: labelStream contents lines: lines) startUp. index = 0 ifTrue: [^ self]. Smalltalk browseAllCallsOn: ((owningClasses at: index) classPool associationAt: (allVars at: index))! ! !ClassDescription methodsFor: 'instance variables'! browseInstVarDefs "Copied from browseInstVarRefs. Should be consolidated some day. 7/29/96 di 7/30/96 sw: did the consolidation" self chooseInstVarThenDo: [:aVar | self browseAllStoresInto: aVar]! ! !ClassDescription methodsFor: 'instance variables'! browseInstVarRefs "1/16/96 sw: moved here from Browser so that it could be used from a variety of places. 7/30/96 sw: call chooseInstVarThenDo: to get the inst var choice" self chooseInstVarThenDo: [:aVar | self browseAllAccessesTo: aVar]! ! !ClassDescription methodsFor: 'instance variables' stamp: 'sw 7/29/97 18:34'! chooseInstVarThenDo: aBlock "Put up a menu of all the instance variables in the receiver, and when the user chooses one, evaluate aBlock with the chosen variable as its parameter. 7/30/96 sw" | lines labelStream vars allVars index | lines _ OrderedCollection new. allVars _ OrderedCollection new. labelStream _ WriteStream on: (String new: 200). self withAllSuperclasses reverseDo: [:class | vars _ class instVarNames. vars do: [:var | labelStream nextPutAll: var; cr. allVars add: var]. vars isEmpty ifFalse: [lines add: allVars size]]. labelStream isEmpty ifTrue: [^ (PopUpMenu labels: ' OK ') startUpWithCaption: 'There are no instance variables.']. labelStream skip: -1 "cut last CR". index _ (PopUpMenu labels: labelStream contents lines: lines) startUpWithCaption: 'Instance variables in ', class name. index = 0 ifTrue: [^ self]. aBlock value: (allVars at: index)! ! !ClassDescription methodsFor: 'instance variables'! forceNewFrom: anArray "Create a new instance of the class and fill its instance variables up with the array." | object max | object _ self new. max _ self instSize. anArray doWithIndex: [:each :index | index > max ifFalse: [object instVarAt: index put: each]]. ^ object! ! !ClassDescription methodsFor: 'instance variables'! instVarNames "Answer an Array of the receiver's instance variable names." instanceVariables == nil ifTrue: [^#()] ifFalse: [^instanceVariables]! ! !ClassDescription methodsFor: 'instance variables'! removeInstVarName: aString "Remove the argument, aString, as one of the receiver's instance variables. Create an error notification if the argument is not found." self subclassResponsibility! ! !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 variables is 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'! removeCategory: aString "Remove each of the messages categorized under aString in the method dictionary of the receiver. Then remove the category aString." | categoryName | categoryName _ aString asSymbol. (self organization listAtCategoryNamed: categoryName) do: [:sel | self removeSelector: sel]. self organization removeCategory: categoryName! ! !ClassDescription methodsFor: 'method dictionary' stamp: 'sw 2/28/98 22:02'! 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]. self wantsChangeSetLogging ifTrue: [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'! category "Answer the system organization category for the receiver." ^SystemOrganization categoryOfElement: self name! ! !ClassDescription methodsFor: 'organization'! category: cat "Categorize the receiver under the system category, cat, removing it from any previous categorization." (cat isKindOf: String) ifTrue: [SystemOrganization classify: self name under: cat asSymbol] ifFalse: [self errorCategoryName]! ! !ClassDescription methodsFor: 'organization'! organization "Answer the instance of ClassOrganizer that represents the organization of the messages of the receiver." organization==nil ifTrue: [organization _ ClassOrganizer defaultList: methodDict keys asSortedCollection asArray]. ^organization! ! !ClassDescription methodsFor: 'organization' stamp: 'di 7/17/97 00:06'! whichCategoryIncludesSelector: aSelector "Answer the category of the argument, aSelector, in the organization of the receiver, or answer nil if the receiver does not inlcude this selector." (self includesSelector: aSelector) ifTrue: [^ self organization categoryOfElement: aSelector] ifFalse: [^nil]! ! !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'! acceptsLoggingOfCompilation "weird name is so that it will come lexically before #compile, so that a clean build can make it through. 7/7/96 sw" ^ true! ! !ClassDescription methodsFor: 'compiling'! compile: code classified: heading "Compile the argument, code, as source code in the context of the receiver and install the result in the receiver's method dictionary under the classification indicated by the second argument, heading. nil 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 on an object that converts to a string." ^self compile: code classified: heading notifying: (SyntaxError new category: heading)! ! !ClassDescription methodsFor: 'compiling' stamp: 'sw 8/21/97 00:26'! compile: text classified: category notifying: requestor | stamp | stamp _ self acceptsLoggingOfCompilation ifTrue: [Utilities changeStamp] ifFalse: [nil]. ^ self compile: text classified: category withStamp: stamp notifying: requestor ! ! !ClassDescription methodsFor: 'compiling' stamp: 'di 2/2/98 12:51'! compile: text classified: category withStamp: changeStamp notifying: requestor | selector priorMethod method methodNode newText | 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: [newText _ (requestor ~~ nil and: [Preferences confirmFirstUseOfStyle]) ifTrue: [text askIfAddStyle: priorMethod req: requestor] ifFalse: [text]. method putSource: newText fromParseNode: methodNode class: self category: category withStamp: changeStamp inFile: 2 priorMethod: priorMethod]. self organization classify: selector under: category. ^selector! ! !ClassDescription methodsFor: 'compiling'! compile: code notifying: requestor "Refer to the comment in Behavior|compile:notifying:." ^self compile: code classified: ClassOrganizer default notifying: requestor! ! !ClassDescription methodsFor: 'compiling'! compile: code notifying: requestor trailer: bytes ifFail: failBlock elseSetSelectorAndNode: selAndNodeBlock "Intercept this message in order to remember system changes. 5/15/96 sw: modified so that if the class does not wish its methods logged in the changes file, then they also won't be accumulated in the current change set. 7/12/96 sw: use wantsChangeSetLogging to determine whether to put in change set" | methodNode selector method | methodNode _ self compilerClass new compile: code in: self notifying: requestor ifFail: failBlock. selector _ methodNode selector. selAndNodeBlock value: selector value: methodNode. self wantsChangeSetLogging ifTrue: [(methodDict includesKey: selector) ifTrue: [Smalltalk changes changeSelector: selector class: self] ifFalse: [Smalltalk changes addSelector: selector class: self]]. methodNode encoder requestor: requestor. "Why was this not preserved?" method _ methodNode generate: bytes. self addSelector: selector withMethod: method. ^ method! ! !ClassDescription methodsFor: 'compiling'! wantsChangeSetLogging "Answer whether code submitted for the receiver should be remembered by the changeSet mechanism. 7/12/96 sw" ^ true! ! !ClassDescription methodsFor: 'fileIn/Out' stamp: 'tk 12/29/97 13:11'! classComment: aString "Store the comment, aString or Text or RemoteString, associated with the class we are orgainzing. Empty string gets stored only if had a non-empty one before." | ptr header file oldCommentRemoteStr | (aString isKindOf: RemoteString) ifTrue: [^ organization classComment: aString]. oldCommentRemoteStr _ organization commentRemoteStr. (aString size = 0) & (oldCommentRemoteStr == nil) ifTrue: [^ organization classComment: nil]. "never had a class comment, no need to write empty string out" ptr _ oldCommentRemoteStr ifNil: [0] ifNotNil: [oldCommentRemoteStr sourcePointer]. SourceFiles ifNotNil: [(file _ SourceFiles at: 2) ifNotNil: [ file setToEnd; cr; nextPut: $!!. "directly" "Should be saying (file command: 'H3') for HTML, but ignoring it here" header _ String streamContents: [:strm | strm nextPutAll: self name; nextPutAll: ' commentStamp: '. Utilities changeStamp storeOn: strm. strm nextPutAll: ' prior: '; nextPutAll: ptr printString]. file nextChunkPut: header]]. organization classComment: (RemoteString newString: aString onFileNumber: 2). Smalltalk changes commentClass: self. ! ! !ClassDescription methodsFor: 'fileIn/Out' stamp: 'tk 12/13/97 14:20'! commentFollows "Answer a ClassCommentReader who will scan in the comment." ^ ClassCommentReader new setClass: self category: #Comment "False commentFollows inspect"! ! !ClassDescription methodsFor: 'fileIn/Out' stamp: 'tk 12/13/97 14:21'! commentStamp: changeStamp prior: indexAndOffset "Prior source link ignored when filing in." ^ ClassCommentReader new setClass: self category: #Comment changeStamp: changeStamp ! ! !ClassDescription methodsFor: 'fileIn/Out'! definition "Answer a String that defines the receiver." | aStream | aStream _ WriteStream on: (String new: 300). aStream nextPutAll: (superclass == nil ifTrue: ['nil'] ifFalse: [superclass name]) , self kindOfSubclass. self name storeOn: aStream. aStream cr; tab; nextPutAll: 'instanceVariableNames: '. aStream store: self instanceVariablesString. aStream cr; tab; nextPutAll: 'classVariableNames: '. aStream store: self classVariablesString. aStream cr; tab; nextPutAll: 'poolDictionaries: '. aStream store: self sharedPoolsString. aStream cr; tab; nextPutAll: 'category: '. (SystemOrganization categoryOfElement: self name) asString storeOn: aStream. ^aStream contents! ! !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 5/17/1998 10:40'! 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. true ifTrue: ["Overridden to preserve author stamps in sources file regardless" (self organization listAtCategoryNamed: aString) do: [:sel | self printMethodChunk: sel withPreamble: true on: aFileStream moveSource: moveSource toFile: fileIndex]. ^ self]. 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'! fileOutChangedMessages: aSet on: aFileStream "File a description of the messages of the receiver that have been changed (i.e., are entered into the argument, aSet) onto aFileStream." self fileOutChangedMessages: aSet on: aFileStream moveSource: false toFile: 0! ! !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'! fileOutOn: aFileStream "File a description of the receiver on aFileStream." self fileOutOn: aFileStream moveSource: false toFile: 0! ! !ClassDescription methodsFor: 'fileIn/Out' stamp: 'sw 1/15/98 23:38'! 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 forClass: self. 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'! kindOfSubclass "Answer a string that describes what kind of subclass the receiver is, i.e., variable, variable byte, variable word, or not variable." self isVariable ifTrue: [self isBits ifTrue: [self isBytes ifTrue: [^' variableByteSubclass: '] ifFalse: [^' variableWordSubclass: ']] ifFalse: [^' variableSubclass: ']] ifFalse: [^' subclass: ']! ! !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: 'tk 12/29/97 13:00'! 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'! methodsFor: aString priorSource: sourcePosition inFile: fileIndex "Prior source pointer ignored when filing in." ^ self methodsFor: aString! ! !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'! moveChangesTo: newFile "Used in the process of condensing changes, this message requests that the source code of all methods of the receiver that have been changed should be moved to newFile." | changes | self organization moveChangedCommentToFile: newFile numbered: 2. changes _ methodDict keys select: [:sel | (methodDict at: sel) fileIndex > 1]. self fileOutChangedMessages: changes on: newFile moveSource: true toFile: 2! ! !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: 'tk 12/15/97 15:01'! 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. sourceFile skipSeparators. "The following chunk may have ]style[" sourceFile peek == $] ifTrue: [ outStream cr; 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'! reformatAll "Reformat all methods in this class. Leaves old code accessible to version browsing" self selectorsDo: [:sel | self reformatMethodAt: sel]! ! !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: 'fileIn/Out'! reorganize "Record that the receiver is being reorganized and answer the receiver's organization." Smalltalk changes reorganizeClass: self. ^self organization! ! !ClassDescription methodsFor: 'private'! errorCategoryName self error: 'Category name must be a String'! ! !ClassDescription methodsFor: 'private' stamp: 'di 1/30/98 11:56'! 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 spaceUsed]! ! Object subclass: #ClassOrganizer instanceVariableNames: 'globalComment categoryArray categoryStops elementArray ' classVariableNames: 'Default NullCategory ' poolDictionaries: '' category: 'Kernel-Classes'! !ClassOrganizer commentStamp: 'di 5/22/1998 16:32' prior: 0! ClassOrganizer comment: 'I represent method categorization information for classes.'! !ClassOrganizer methodsFor: 'accessing'! categories "Answer an Array of categories (names)." (categoryArray size = 1 and: [categoryArray first = Default & (elementArray size = 0)]) ifTrue: [^Array with: NullCategory]. ^categoryArray! ! !ClassOrganizer methodsFor: 'accessing'! categories: anArray "Reorder my categories to be in order of the argument, anArray. If the resulting organization does not include all elements, then give an error." | newCategories newStops newElements catName list runningTotal | newCategories _ Array new: anArray size. newStops _ Array new: anArray size. newElements _ Array new: 0. runningTotal _ 0. 1 to: anArray size do: [:i | catName _ (anArray at: i) asSymbol. list _ self listAtCategoryNamed: catName. newElements _ newElements, list. newCategories at: i put: catName. newStops at: i put: (runningTotal _ runningTotal + list size)]. elementArray do: [:element | "check to be sure all elements are included" (newElements includes: element) ifFalse: [^self error: 'New categories must match old ones']]. "Everything is good, now update my three arrays." categoryArray _ newCategories. categoryStops _ newStops. elementArray _ newElements! ! !ClassOrganizer methodsFor: 'accessing'! categoryOfElement: element "Answer the category associated with the argument, element." | index | index _ self numberOfCategoryOfElement: element. index = 0 ifTrue: [^nil] ifFalse: [^categoryArray at: index]! ! !ClassOrganizer methodsFor: 'accessing' stamp: 'tk 9/30/97 11:00'! changeFromString: aString "Parse the argument, aString, and make this be the receiver's structure." | scanner oldElements newElements newCategories newStops currentStop anArray temp ii cc | 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. (cc _ categoryArray asSet) size = categoryArray size ifFalse: ["has duplicate element" temp _ categoryArray asOrderedCollection. temp removeAll: categoryArray asSet asOrderedCollection. temp do: [:dup | ii _ categoryArray indexOf: dup. [dup _ (dup,' #2') asSymbol. cc includes: dup] whileTrue. cc add: dup. categoryArray at: ii put: dup]]. categoryStops _ newStops. elementArray _ newElements. oldElements do: [:pair | self classify: pair last under: pair first].! ! !ClassOrganizer methodsFor: 'accessing' stamp: 'tk 12/12/97 13:32'! classComment "Answer the comment associated with the object that refers to the receiver." globalComment == nil ifTrue: [^'']. ^globalComment text! ! !ClassOrganizer methodsFor: 'accessing' stamp: 'tk 12/16/97 07:44'! classComment: aString "Store the comment, aString, associated with the object that refers to the receiver." (aString isKindOf: RemoteString) ifTrue: [globalComment _ aString] ifFalse: [aString size = 0 ifTrue: [globalComment _ nil] ifFalse: [ self error: 'use aClass classComment:'. globalComment _ RemoteString newString: aString onFileNumber: 2]] "Later add priorSource and date and initials?"! ! !ClassOrganizer methodsFor: 'accessing' stamp: 'tk 12/15/97 14:41'! commentRemoteStr ^ globalComment! ! !ClassOrganizer methodsFor: 'accessing'! hasNoComment "Answer whether the class classified by the receiver has a comment." ^globalComment == nil! ! !ClassOrganizer methodsFor: 'accessing'! listAtCategoryNamed: categoryName "Answer the array of elements associated with the name, categoryName." | i | i _ categoryArray indexOf: categoryName ifAbsent: [^Array new]. ^self listAtCategoryNumber: i! ! !ClassOrganizer methodsFor: 'accessing'! listAtCategoryNumber: anInteger "Answer the array of elements stored at the position indexed by anInteger." | firstIndex lastIndex | firstIndex _ (anInteger > 1 ifTrue: [categoryStops at: anInteger - 1] ifFalse: [0]) + 1. lastIndex _ categoryStops at: anInteger. ^elementArray copyFrom: firstIndex to: lastIndex! ! !ClassOrganizer methodsFor: 'accessing'! numberOfCategoryOfElement: element "Answer the index of the category with which the argument, element, is associated." | categoryIndex elementIndex | categoryIndex _ 1. elementIndex _ 0. [(elementIndex _ elementIndex + 1) <= elementArray size] whileTrue: ["point to correct category" [elementIndex > (categoryStops at: categoryIndex)] whileTrue: [categoryIndex _ categoryIndex + 1]. "see if this is element" element = (elementArray at: elementIndex) ifTrue: [^categoryIndex]]. ^0! ! !ClassOrganizer methodsFor: 'accessing'! removeElement: element "Remove the selector, element, from all categories." | categoryIndex elementIndex nextStop newElements | categoryIndex _ 1. elementIndex _ 0. nextStop _ 0. "nextStop keeps track of the stops in the new element array" newElements _ WriteStream on: (Array new: elementArray size). [(elementIndex _ elementIndex + 1) <= elementArray size] whileTrue: [[elementIndex > (categoryStops at: categoryIndex)] whileTrue: [categoryStops at: categoryIndex put: nextStop. categoryIndex _ categoryIndex + 1]. (elementArray at: elementIndex) = element ifFalse: [nextStop _ nextStop + 1. newElements nextPut: (elementArray at: elementIndex)]]. [categoryIndex <= categoryStops size] whileTrue: [categoryStops at: categoryIndex put: nextStop. categoryIndex _ categoryIndex + 1]. elementArray _ newElements contents! ! !ClassOrganizer methodsFor: 'accessing'! removeEmptyCategories "Remove empty categories." | categoryIndex currentStop keptCategories keptStops | keptCategories _ WriteStream on: (Array new: 16). keptStops _ WriteStream on: (Array new: 16). currentStop _ categoryIndex _ 0. [(categoryIndex _ categoryIndex + 1) <= categoryArray size] whileTrue: [(categoryStops at: categoryIndex) > currentStop ifTrue: [keptCategories nextPut: (categoryArray at: categoryIndex). keptStops nextPut: (currentStop _ categoryStops at: categoryIndex)]]. categoryArray _ keptCategories contents. categoryStops _ keptStops contents. categoryArray size = 0 ifTrue: [categoryArray _ Array with: Default. categoryStops _ Array with: 0] "ClassOrganizer allInstancesDo: [:co | co removeEmptyCategories]."! ! !ClassOrganizer methodsFor: 'compiler access' stamp: 'tk 5/18/1998 11:32'! classify: element under: heading "Store the argument, element, in the category named heading." | catName catIndex elemIndex realHeading | ((heading = NullCategory) or: [heading == nil]) 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: 'compiler access'! classifyAll: aCollection under: heading aCollection do: [:element | self classify: element under: heading]! ! !ClassOrganizer methodsFor: 'method dictionary'! addCategory: newCategory ^ self addCategory: newCategory before: nil ! ! !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] ! ! !ClassOrganizer methodsFor: 'method dictionary'! renameCategory: oldCatString toBe: newCatString "Rename a category. No action if new name already exists, or if old name does not exist." | index oldCategory newCategory | oldCategory _ oldCatString asSymbol. newCategory _ newCatString asSymbol. (categoryArray indexOf: newCategory) > 0 ifTrue: [^self]. "new name exists, so no action" (index _ categoryArray indexOf: oldCategory) = 0 ifTrue: [^self]. "old name not found, so no action" categoryArray at: index put: newCategory! ! !ClassOrganizer methodsFor: 'printing'! printOn: aStream "Refer to the comment in Object|printOn:." | elementIndex lastStop | elementIndex _ 1. lastStop _ 1. 1 to: categoryArray size do: [:i | aStream nextPut: $(. (categoryArray at: i) asString printOn: aStream. [elementIndex <= (categoryStops at: i)] whileTrue: [aStream space. (elementArray at: elementIndex) printOn: aStream. elementIndex _ elementIndex + 1]. aStream nextPut: $). aStream cr]! ! !ClassOrganizer methodsFor: 'fileIn/Out'! fileOutCommentOn: aFileStream moveSource: moveSource toFile: fileIndex "Copy the class comment to aFileStream. If moveSource is true (as in compressChanges or compressSources, then update globalComment to point to the new file." | fileComment | globalComment ifNotNil: [aFileStream cr. fileComment _ RemoteString newString: globalComment text onFileNumber: fileIndex toFile: aFileStream. moveSource ifTrue: [globalComment _ fileComment]]! ! !ClassOrganizer methodsFor: 'fileIn/Out'! moveChangedCommentToFile: aFileStream numbered: fileIndex "If the comment is in the changes file, then move it to a new file." (globalComment ~~ nil and: [globalComment sourceFileNumber > 1]) ifTrue: [self fileOutCommentOn: aFileStream moveSource: true toFile: fileIndex]! ! !ClassOrganizer methodsFor: 'fileIn/Out'! putCommentOnFile: aFileStream numbered: sourceIndex moveSource: moveSource forClass: aClass "Store the comment about the class onto file, aFileStream." | header | globalComment ifNotNil: [aFileStream cr; nextPut: $!!. header _ String streamContents: [:strm | strm nextPutAll: aClass name; nextPutAll: ' commentStamp: '. Utilities changeStamp storeOn: strm. strm nextPutAll: ' prior: '; nextPutAll: '0']. aFileStream nextChunkPut: header. aClass organization fileOutCommentOn: aFileStream moveSource: moveSource toFile: sourceIndex. aFileStream cr]! ! !ClassOrganizer methodsFor: 'fileIn/Out' stamp: 'di 1/13/98 16:57'! scanFrom: aStream "Reads in the organization from the next chunk on aStream. Categories or elements not found in the definition are not affected. New elements are ignored." self changeFromString: aStream nextChunk. aStream skipStyleChunk.! ! !ClassOrganizer methodsFor: 'private' stamp: 'tk 12/16/97 07:35'! setDefaultList: aSortedCollection self classComment: ''. categoryArray _ Array with: Default. categoryStops _ Array with: aSortedCollection size. elementArray _ aSortedCollection asArray! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ClassOrganizer class instanceVariableNames: ''! !ClassOrganizer class methodsFor: 'class initialization'! default ^ Default! ! !ClassOrganizer class methodsFor: 'class initialization'! initialize Default _ 'as yet unclassified' asSymbol. NullCategory _ 'no messages' asSymbol. "ClassOrganizer initialize"! ! !ClassOrganizer class methodsFor: 'class initialization'! nullCategory ^ NullCategory! ! !ClassOrganizer class methodsFor: 'instance creation'! defaultList: aSortedCollection "Answer an instance of me with initial elements from the argument, aSortedCollection." ^self new setDefaultList: aSortedCollection! ! !ClassOrganizer class methodsFor: 'documentation'! documentation "Instances consist of an Array of category names (categoryArray), each of which refers to an Array of elements (elementArray). This association is made through an Array of stop indices (categoryStops), each of which is the index in elementArray of the last element (if any) of the corresponding category. For example: categories _ Array with: 'firstCat' with: 'secondCat' with: 'thirdCat'. stops _ Array with: 1 with: 4 with: 4. elements _ Array with: #a with: #b with: #c with: #d. This means that category firstCat has only #a, secondCat has #b, #c, and #d, and thirdCat has no elements. This means that stops at: stops size must be the same as elements size." ! ! StringMorph subclass: #ClockMorph instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Demo'! !ClockMorph methodsFor: 'all' stamp: 'sw 2/9/98 01:23'! step super step. self contents: Time now printString.! ! !ClockMorph methodsFor: 'all'! stepTime "Answer the desired time between steps in milliseconds." ^ 1000! ! ServerAction subclass: #CodeServer instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'PluggableWebServer'! !CodeServer commentStamp: 'di 5/22/1998 16:32' prior: 0! Return the source code from Smalltalk, as web page text, or as a raw Squeak file chunk. URLs are of the form: machine:80/smtlk.Point|min; <-- NOTE: use ; instead of : machine:80/smtlk.{Class}|{selector} machine:80/chunk.{Class}|{selector} machine:80/smtlk.{Class}|class|{selector} machine:80/chunk.{Class}|class|{selector} machine:80/smtlk.{Class}|Definition machine:80/chunk.{Class}|Definition machine:80/smtlk.{Class}|Hierarchy machine:80/chunk.{Class}|Hierarchy machine:80/smtlk.{Class}|Comment machine:80/chunk.{Class}|Comment NOTE: use ; semicolon instead of : colon in selector names ! !CodeServer methodsFor: 'as yet unclassified' stamp: 'tk 5/7/1998 15:36'! chunk: request "Return Smalltalk source code as a chunk from the changes file. URL = machine:80/chunk.Point|min; included are: Point|at; Point|Comment Point|Hierarchy Point|Definition Point|class|x;y; Meant to be received by a Squeak client, not a browser. Reply not in HTML" | classAndMethod set strm chunk | classAndMethod _ request message atPin: 2. classAndMethod _ classAndMethod copyReplaceAll: '|' with: ' '. classAndMethod _ classAndMethod copyReplaceAll: ';' with: ':'. set _ LinkedMessageSet messageList: (Array with: classAndMethod). strm _ WriteStream on: (String new: 300). strm nextChunkPutWithStyle: (set selectedMessage). "String or text" chunk _ strm contents. request reply: 'content-length: ', chunk size printString, PWS crlfcrlf. request reply: chunk. ! ! !CodeServer methodsFor: 'as yet unclassified' stamp: 'tk 5/7/1998 15:35'! process: request "Return the source code from Smalltalk, as text or as a chunk. URLs are of this form. Each may have 'chunk' or 'smtlk' as the thing after the slash machine:80/smtlk.Point|min; machine:80/chunk.{Class}|{selector} machine:80/smtlk.{Class}|{selector} machine:80/smtlk.{Class}|class|{selector} machine:80/smtlk.{Class}|Definition machine:80/smtlk.{Class}|Hierarchy machine:80/smtlk.{Class}|Comment NOTE: use ; semicolon instead of : colon in selector names!!!!!!" | coreRef | coreRef _ (request message at: 1) asLowercase. request reply: PWS success; reply: PWS contentHTML. Transcript show: 'In process: ', request message printString; cr. coreRef = 'smtlk' ifTrue: [^ self smtlk: request]. coreRef = 'chunk' ifTrue: [^ self chunk: request]. request reply: ( 'HTTP/1.0 400 Bad Request', PWS crlfcrlf, 'expected smtlk.{Class}|{selector} or chunk.{Class}|{selector}'). "failure"! ! !CodeServer methodsFor: 'as yet unclassified' stamp: 'tk 5/7/1998 15:36'! smtlk: request "Return Smalltalk sourcecode in HTML. URL = machine:80/myswiki.smtlk.Point|min; included are: Point|min; Point|Comment Point|Hierarchy Point|Definition Point|class|x;y; NOTE: use ; instead of : in selector names!!!!!!" | classAndMethod set | classAndMethod _ request message atPin: 2. classAndMethod _ classAndMethod copyReplaceAll: '|' with: ' '. classAndMethod _ classAndMethod copyReplaceAll: ';' with: ':'. set _ LinkedMessageSet messageList: (Array with: classAndMethod). request reply: PWS crlf, (HTMLformatter evalEmbedded: (self fileContents: 'swiki',(ServerAction pathSeparator),'smtlk.html') with: set).! ! Object subclass: #Collection instanceVariableNames: '' classVariableNames: 'RandomForPicking ' poolDictionaries: '' category: 'Collections-Abstract'! !Collection commentStamp: 'di 5/22/1998 16:32' prior: 0! Collection comment: 'I am the abstract superclass of all classes that represent a group of elements.'! !Collection methodsFor: 'accessing'! size "Answer how many elements the receiver contains." | tally | tally _ 0. self do: [:each | tally _ tally + 1]. ^tally! ! !Collection methodsFor: 'testing'! includes: anObject "Answer whether anObject is one of the receiver's elements." self do: [:each | anObject = each ifTrue: [^true]]. ^false! ! !Collection methodsFor: 'testing'! includesAllOf: aCollection "Answer whether all the elements of aCollection are in the receiver." aCollection do: [:elem | (self includes: elem) ifFalse: [^ false]]. ^ true! ! !Collection methodsFor: 'testing'! includesAnyOf: aCollection "Answer whether any element of aCollection is one of the receiver's elements." aCollection do: [:elem | (self includes: elem) ifTrue: [^ true]]. ^ false! ! !Collection methodsFor: 'testing' stamp: 'sw 8/12/97 20:59'! includesSubstringAnywhere: testString "Answer whether the receiver includes, anywhere in its nested structure, a string that has testString as a substring" self do: [:element | (element isKindOf: String) ifTrue: [(element includesSubString: testString) ifTrue: [^ true]]. (element isKindOf: Collection) ifTrue: [(element includesSubstringAnywhere: testString) ifTrue: [^ true]]]. ^ false "#(first (second third) ((allSentMessages ('Elvis' includes:)))) includesSubstringAnywhere: 'lvi'"! ! !Collection methodsFor: 'testing'! isEmpty "Answer whether the receiver contains any elements." ^self size = 0! ! !Collection methodsFor: 'testing'! occurrencesOf: anObject "Answer how many of the receiver's elements are equal to anObject." | tally | tally _ 0. self do: [:each | anObject = each ifTrue: [tally _ tally + 1]]. ^tally! ! !Collection methodsFor: 'adding'! add: newObject "Include newObject as one of the receiver's elements. Answer newObject. ArrayedCollections cannot respond to this message." self subclassResponsibility! ! !Collection methodsFor: 'adding'! addAll: aCollection "Include all the elements of aCollection as the receiver's elements. Answer aCollection." aCollection do: [:each | self add: each]. ^aCollection! ! !Collection methodsFor: 'adding' stamp: 'tk 5/7/1998 13:00'! addIfNotPresent: anObject (self includes: anObject) ifFalse: [^ self add: anObject]! ! !Collection methodsFor: 'removing'! remove: oldObject "Remove oldObject as one of the receiver's elements. Answer oldObject unless no element is equal to oldObject, in which case, create an error notification." ^self remove: oldObject ifAbsent: [self errorNotFound]! ! !Collection methodsFor: 'removing'! remove: oldObject ifAbsent: anExceptionBlock "Remove oldObject as one of the receiver's elements. If several of the elements are equal to oldObject, only one is removed. If no element is equal to oldObject, answer the result of evaluating anExceptionBlock. Otherwise, answer the argument, oldObject. SequenceableCollections cannot respond to this message." self subclassResponsibility! ! !Collection methodsFor: 'removing'! removeAll: aCollection "Remove each element of aCollection from the receiver. If successful for each, answer aCollection. Otherwise create an error notification." aCollection do: [:each | self remove: each]. ^aCollection! ! !Collection methodsFor: 'removing'! removeAllFoundIn: aCollection "Remove each element of aCollection which is present in the receiver from the receiver" aCollection do: [:each | self remove: each ifAbsent: []]. ^aCollection! ! !Collection methodsFor: 'removing'! removeAllSuchThat: aBlock "Apply the condition to each element and remove it if the condition is true. Use a copy to enumerate collections whose order changes when an element is removed (Set)." | copy newCollection | newCollection _ self species new. copy _ self copy. copy do: [:element | (aBlock value: element) ifTrue: [ self remove: element. newCollection add: element]]. ^ newCollection! ! !Collection methodsFor: 'enumerating'! associationsDo: aBlock "Evaluate aBlock for each of the receiver's elements (key/value associations). If any non-association is within, the error is not caught now, but later, when a key or value message is sent to it." self do: aBlock! ! !Collection methodsFor: 'enumerating' stamp: 'jm 10/16/97 21:25'! average "Return the average of all my elements." ^ self sum asFloat / self size ! ! !Collection methodsFor: 'enumerating'! collect: aBlock "Evaluate aBlock with each of the receiver's elements as the argument. Collect the resulting values into a collection like the receiver. Answer the new collection." | newCollection | newCollection _ self species new. self do: [:each | newCollection add: (aBlock value: each)]. ^newCollection! ! !Collection methodsFor: 'enumerating'! collect: collectBlock thenSelect: selectBlock ^ (self collect: collectBlock) select: selectBlock! ! !Collection methodsFor: 'enumerating'! count: aBlock "Evaluate aBlock with each of the receiver's elements as the argument. Return the number that answered true." | sum | sum _ 0. self do: [:each | (aBlock value: each) ifTrue: [sum _ sum + 1]]. ^ sum! ! !Collection methodsFor: 'enumerating'! detect: aBlock "Evaluate aBlock with each of the receiver's elements as the argument. Answer the first element for which aBlock evaluates to true." ^self detect: aBlock ifNone: [self errorNotFound]! ! !Collection methodsFor: 'enumerating'! detect: aBlock ifNone: exceptionBlock "Evaluate aBlock with each of the receiver's elements as the argument. Answer the first element for which aBlock evaluates to true. If none evaluate to true, then evaluate the argument, exceptionBlock." self do: [:each | (aBlock value: each) ifTrue: [^each]]. ^exceptionBlock value! ! !Collection methodsFor: 'enumerating'! detectMax: aBlock "Evaluate aBlock with each of the receiver's elements as the argument. Answer the element for which aBlock evaluates to the highest magnitude. If collection empty, return nil. This method might also be called elect:." | maxElement maxValue val | self do: [:each | maxValue == nil ifFalse: [ (val _ aBlock value: each) > maxValue ifTrue: [ maxElement _ each. maxValue _ val]] ifTrue: ["first element" maxElement _ each. maxValue _ aBlock value: each]. "Note that there is no way to get the first element that works for all kinds of Collections. Must test every one."]. ^ maxElement! ! !Collection methodsFor: 'enumerating'! detectMin: aBlock "Evaluate aBlock with each of the receiver's elements as the argument. Answer the element for which aBlock evaluates to the lowest number. If collection empty, return nil." | minElement minValue val | self do: [:each | minValue == nil ifFalse: [ (val _ aBlock value: each) < minValue ifTrue: [ minElement _ each. minValue _ val]] ifTrue: ["first element" minElement _ each. minValue _ aBlock value: each]. "Note that there is no way to get the first element that works for all kinds of Collections. Must test every one."]. ^ minElement! ! !Collection methodsFor: 'enumerating'! detectSum: aBlock "Evaluate aBlock with each of the receiver's elements as the argument. Return the sum of the answers." | sum | sum _ 0. self do: [:each | sum _ (aBlock value: each) + sum]. ^ sum! ! !Collection methodsFor: 'enumerating'! do: aBlock "Evaluate aBlock with each of the receiver's elements as the argument." self subclassResponsibility! ! !Collection methodsFor: 'enumerating'! inject: thisValue into: binaryBlock "Accumulate a running value associated with evaluating the argument, binaryBlock, with the current value of the argument, thisValue, and the receiver as block arguments. For instance, to sum the numeric elements of a collection, aCollection inject: 0 into: [:subTotal :next | subTotal + next]." | nextValue | nextValue _ thisValue. self do: [:each | nextValue _ binaryBlock value: nextValue value: each]. ^nextValue! ! !Collection methodsFor: 'enumerating' stamp: 'jm 11/14/97 11:08'! max "Return the max of all my elements." | max | max _ nil. self do: [:each | (max == nil or: [each > max]) ifTrue: [max _ each]]. ^ max! ! !Collection methodsFor: 'enumerating'! reject: aBlock "Evaluate aBlock with each of the receiver's elements as the argument. Collect into a new collection like the receiver only those elements for which aBlock evaluates to false. Answer the new collection." ^self select: [:element | (aBlock value: element) == false]! ! !Collection methodsFor: 'enumerating'! select: aBlock "Evaluate aBlock with each of the receiver's elements as the argument. Collect into a new collection like the receiver, only those elements for which aBlock evaluates to true. Answer the new collection." | newCollection | newCollection _ self species new. self do: [:each | (aBlock value: each) ifTrue: [newCollection add: each]]. ^newCollection! ! !Collection methodsFor: 'enumerating'! select: selectBlock thenCollect: collectBlock ^ (self select: selectBlock) collect: collectBlock! ! !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: 'converting'! asBag "Answer a Bag whose elements are the elements of the receiver." | aBag | aBag _ Bag new. self do: [:each | aBag add: each]. ^aBag! ! !Collection methodsFor: 'converting'! asOrderedCollection "Answer an OrderedCollection whose elements are the elements of the receiver. The order in which elements are added depends on the order in which the receiver enumerates its elements. In the case of unordered collections, the ordering is not necessarily the same for multiple requests for the conversion." | anOrderedCollection | anOrderedCollection _ OrderedCollection new: self size. self do: [:each | anOrderedCollection addLast: each]. ^anOrderedCollection! ! !Collection methodsFor: 'converting'! asSet "Answer a Set whose elements are the unique elements of the receiver." | aSet | aSet _ Set new: self size. self do: [:each | aSet add: each]. ^aSet! ! !Collection methodsFor: 'converting'! asSortedArray "Return a copy of the receiver in sorted order, as an Array. 6/10/96 sw" ^ self asSortedCollection asArray! ! !Collection methodsFor: 'converting'! asSortedCollection "Answer a SortedCollection whose elements are the elements of the receiver. The sort order is the default less than or equal." | aSortedCollection | aSortedCollection _ SortedCollection new: self size. aSortedCollection addAll: self. ^aSortedCollection! ! !Collection methodsFor: 'converting'! asSortedCollection: aBlock "Answer a SortedCollection whose elements are the elements of the receiver. The sort order is defined by the argument, aBlock." | aSortedCollection | aSortedCollection _ SortedCollection new: self size. aSortedCollection sortBlock: aBlock. aSortedCollection addAll: self. ^aSortedCollection! ! !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: $)! ! !Collection methodsFor: 'printing'! storeOn: aStream "Refer to the comment in Object|storeOn:." | noneYet | aStream nextPutAll: '(('. aStream nextPutAll: self class name. aStream nextPutAll: ' new)'. noneYet _ true. self do: [:each | noneYet ifTrue: [noneYet _ false] ifFalse: [aStream nextPut: $;]. aStream nextPutAll: ' add: '. aStream store: each]. noneYet ifFalse: [aStream nextPutAll: '; yourself']. aStream nextPut: $)! ! !Collection methodsFor: 'private'! emptyCheck self isEmpty ifTrue: [self errorEmptyCollection]! ! !Collection methodsFor: 'private'! errorEmptyCollection self error: 'this collection is empty'! ! !Collection methodsFor: 'private'! errorNoMatch self error: 'collection sizes do not match'! ! !Collection methodsFor: 'private'! errorNotFound self error: 'Object is not in the collection.'! ! !Collection methodsFor: 'private'! errorNotKeyed self error: self class name, 's do not respond to keyed accessing messages.'! ! !Collection methodsFor: 'private'! fill: numElements fromStack: aContext "Fill me with numElements elements, popped in reverse order from the stack of aContext. Do not call directly: this is called indirectly by {1. 2. 3} constructs. Subclasses that support at:put: instead of add: should override this and call Contextclass>examples>tinyText... Messages: mixed: proportion with: aColor Answer this color mixed with the given color additively. The proportion, a number between 0.0 and 1.0, determines what what fraction of the receiver to use in the mix. + add two colors - subtract two colors * multiply the values of r, g, b by a number or an Array of factors. ((Color named: #white) * 0.3) gives a darkish gray. (aColor * #(0 0 0.9)) gives a color with slightly less blue. / divide a color by a factor or an array of three factors. errorForDepth: d How close the nearest color at this depth is to this abstract color. Sum of the squares of the RGB differences, square rooted and normalized to 1.0. Multiply by 100 to get percent. hue Returns the hue of the color. On a wheel from 0 to 360 with pure red at 0 and again at 360. saturation Returns the saturation of the color. 0.0 to 1.0 brightness Returns the brightness of the color. 0.0 to 1.0 name Look to see if this Color has a name. display Show a swatch of this color tracking the cursor. lightShades: thisMany An array of thisMany colors from white to the receiver. darkShades: thisMany An array of thisMany colors from black to the receiver. Array is of length num. mix: color2 shades: thisMany An array of thisMany colors from the receiver to color2. wheel: thisMany An array of thisMany colors around the color wheel starting and ending at the receiver. pixelValueForDepth: d Returns the bits that appear be in a Bitmap of this depth for this color. Represents the nearest available color at this depth. Normal users do not need to know which pixelValue is used for which color. Messages to Class Color. red: r green: g blue: b Return a color with the given r, g, and b components. r: g: b: Same as above, for fast typing. hue: h saturation: s brightness: b Create a color with the given hue, saturation, and brightness. pink blue red ... Many colors have messages that return an instance of Color. canUnderstand: #brown Returns true if #brown is a defined color. names An OrderedCollection of the names of the colors. named: #notAllThatGray put: aColor Add a new color to the list and create an access message and a class variable for it. fromUser Shows the palette of colors available at this display depth. Click anywhere to return the color you clicked on. hotColdShades: thisMany An array of thisMany colors showing temperature from blue to red to white hot. stdColorsForDepth: d An Array of colors available at this depth. For 16 bit and 32 bits, returns a ColorGenerator. It responds to at: with a Color for that index, simulating a very big Array. colorFromPixelValue: value depth: d Returns a Color whose bit pattern (inside a Bitmap) at this depth is the number specified. Normal users do not need to use this. (See also comments in these classes: Form, Bitmap, BitBlt, Pattern, MaskedForm.)'! !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'! hue "Return the hue of this color, an angle in the range [0.0..360.0]." | r g b max min span h | r _ self privateRed. g _ self privateGreen. b _ self privateBlue. max _ ((r max: g) max: b). min _ ((r min: g) min: b). span _ (max - min) asFloat. span = 0.0 ifTrue: [ ^ 0.0 ]. r = max ifTrue: [ h _ ((g - b) asFloat / span) * 60.0. ] ifFalse: [ g = max ifTrue: [ h _ 120.0 + (((b - r) asFloat / span) * 60.0). ] ifFalse: [ h _ 240.0 + (((r - g) asFloat / span) * 60.0). ]. ]. h < 0.0 ifTrue: [ h _ 360.0 + h ]. ^ h! ! !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' stamp: 'tk 10/21/97 11:24'! = aColor "Return true if the receiver equals the given color. This method handles TranslucentColors, too." aColor isColor ifFalse: [^ false]. aColor isOpaqueMask ifTrue: [^ false]. aColor isTransparent ifTrue: [^ false]. ^ aColor privateRGB = rgb and: [aColor privateAlpha = self privateAlpha] ! ! !Color methodsFor: 'equality'! hash ^ rgb! ! !Color methodsFor: 'queries' stamp: 'sw 4/25/1998 12:51'! basicType ^ #color! ! !Color methodsFor: 'queries'! isColor ^ true ! ! !Color methodsFor: 'queries'! isOpaqueMask ^ false ! ! !Color methodsFor: 'queries'! isTransparent ^ false ! ! !Color methodsFor: 'transformations' stamp: 'di 11/2/97 14:05'! * aNumber "Answer this color with its RGB multiplied by the given number. " "(Color brown * 2) display" ^ Color basicNew setPrivateRed: (self privateRed * aNumber) asInteger green: (self privateGreen * aNumber) asInteger blue: (self privateBlue * aNumber) asInteger ! ! !Color methodsFor: 'transformations' stamp: 'di 11/2/97 14:05'! + aColor "Answer this color mixed with the given color in an additive color space. " "(Color blue + Color green) display" ^ Color basicNew setPrivateRed: self privateRed + aColor privateRed green: self privateGreen + aColor privateGreen blue: self privateBlue + aColor privateBlue ! ! !Color methodsFor: 'transformations' stamp: 'di 11/2/97 14:05'! - aColor "Answer aColor is subtracted from the given color in an additive color space. " "(Color white - Color red) display" ^ Color basicNew setPrivateRed: self privateRed - aColor privateRed green: self privateGreen - aColor privateGreen blue: self privateBlue - aColor privateBlue ! ! !Color methodsFor: 'transformations' stamp: 'di 11/2/97 14:07'! / aNumber "Answer this color with its RGB divided by the given number. " "(Color red / 2) display" ^ Color basicNew setPrivateRed: (self privateRed / aNumber) asInteger green: (self privateGreen / aNumber) asInteger blue: (self privateBlue / aNumber) asInteger ! ! !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' stamp: 'di 5/15/1998 21:54'! dansDarker "Return a darker shade of the same color. An attempt to do better than the current darker method." ^ Color h: self hue s: self saturation v: (self brightness - 0.16 max: 0.0)! ! !Color methodsFor: 'transformations'! darker "Return a lighter shade of the same color. 1/6th towards white. 6/18/96 tk Should this be an absolute step, instead of relative?" ^ self mixed: 5/6 with: Color black! ! !Color methodsFor: 'transformations'! lighter "Return a lighter shade of the same color. 1/6th towards white. 6/18/96 tk Should this be an absolute step, instead of relative?" ^ self mixed: 5/6 with: Color white! ! !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: 'transformations' stamp: 'jm 9/22/97 15:11'! muchLighter ^ self mixed: 0.233 with: Color white ! ! !Color methodsFor: 'transformations' stamp: 'sw 4/23/1998 18:17'! veryMuchLighter ^ self mixed: 0.1165 with: Color white ! ! !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: 'sw 2/16/98 03:42'! colorForInsets ^ self! ! !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' stamp: 'jm 12/4/97 10:24'! name "Return this color's name, or nil if it has no name. Only returns a name if it exactly matches the named color." ColorNames do: [:name | (Color perform: name) = self ifTrue: [^ name]]. ^ nil ! ! !Color methodsFor: 'other' stamp: 'sw 9/17/97 17:27'! newTileMorphRepresentative ^ ColorTileMorph new! ! !Color methodsFor: 'other' stamp: 'jm 12/4/97 10:27'! rgbTriplet "Color fromUser rgbTriplet" ^ Array with: (self red roundTo: 0.01) with: (self green roundTo: 0.01) with: (self blue roundTo: 0.01) ! ! !Color methodsFor: 'conversions' stamp: 'di 11/3/97 08:40'! balancedPatternForDepth: depth "A generalization of bitPatternForDepth: as it exists. Generates a 2x2 stipple of color. The topLeft and bottomRight pixel are closest approx to this color" | pv1 pv2 mask1 mask2 pv3 c | depth == cachedDepth ifTrue: [^ cachedBitPattern]. (depth between: 4 and: 16) ifFalse: [^ self bitPatternForDepth: depth]. cachedDepth _ depth. pv1 _ self pixelValueForDepth: depth. " Subtract error due to pv1 to get pv2. pv2 _ (self - (err1 _ (Color colorFromPixelValue: pv1 depth: depth) - self)) pixelValueForDepth: depth. Subtract error due to 2 pv1's and pv2 to get pv3. pv3 _ (self - err1 - err1 - ((Color colorFromPixelValue: pv2 depth: depth) - self)) pixelValueForDepth: depth. " "Above two statements computed faster by the following..." pv2 _ (c _ self - ((Color colorFromPixelValue: pv1 depth: depth) - self)) pixelValueForDepth: depth. pv3 _ (c + (c - (Color colorFromPixelValue: pv2 depth: depth))) pixelValueForDepth: depth. "Return to a 2-word bitmap that encodes a 2x2 stipple of the given pixelValues." mask1 _ (#(- - - 16r01010101 - - - "replicates every other 4 bits" 16r00010001 - - - - - - - "replicates every other 8 bits" 16r00000001) at: depth). "replicates every other 16 bits" mask2 _ (#(- - - 16r10101010 - - - "replicates the other 4 bits" 16r01000100 - - - - - - - "replicates the other 8 bits" 16r00010000) at: depth). "replicates the other 16 bits" ^ Bitmap with: (mask1*pv1) + (mask2*pv2) with: (mask1*pv3) + (mask2*pv1)! ! !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 9/2/97 20:21'! dominantColor ^ self! ! !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' stamp: 'di 11/2/97 12:19'! setPrivateRed: r green: g blue: b "Initialize this color's r, g, and b components to the given values in the range [0..ComponentMax]. Encoded in a single variable as 3 integers in [0..1023]." rgb == nil ifFalse: [self attemptToMutateError]. rgb _ ((r min: ComponentMask max: 0) bitShift: RedShift) + ((g min: ComponentMask max: 0) bitShift: GreenShift) + (b min: ComponentMask max: 0). cachedDepth _ nil. cachedBitPattern _ nil. ! ! !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 instanceVariableNames: ''! !Color class methodsFor: 'instance creation' stamp: 'jm 12/1/97 20:43'! 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 greater depths, 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) | (d = 15) ifTrue: [ "five bits per component" 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)]]. d = 12 ifTrue: [ "four bits per component" r _ (p bitShift: -8) bitAnd: 16rF. g _ (p bitShift: -4) bitAnd: 16rF. b _ p bitAnd: 16rF. ^ Color r: r g: g b: b range: 15]. d = 9 ifTrue: [ "three bits per component" r _ (p bitShift: -6) bitAnd: 16r7. g _ (p bitShift: -3) bitAnd: 16r7. b _ p bitAnd: 16r7. ^ Color r: r g: g b: b range: 7]. self error: 'unknown pixel depth: ', d printString ! ! !Color class methodsFor: 'instance creation' stamp: 'sw 8/8/97 22:03'! fromRgbTriplet: list ^ self r: list first g: list second b: list last! ! !Color class methodsFor: 'instance creation' stamp: 'jm 12/4/97 13:05'! gray: brightness "Return a gray shade with the given brightness in the range [0.0..1.0]." ^ self basicNew setRed: brightness green: brightness blue: brightness ! ! !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' stamp: 'jm 12/4/97 13:04'! r: r g: g b: b "Return a color with the given r, g, and b components in the range [0.0..1.0]." ^ self basicNew setRed: r green: g blue: b ! ! !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'! black ^Black! ! !Color class methodsFor: 'named colors'! blue ^Blue! ! !Color class methodsFor: 'named colors'! brown ^Brown! ! !Color class methodsFor: 'named colors'! cyan ^Cyan! ! !Color class methodsFor: 'named colors'! darkGray ^DarkGray! ! !Color class methodsFor: 'named colors'! gray ^Gray! ! !Color class methodsFor: 'named colors'! green ^Green! ! !Color class methodsFor: 'named colors'! lightBlue ^LightBlue! ! !Color class methodsFor: 'named colors'! lightBrown ^LightBrown! ! !Color class methodsFor: 'named colors'! lightCyan ^LightCyan! ! !Color class methodsFor: 'named colors'! lightGray ^LightGray! ! !Color class methodsFor: 'named colors'! lightGreen ^LightGreen! ! !Color class methodsFor: 'named colors'! lightMagenta ^LightMagenta! ! !Color class methodsFor: 'named colors'! lightOrange ^LightOrange! ! !Color class methodsFor: 'named colors'! lightRed ^LightRed! ! !Color class methodsFor: 'named colors'! lightYellow ^LightYellow! ! !Color class methodsFor: 'named colors'! magenta ^Magenta! ! !Color class methodsFor: 'named colors'! opaqueMask ^OpaqueMask! ! !Color class methodsFor: 'named colors'! orange ^Orange! ! !Color class methodsFor: 'named colors'! red ^Red! ! !Color class methodsFor: 'named colors'! transparent ^Transparent! ! !Color class methodsFor: 'named colors'! veryDarkGray ^VeryDarkGray! ! !Color class methodsFor: 'named colors'! veryLightGray ^VeryLightGray! ! !Color class methodsFor: 'named colors'! veryVeryDarkGray ^VeryVeryDarkGray! ! !Color class methodsFor: 'named colors'! veryVeryLightGray ^VeryVeryLightGray! ! !Color class methodsFor: 'named colors'! white ^White! ! !Color class methodsFor: 'named colors'! yellow ^Yellow! ! !Color class methodsFor: 'colormaps' stamp: 'jm 11/12/97 19:16'! 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) and: [destDepth < 16]) ifTrue: [ "can use the same map from both 16-bits and 32-bits to a given lesser 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' stamp: 'jm 12/5/97 18:27'! 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 | 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" map _ self computeRGBColormapFor: destDepth bitsPerColor: 4]. "Note: zero is transparent except when source depth is one-bit deep" sourceDepth > 1 ifTrue: [map at: 1 put: 0]. ^ map ! ! !Color class methodsFor: 'colormaps' stamp: 'jm 12/4/97 15:25'! computeRGBColormapFor: destDepth bitsPerColor: bitsPerColor "Compute a colorMap for translating from 16-bit or 32-bit RGB color to the given depth, using the given number of of bits per color component." | mask map c | (#(3 4 5) includes: bitsPerColor) ifFalse: [self error: 'BitBlt only supports 3, 4, or 5 bits per color component']. 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 - (2 * bitsPerColor)) 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)]. map at: 1 put: (Color transparent pixelWordForDepth: destDepth). "zero always transparent" ^ map ! ! !Color class methodsFor: 'other'! colorNames "Return a collection of color names." ^ ColorNames! ! !Color class methodsFor: 'other'! indexedColors ^ IndexedColors! ! !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'! quickHighLight: depth "Quickly return a Bitblt-ready raw colorValue for highlighting areas. 6/22/96 tk" ^ HighLightBitmaps at: depth! ! !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" ! ! !Color class methodsFor: 'color from user' stamp: 'jm 12/5/97 18:35'! colorPaletteForDepth: depth extent: chartExtent "Display a palette of colors sorted horizontally by hue and vertically by lightness. Useful for eyeballing the color gamut of the display, or for choosing a color interactively." "Note: It is slow to build this palette, so it should be cached for quick access." "(Color colorPaletteForDepth: 16 extent: 190@60) display" | basicHue x y c startHue palette transHt vSteps transCaption grayWidth hSteps | palette _ Form extent: chartExtent depth: depth. transCaption _ "(DisplayText text: 'no color' asText textStyle: (TextConstants at: #ComicPlain)) form storeString" (Form extent: 34@9 depth: 1 fromArray: #(0 0 256 0 256 0 3808663859 2147483648 2491688266 2147483648 2491688266 0 2491688266 0 2466486578 0 0 0) offset: 0@0). transHt _ transCaption height. palette fillWhite: (0@0 extent: palette width@transHt). palette fillBlack: (0@transHt extent: palette width@1). transCaption displayOn: palette at: palette boundingBox topCenter - ((transCaption width // 2)@0). grayWidth _ 10. startHue _ 338.0. vSteps _ palette height - transHt // 2. hSteps _ palette width - grayWidth. x _ 0. startHue to: startHue + 360.0 by: 360.0/hSteps do: [:h | basicHue _ Color h: h asFloat s: 1.0 v: 1.0. y _ transHt+1. 0 to: vSteps do: [:n | c _ basicHue mixed: (n asFloat / vSteps asFloat) with: Color white. palette fill: (x@y extent: 1@1) fillColor: c. y _ y + 1]. 1 to: vSteps do: [:n | c _ Color black mixed: (n asFloat / vSteps asFloat) with: basicHue. palette fill: (x@y extent: 1@1) fillColor: c. y _ y + 1]. x _ x + 1]. y _ transHt + 1. 1 to: vSteps * 2 do: [:n | c _ Color black mixed: (n asFloat / (vSteps*2) asFloat) with: Color white. palette fill: (x@y extent: 10@1) fillColor: c. y _ y + 1]. ^ palette ! ! !Color class methodsFor: 'color from user' stamp: 'jm 12/4/97 10:32'! fromUser "Displays a color palette of colors, waits for a mouse click, and returns the selected color. Any pixel on the Display can be chosen, not just those in the color palette." "Note: Since the color chart is cached, you may need to do 'ColorChart _ nil' after changing the oldColorPaletteForDepth: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 oldColorPaletteForDepth: 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: 'color from user' stamp: 'jm 12/5/97 18:34'! oldColorPaletteForDepth: depth extent: paletteExtent "Returns a form of the given size showing a color palette for the given depth." "(Color oldColorPaletteForDepth: 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 ! ! Form subclass: #ColorForm instanceVariableNames: 'colors cachedDepth cachedColormap ' classVariableNames: '' poolDictionaries: '' category: 'Graphics-Display Objects'! !ColorForm commentStamp: 'di 5/22/1998 16:32' prior: 0! ColorForm is a normal Form plus a color map of up to 2^depth Colors. Typically, one reserves one entry in the color map for transparent. This allows 1, 3, 15, or 255 non-transparent colors in ColorForms of depths 1, 2, 4, and 8 bits per pixel. ColorForms don't support depths greater than 8 bits because that would require excessively large color maps with little real benefit, since 16-bit and 32-bit depths already support thousands and millions of colors. ColorForms have several uses: 1) Precise colors. You can have up to 256 true colors, instead being limited to the 8-bit color palette. 2) Easy transparency. Just store (Color transparent) at the desired position in the color map. 3) Cheap color remapping by changing the color map. A color map is an Array of up to 2^depth Color objects. A Bitmap colorMap is automatically computed and cached for rapid display. Note that if you change the color map, you must resubmit it via the colors: method to flush this cache. ColorForms can be a bit tricky. Note that: a) When you BitBlt from one ColorForm to another, you must remember to copy the color map of the source ColorForm to the destination ColorForm. b) A ColorForm's color map is an array of depth-independent Color objects. BitBlt requires a BitMap of actual pixel values, adjusted to the destination depth. These are different things!! ColorForms automatically maintain a cache of the BitBlt-style color map corresponding to the colors array for the last depth on which the ColorForm was displayed, so there should be little need for clients to work with BitBlt-style color maps. c) The default map for 8 bit depth has black in the first entry, not transparent. Say (cform colors at: 1 put: Color transparent). ! !ColorForm methodsFor: 'accessing' stamp: 'jm 11/14/97 17:39'! colors "Return my color palette." self ensureColorArrayExists. ^ 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' stamp: 'jm 11/14/97 17:25'! colorAt: aPoint "Return the color of the pixel at aPoint." ^ self colors at: (self pixelValueAt: aPoint) + 1 ! ! !ColorForm methodsFor: 'pixel accessing' stamp: 'jm 11/14/97 17:25'! 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 _ self 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' stamp: 'tk 10/21/97 12:27'! isTransparentAt: aPoint "Return true if the receiver is transparent at the given point." ^ (self colorAt: aPoint) isTransparent ! ! !ColorForm methodsFor: 'pixel accessing' stamp: 'jm 11/16/97 10:43'! pixelValueAt: aPoint "Return the raw pixel value at the given point. Typical clients use colorAt: to get a Color." "Details: To get the raw pixel value, be sure the peeker's colorMap is nil." ^ (BitBlt bitPeekerFromForm: self) colorMap: nil; pixelAt: aPoint ! ! !ColorForm methodsFor: 'color manipulation'! 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: 'color manipulation' stamp: 'jm 4/18/98 20:34'! colorsUsed "Return a list of the colors actually used by this ColorForm." | myColor list | myColor _ self colors. list _ OrderedCollection new. self tallyPixelValues doWithIndex: [:count :i | count > 0 ifTrue: [list add: (myColor at: i)]]. ^ list asArray ! ! !ColorForm methodsFor: 'color manipulation' stamp: 'jm 11/16/97 11:18'! ensureTransparentColor "Ensure that the receiver (a) includes Color transparent in its color map and (b) that the entry for Color transparent is the first entry in its color map." | i | self error: 'not yet implemented'. (colors includes: Color transparent) ifTrue: [ (colors indexOf: Color transparent) = 1 ifTrue: [^ self]. "shift the entry for color transparent"] ifFalse: [ i _ self unusedColormapEntry. i = 0 ifTrue: [self error: 'no color map entry is available']. colors at: i put: Color transparent. "shift the entry for color transparent"]. ! ! !ColorForm methodsFor: 'color manipulation' stamp: 'jm 3/27/98 13:24'! readFrom: aBinaryStream self error: 'not yet implemented'. ! ! !ColorForm methodsFor: 'color manipulation' stamp: 'jm 11/16/97 09:08'! replaceColor: oldColor with: newColor "Replace all occurances of the given color with the given new color in my color map." self ensureColorArrayExists. 1 to: colors size do: [:i | (colors at: i) = oldColor ifTrue: [colors at: i put: newColor]]. self clearColormapCache. ! ! !ColorForm methodsFor: 'color manipulation' stamp: 'tk 3/2/98 15:42'! replaceColorAt: aPoint with: newColor "Replace a color map entry with newColor. The entry replaced is the one used by aPoint. If there are are two entries in the colorMap for the oldColor, just replace ONE!!!! There are often two whites or two blacks, and this is what you want, when replacing one." | oldIndex | self ensureColorArrayExists. oldIndex _ self pixelValueAt: aPoint. colors at: oldIndex+1 put: newColor. self clearColormapCache. ! ! !ColorForm methodsFor: 'color manipulation' stamp: 'tk 3/2/98 11:26'! transparentAllPixelsLike: aPoint "Make all occurances of the given pixel value transparent. Very useful when two entries in the colorMap have the same value. This only changes ONE." self replaceColorAt: aPoint with: Color transparent. ! ! !ColorForm methodsFor: 'color manipulation' stamp: 'tk 3/2/98 11:27'! transparentColor: aColor "Make all occurances of the given color transparent. Note: for colors like black and white, which have two entries in the colorMap, this changes BOTH of them. Not always what you want." self replaceColor: aColor with: Color transparent. ! ! !ColorForm methodsFor: 'color manipulation'! 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 methodsFor: 'copying' stamp: 'tk 2/25/98 11:20'! copy: aRect "Return a new ColorForm containing the portion of the receiver delineated by aRect." | newForm | newForm _ self class extent: aRect extent depth: depth. ((BitBlt destForm: newForm sourceForm: self fillColor: nil combinationRule: Form over destOrigin: 0@0 sourceOrigin: aRect origin extent: aRect extent clipRect: newForm boundingBox) colorMap: nil) copyBits. colors ifNotNil: [newForm colors: colors copy]. ^ newForm ! ! !ColorForm methodsFor: 'copying' stamp: 'jm 2/27/98 09:38'! deepCopy ^ self shallowCopy bits: bits copy; offset: offset copy; colors: colors ! ! !ColorForm methodsFor: 'private' stamp: 'jm 11/16/97 09:07'! clearColormapCache cachedDepth _ nil. cachedColormap _ nil. ! ! !ColorForm methodsFor: 'private' stamp: 'jm 11/16/97 09:12'! depth: bitsPerPixel bitsPerPixel > 8 ifTrue: [self error: 'ColorForms only support depths up to 8 bits']. super depth: bitsPerPixel. ! ! !ColorForm methodsFor: 'private' stamp: 'jm 11/16/97 08:37'! ensureColorArrayExists "Return my color palette." colors ifNil: [ depth > 8 ifTrue: [^ self error: 'ColorForms only support depths up to 8 bits']. self colors: (Color indexedColors copyFrom: 1 to: (1 bitShift: depth))]. ! ! !ColorForm methodsFor: 'private' stamp: 'jm 11/16/97 08:37'! setExtent: extent depth: bitsPerPixel "Create a virtual bit map with the given extent and bitsPerPixel." bitsPerPixel > 8 ifTrue: [self error: 'ColorForms only support depths up to 8 bits']. super setExtent: extent depth: bitsPerPixel. ! ! !ColorForm methodsFor: 'private' stamp: 'jm 2/24/98 18:53'! unusedColormapEntry "Return the index of an unused color map entry, or zero if there isn't one." | tallies | tallies _ self tallyPixelValues. 1 to: tallies size do: [:i | (tallies at: i) = 0 ifTrue: [^ i]]. ^ 0 ! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ColorForm class instanceVariableNames: ''! !ColorForm class methodsFor: 'all' stamp: 'jm 11/16/97 09:17'! mappingWhiteToTransparentFrom: 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 ! ! SketchMorph subclass: #ColorPickerMorph instanceVariableNames: 'selectedColor sourceHand deleteOnMouseUp updateContinuously selector target ' classVariableNames: 'ColorChart FeedbackBox TransparentBox ' poolDictionaries: '' category: 'Morphic-Widgets'! !ColorPickerMorph methodsFor: 'initialization' stamp: 'jm 11/4/97 07:46'! 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 11/4/97 07:15'! deleteOnMouseUp ^ deleteOnMouseUp ! ! !ColorPickerMorph methodsFor: 'accessing' stamp: 'jm 11/4/97 07:15'! deleteOnMouseUp: aBoolean deleteOnMouseUp _ aBoolean. ! ! !ColorPickerMorph methodsFor: 'accessing' stamp: 'jm 11/4/97 07:15'! selectedColor ^ selectedColor ! ! !ColorPickerMorph methodsFor: 'accessing' stamp: 'jm 11/4/97 07:15'! selector ^ selector ! ! !ColorPickerMorph methodsFor: 'accessing' stamp: 'jm 11/4/97 07:15'! selector: aSymbol selector _ aSymbol. ! ! !ColorPickerMorph methodsFor: 'accessing' stamp: 'jm 11/4/97 07:15'! sourceHand ^ sourceHand ! ! !ColorPickerMorph methodsFor: 'accessing' stamp: 'jm 11/4/97 07:15'! sourceHand: aHand sourceHand _ aHand. ! ! !ColorPickerMorph methodsFor: 'accessing' stamp: 'jm 11/4/97 07:15'! target ^ target ! ! !ColorPickerMorph methodsFor: 'accessing' stamp: 'jm 11/4/97 07:15'! target: anObject target _ anObject. ! ! !ColorPickerMorph methodsFor: 'accessing' stamp: 'jm 11/4/97 07:46'! updateContinuously ^ updateContinuously ! ! !ColorPickerMorph methodsFor: 'accessing' stamp: 'jm 11/4/97 07:46'! updateContinuously: aBoolean updateContinuously _ aBoolean. ! ! !ColorPickerMorph methodsFor: 'event handling' stamp: 'jm 11/4/97 07:15'! handlesMouseDown: evt ^ true ! ! !ColorPickerMorph methodsFor: 'event handling' stamp: 'jm 11/4/97 07:15'! mouseDown: evt sourceHand _ evt hand. self startStepping. ! ! !ColorPickerMorph methodsFor: 'event handling' stamp: 'jm 11/4/97 07:46'! mouseUp: evt self stopStepping. sourceHand _ nil. deleteOnMouseUp ifTrue: [self delete]. self updateTargetColor. ! ! !ColorPickerMorph methodsFor: 'stepping' stamp: 'jm 11/4/97 07:15'! step sourceHand ifNotNil: [self pickColorAt: sourceHand position]. ! ! !ColorPickerMorph methodsFor: 'stepping' stamp: 'jm 11/4/97 07:15'! stepTime ^ 50 ! ! !ColorPickerMorph methodsFor: 'private' stamp: 'jm 11/4/97 07:15'! 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 11/4/97 07:46'! 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 11/4/97 07:46'! 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 11/4/97 07:46'! 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 11/4/97 07:46'! toggleDeleteOnMouseUp deleteOnMouseUp _ deleteOnMouseUp not. ! ! !ColorPickerMorph methodsFor: 'menu' stamp: 'jm 11/4/97 07:46'! toggleUpdateContinuously updateContinuously _ updateContinuously not. ! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ColorPickerMorph class instanceVariableNames: ''! !ColorPickerMorph class methodsFor: 'all' stamp: 'jm 5/13/1998 14:44'! initialize "ColorPickerMorph initialize" ColorChart _ Color colorPaletteForDepth: 16 extent: 190@60. TransparentBox _ ColorChart boundingBox withHeight: 10. FeedbackBox _ (ColorChart width - 20)@0 extent: 20@9. ! ! ColorTileMorph subclass: #ColorSeerTile instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Scripting-Tiles'! !ColorSeerTile methodsFor: 'as yet unclassified' stamp: 'sw 5/2/1998 15:00'! initialize | m1 m2 desiredW | super initialize. self removeAllMorphs. "get rid of the parts of a regular Color tile" type _ #operator. operatorOrExpression _ #color:sees:. m1 _ StringMorph new initWithContents: 'color sees' font: ScriptingSystem fontForTiles. m2 _ Morph new extent: 12@8; color: (Color r: 0.8 g: 0 b: 0). desiredW _ m1 width + 6. self extent: (desiredW max: self class defaultW) @ self class defaultH. m1 position: (bounds center x - (m1 width // 2)) @ (bounds top + 5). m2 position: (bounds center x - (m2 width // 2) + 3) @ (bounds top + 8). self addMorph: m1; addMorphFront: m2. colorSwatch _ m2. ! ! !ColorSeerTile methodsFor: 'as yet unclassified' stamp: 'tk 12/2/97 13:12'! storeCodeOn: aStream "We have a hidden arg. Give 'keyword1: arg1 keyword2:' as my operator string" | parts | parts _ operatorOrExpression keywords. "color:sees:" ^ aStream nextPutAll: (parts at: 1); space; nextPutAll: colorSwatch color printString; space; nextPutAll: (parts at: 2). ! ! !ColorSeerTile methodsFor: 'as yet unclassified' stamp: 'tk 12/3/97 09:51'! updateLiteralLabel "Do nothing"! ! StandardSystemView subclass: #ColorSystemView instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Interface-Support'! !ColorSystemView methodsFor: 'as yet unclassified'! cacheBitsAsTwoTone ^ false! ! !ColorSystemView methodsFor: 'as yet unclassified' stamp: 'di 2/26/98 08:58'! displayDeEmphasized "Display this view with emphasis off. If windowBits is not nil, then simply BLT if possible." bitsValid ifTrue: [self lock. windowBits displayAt: self windowOrigin] ifFalse: [super displayDeEmphasized] ! ! TileMorph subclass: #ColorTileMorph instanceVariableNames: 'colorSwatch ' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Scripting-Tiles'! !ColorTileMorph methodsFor: 'initialization'! initialize super initialize. type _ #literal. self addColorSwatch. ! ! !ColorTileMorph methodsFor: 'events'! handlesMouseDown: evt (colorSwatch containsPoint: evt cursorPoint) ifTrue: [^ true] ifFalse: [^ super handlesMouseDown: evt]. ! ! !ColorTileMorph methodsFor: 'events'! mouseDown: evt (colorSwatch containsPoint: evt cursorPoint) ifFalse: [super mouseDown: evt]. ! ! !ColorTileMorph methodsFor: 'events' stamp: 'jm 5/13/1998 14:47'! mouseUp: evt evt hand changeColorTarget: colorSwatch selector: #color:. self acceptNewLiteral. ! ! !ColorTileMorph methodsFor: 'other' stamp: 'tk 9/17/97 18:13'! addColorSwatch | m1 m2 desiredW | m1 _ StringMorph new contents: 'color'. m2 _ Morph new extent: 12@8; color: (Color r: 0.8 g: 0 b: 0). desiredW _ m1 width + 6. self extent: (desiredW max: self class defaultW) @ self class defaultH. m1 position: (bounds center x - (m1 width // 2)) @ (bounds top + 1). m2 position: (bounds center x - (m2 width // 2)) @ (m1 bottom - 1). self addMorph: m1; addMorph: m2. colorSwatch _ m2. ! ! !ColorTileMorph methodsFor: 'other' stamp: 'jm 6/25/97 17:38'! resultType ^ #color! ! !ColorTileMorph methodsFor: 'other'! storeCodeOn: aStream aStream nextPutAll: colorSwatch color printString. ! ! AlignmentMorph subclass: #CommandTilesMorph instanceVariableNames: 'morph playerScripted ' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Scripting-Tiles'! !CommandTilesMorph commentStamp: 'di 5/22/1998 16:32' prior: 0! CommandTilesMorph comment: 'An entire Smalltalk statement in tiles. A line of code.'! !CommandTilesMorph methodsFor: 'all'! initialize super initialize. centering _ #center. hResizing _ #shrinkWrap. borderWidth _ 0. inset _ 0. self extent: 5@5. "will grow to fit" ! ! !CommandTilesMorph methodsFor: 'all' stamp: 'tk 10/1/97 18:25'! isTileLike "Can be dropped into a script" ^ true! ! !CommandTilesMorph methodsFor: 'all' stamp: 'sw 1/29/98 18:32'! setMorph: aMorph playerScripted _ aMorph playerScripted ! ! !CommandTilesMorph methodsFor: 'all'! tileRows ^ Array with: self submorphs! ! Object subclass: #Comment instanceVariableNames: '' classVariableNames: 'CommentsTable ' poolDictionaries: '' category: 'PluggableWebServer'! !Comment commentStamp: 'di 5/22/1998 16:33' prior: 0! A Comment space is like a bulletin board. It is a web page with a list statements from many different people. At the bottom there is a form for you to add your own statement. Anyone may start a new comment page, just by asking for a page with a new key, and there can be any number of pages. The default Swiki has a page called 'pws' already created. The administrator must take special action to save the accumulated comments (Comment saveTo: 'aFileName'). Comments are not automatically stored on the disk like regular Swiki pages are. So, for the moment, it is likely that Comments will get lost when the server is restarted. URLs are of the form machine:80/Comment.{commentKey} machine:80/Comment.{commentKey}.{number} machine:80/Comment.{commentKey}.note -- Does this really work??? -tk machine:80/Comment.{commentKey}.gif! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Comment class instanceVariableNames: ''! !Comment class methodsFor: 'initialization' stamp: 'mjg 11/10/97 10:44'! initialize CommentsTable := Dictionary new.! ! !Comment class methodsFor: 'initialization' stamp: 'mjg 11/24/97 15:20'! readIn: filename |f| f _ ReferenceStream fileNamed: filename. CommentsTable _ f next. f close.! ! !Comment class methodsFor: 'initialization' stamp: 'mjg 11/24/97 15:20'! saveTo: filename |f| f _ ReferenceStream fileNamed: filename. f nextPut: CommentsTable. f close.! ! !Comment class methodsFor: 'initialization' stamp: 'mjg 11/17/97 14:52'! setUpExample | newDiscussion | newDiscussion _ Discussion new. newDiscussion title: 'pws'. newDiscussion description: 'Here is a space for talking about the Pluggable Web Server.'. CommentsTable at: 'pws' put: newDiscussion. ! ! !Comment class methodsFor: 'URL processing' stamp: 'mjg 11/10/97 11:18'! comments ^CommentsTable! ! !Comment class methodsFor: 'URL processing' stamp: 'mjg 12/19/97 13:44'! createComment: request "Create a new comment from a Web request" | newNote newMap | request fields isNil ifTrue: [self error: 'No request to create a comment from!!']. newNote := Note new. newMap := URLmap new. newNote author: (request fields at: 'author' ifAbsent: ['Anonymous']). newNote title: (request fields at: 'title' ifAbsent: ['Untitled']). newNote text: (HTMLformatter swikify: (request fields at: 'text' ifAbsent: ['Nothing much to say']) linkhandler: [:phrase | newMap linkFor: phrase from: (request peerName) storingTo: OrderedCollection new]). newNote timestamp: (Date today printString),' ',(Time now printString). newNote children: OrderedCollection new. "For later addition of threaded comments" ^newNote ! ! !Comment class methodsFor: 'URL processing' stamp: 'tk 5/6/1998 18:48'! process: request "URLs are of the form Comment.commentKey or Comment.commentKey.note of Comment.commentKey.gif. If commentKey is accessed but not created, create an empty one. If note is accessed, display it." | commentKey noteIndex newNote | (request message size > 1) ifTrue: [commentKey _ request message at: 2] ifFalse: [commentKey _ 'comment' "Just a default comment space"]. (CommentsTable includesKey: commentKey) ifFalse: [CommentsTable at: commentKey put: Discussion new. (CommentsTable at: commentKey) title: commentKey. (CommentsTable at: commentKey) description: 'Discussion on ' , commentKey]. request fields isNil ifFalse: ["Are there input fields?" newNote _ self createComment: request. newNote parent: commentKey. (CommentsTable at: commentKey) addNote: newNote. newNote url: ('Comment.',commentKey,'.', (CommentsTable at: commentKey) notes size printString)]. request message size > 2 ifTrue: ["There's a note reference or a request for a status image" noteIndex _ request message at: 3. noteIndex asUppercase = 'GIF' ifTrue: [ request reply: (PWS success),(PWS content: 'image/gif'). request reply: (HTMLformatter textToGIF: (CommentsTable at: commentKey) status)] ifFalse: [request reply: (self showNote: ((CommentsTable at: commentKey) at: noteIndex asNumber))]] ifFalse: [request reply: (self showComment: (CommentsTable at: commentKey))]! ! !Comment class methodsFor: 'URL processing' stamp: 'mjg 11/18/97 10:28'! showComment: aComment | fileName | fileName := (ServerAction serverDirectory) , 'ShowComment.html'. ^HTMLformatter evalEmbedded: (FileStream fileNamed: fileName) contentsOfEntireFile with: aComment. ! ! !Comment class methodsFor: 'URL processing' stamp: 'mjg 11/18/97 10:28'! showNote: aNote | fileName | fileName := (ServerAction serverDirectory) , 'ShowNote.html'. ^HTMLformatter evalEmbedded: (FileStream fileNamed: fileName) contentsOfEntireFile with: aNote. ! ! ByteArray variableByteSubclass: #CompiledMethod instanceVariableNames: '' classVariableNames: 'LargeFrame SmallFrame SpecialConstants TempNameCache ' poolDictionaries: '' category: 'Kernel-Methods'! !CompiledMethod commentStamp: 'di 5/22/1998 16:33' prior: 0! CompiledMethod comment: 'I represent a method suitable for interpretation by the virtual machine. My instances have pointer fields, including a header and some literals, followed by non-pointer fields comprising the byte encoded instructions for the method. The header encodes the number of arguments, the number of literals, and the amount of temporary space needed (for context allocation). An extra three bytes are added after the executable code. These contain an external file address to the source code for the method.'! !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: 'initialize-release'! needsFrameSize: newFrameSize "Set the largeFrameBit to accomodate the newFrameSize. NOTE: I think the >= below is overly cautious. Recompile the system with just > some day - DI 2/26/96" | largeFrameBit header | largeFrameBit _ 16r20000. (self numTemps + newFrameSize) >= LargeFrame ifTrue: [^self error: 'Cannot compile--stack including temps is too deep']. header _ self objectAt: 1. (header bitAnd: largeFrameBit) ~= 0 ifTrue: [header _ header - largeFrameBit]. self objectAt: 1 put: header + ((self numTemps + newFrameSize) >= SmallFrame ifTrue: [largeFrameBit] ifFalse: [0])! ! !CompiledMethod methodsFor: 'accessing'! bePrimitive: primitiveIndex "Used in conjunction with simulator only" self objectAt: 1 put: ((self objectAt: 1) bitAnd: 16rFFFFFE00) + primitiveIndex! ! !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'! frameSize "Answer the size of temporary frame needed to run the receiver." (self header noMask: 16r20000) ifTrue: [^ SmallFrame] ifFalse: [^ LargeFrame]! ! !CompiledMethod methodsFor: 'accessing'! initialPC "Answer the program counter for the receiver's first bytecode." ^ (self numLiterals + 1) * 4 + 1! ! !CompiledMethod methodsFor: 'accessing'! numArgs "Answer the number of arguments the receiver takes." ^ (self header bitShift: -24) bitAnd: 16r1F! ! !CompiledMethod methodsFor: 'accessing'! numLiterals "Answer the number of literals used by the receiver." ^ (self header bitShift: -9) bitAnd: 16rFF! ! !CompiledMethod methodsFor: 'accessing'! numTemps "Answer the number of temporary variables used by the receiver." ^ (self header bitShift: -18) bitAnd: 16r3F! ! !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: 'accessing'! returnField "Answer the index of the instance variable returned by a quick return method." | prim | prim _ self primitive. prim < 264 ifTrue: [self error: 'only meaningful for quick-return'] ifFalse: [^ prim - 264]! ! !CompiledMethod methodsFor: 'accessing' stamp: 'sw 8/15/97 16:17'! selector "This is slow, so don't call it frivolously" ^ self who last! ! !CompiledMethod methodsFor: 'comparing'! = method "Answer whether the receiver implements the same code as the argument, method." (method isKindOf: CompiledMethod) ifFalse: [^false]. self size = method size ifFalse: [^false]. self header = method header ifFalse: [^false]. self literals = method literals ifFalse: [^false]. self initialPC to: self endPC do: [:i | (self at: i) = (method at: i) ifFalse: [^false]]. ^true! ! !CompiledMethod methodsFor: 'testing'! isQuick "Answer whether the receiver is a quick return (of self or of an instance variable)." ^ self primitive >= 256! ! !CompiledMethod methodsFor: 'testing'! isReturnField "Answer whether the receiver is a quick return of an instance variable." ^ self primitive >= 264! ! !CompiledMethod methodsFor: 'testing'! isReturnSelf "Answer whether the receiver is a quick return of self." ^ self primitive = 256! ! !CompiledMethod methodsFor: 'testing'! isReturnSpecial "Answer whether the receiver is a quick return of self or constant." ^ self primitive between: 256 and: 263! ! !CompiledMethod methodsFor: 'printing'! decompileString | clAndSel cl sel | clAndSel _ self who. cl _ clAndSel first. sel _ clAndSel last. ^ (cl decompilerClass new decompile: sel in: cl method: self) decompileString! ! !CompiledMethod methodsFor: 'printing'! printOn: aStream "Overrides method inherited from the byte arrayed collection." aStream nextPutAll: 'a CompiledMethod'! ! !CompiledMethod methodsFor: 'printing'! storeLiteralsOn: aStream forClass: aBehavior "Store the literals referenced by the receiver on aStream, each terminated by a space." | literal | 2 to: self numLiterals + 1 do: [:index | aBehavior storeLiteral: (self objectAt: index) on: aStream. aStream space]! ! !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'! symbolic "Answer a String that contains a list of all the byte codes in a method with a short description of each." | aStream | self isQuick ifTrue: [self isReturnSpecial ifTrue: [^ 'Quick return ' , (#('self' 'true' 'false' 'nil' '-1' '0' '1' '2') at: self primitive - 255)]. ^ 'Quick return field ' , self returnField printString , ' (0-based)']. aStream _ WriteStream on: (String new: 1000). self primitive > 0 ifTrue: [aStream nextPutAll: '. aStream cr]. (InstructionPrinter on: self) printInstructionsOn: aStream. ^aStream contents! ! !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: 'literals' stamp: 'di 10/17/97 22:38'! hasLiteral: literal "Answer whether the receiver references the argument, literal." "a fast primitive operation equivalent to..." 2 to: self numLiterals + 1 do: [:index | literal == (self objectAt: index) ifTrue: [^ true]]. ^ false! ! !CompiledMethod methodsFor: 'literals' stamp: 'di 8/15/97 09:51'! hasLiteralSuchThat: litBlock "Answer true if litBlock returns true for any literal in this method, even if imbedded in array structure." | lit | 2 to: self numLiterals + 1 do: [:index | lit _ self objectAt: index. (litBlock value: lit) ifTrue: [^ true]. (lit class == Array and: [lit hasLiteralSuchThat: litBlock]) ifTrue: [^ true]]. ^false! ! !CompiledMethod methodsFor: 'literals'! header "Answer the word containing the information about the form of the receiver and the form of the context needed to run the receiver." ^self objectAt: 1! ! !CompiledMethod methodsFor: 'literals'! literalAt: index "Answer the literal indexed by the argument." ^self objectAt: index + 1! ! !CompiledMethod methodsFor: 'literals'! literalAt: index put: value "Replace the literal indexed by the first argument with the second argument. Answer the second argument." ^self objectAt: index + 1 put: value! ! !CompiledMethod methodsFor: 'literals'! literals "Answer an Array of the literals referenced by the receiver." | literals numberLiterals | literals _ Array new: (numberLiterals _ self numLiterals). 1 to: numberLiterals do: [:index | literals at: index put: (self objectAt: index + 1)]. ^literals! ! !CompiledMethod methodsFor: 'literals'! literalStrings | lits litStrs | lits _ self literals. litStrs _ OrderedCollection new: lits size * 3. self literals do: [:lit | (lit isMemberOf: Association) ifTrue: [litStrs addLast: lit key] ifFalse: [(lit isMemberOf: Symbol) ifTrue: [litStrs addAll: lit keywords] ifFalse: [litStrs addLast: lit printString]]]. ^ litStrs! ! !CompiledMethod methodsFor: 'literals'! objectAt: index "Primitive. Answer the method header (if index=1) or a literal (if index >1) from the receiver. Essential. See Object documentation whatIsAPrimitive." self primitiveFailed! ! !CompiledMethod methodsFor: 'literals'! objectAt: index put: value "Primitive. Store the value argument into a literal in the receiver. An index of 2 corresponds to the first literal. Fails if the index is less than 2 or greater than the number of literals. Answer the value as the result. Normally only the compiler sends this message, because only the compiler stores values in CompiledMethods. Essential. See Object documentation whatIsAPrimitive." self primitiveFailed! ! !CompiledMethod methodsFor: 'scanning'! messages "Answer a Set of all the message selectors sent by this method." | scanner aSet | aSet _ Set new. scanner _ InstructionStream on: self. scanner scanFor: [:x | scanner addSelectorTo: aSet. false "keep scanning"]. ^aSet! ! !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'! scanLongLoad: extension "Answer whether the receiver contains a long load whose extension is the argument." | scanner | scanner _ InstructionStream on: self. ^scanner scanFor: [:instr | instr = 128 and: [scanner followingByte = extension]]! ! !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'! cacheTempNames: names TempNameCache _ Association key: self value: names! ! !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' stamp: 'tk 12/12/97 13:03'! 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) text! ! !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' stamp: 'tk 12/11/97 16:21'! 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 methodsFor: 'file in/out' stamp: 'tk 3/24/98 12:58'! 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. Must read both objects for the literals and bytes for the bytecodes." | lits | aDataStream beginReference: self. self objectAt: 1 put: aDataStream next. "the header" lits _ self numLiterals + 1. "counting header" 2 to: lits do: [:ii | self objectAt: ii put: aDataStream next]. lits*4+1 to: self basicSize do: [:ii | self basicAt: ii put: aDataStream byteStream next]. "Get raw bytes directly from the file" ^ self! ! !CompiledMethod methodsFor: 'file in/out' stamp: 'tk 3/26/98 09:10'! storeDataOn: aDataStream "Store myself on a DataStream. I am a mixture of objects and raw data bytes. Only use this for blocks. Normal methodDictionaries should not be put out using ReferenceStreams. Their fileOut should be attached to the beginning of the file." | byteLength lits | "No inst vars of the normal type" byteLength _ self basicSize. aDataStream beginInstance: self class size: byteLength. lits _ self numLiterals + 1. "counting header" 1 to: lits do: [:ii | aDataStream nextPut: (self objectAt: ii)]. lits*4+1 to: byteLength do: [:ii | aDataStream byteStream nextPut: (self basicAt: ii)]. "write bytes straight through to the file"! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! CompiledMethod class instanceVariableNames: ''! !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! ! !CompiledMethod class methodsFor: 'instance creation'! newMethod: numberOfBytes header: headerWord "Primitive. Answer an instance of me. The number of literals (and other information) is specified the headerWord. The first argument specifies the number of fields for bytecodes in the method. Fail if either argument is not a SmallInteger, or if numberOfBytes is negative. Once the header of a method is set by this primitive, it cannot be changed in any way. Essential. See Object documentation whatIsAPrimitive." (numberOfBytes isInteger and: [headerWord isInteger and: [numberOfBytes >= 0]]) ifTrue: [ "args okay; space must be low" Smalltalk signalLowSpace. "retry if user proceeds" ^ self newMethod: numberOfBytes header: headerWord ]. ^self primitiveFailed! ! !CompiledMethod class methodsFor: 'instance creation'! toReturnConst: constCode "Answer an instance of me that is a quick return of a constant constCode = 1...7 -> true, false, nil, -1, 0, 1, 2." ^ self newBytes: 0 nArgs: 0 nTemps: 0 nStack: 0 nLits: 0 primitive: 256 + constCode! ! !CompiledMethod class methodsFor: 'instance creation'! toReturnConstant: index "Answer an instance of me that is a quick return of the constant indexed in (true false nil -1 0 1 2)." ^ self newBytes: 0 nArgs: 0 nTemps: 0 nStack: 0 nLits: 0 primitive: 256 + index ! ! !CompiledMethod class methodsFor: 'instance creation'! toReturnField: field "Answer an instance of me that is a quick return of the instance variable indexed by the argument, field." ^ self newBytes: 0 nArgs: 0 nTemps: 0 nStack: 0 nLits: 0 primitive: 264 + field ! ! !CompiledMethod class methodsFor: 'instance creation'! toReturnSelf "Answer an instance of me that is a quick return of the instance (^self)." ^ self newBytes: 0 nArgs: 0 nTemps: 0 nStack: 0 nLits: 0 primitive: 256 ! ! Object subclass: #Compiler instanceVariableNames: 'sourceStream requestor class context ' classVariableNames: '' poolDictionaries: '' category: 'System-Compiler'! !Compiler commentStamp: 'di 5/22/1998 16:33' prior: 0! Compiler comment: 'The compiler accepts Smalltalk source code and compiles it with respect to a given class. The user of the compiler supplies a context so that temporary variables are accessible during compilation. If there is an error, a requestor (usually a kind of StringHolderController) is sent the message notify:at:in: so that the error message can be displayed. If there is no error, then the result of compilation is a MethodNode, which is the root of a parse tree whose nodes are kinds of ParseNodes. The parse tree can be sent messages to (1) generate code for a CompiledMethod (this is done for compiling methods or evaluating expressions); (2) pretty-print the code (for formatting); or (3) produce a map from object code back to source code (used by debugger program-counter selection). See also Parser, Encoder, ParseNode.'! !Compiler methodsFor: 'error handling'! interactive "Answer whether there is a requestor of the compiler who should be informed that an error occurred." ^ (requestor == nil or: [requestor isKindOf: SyntaxError]) not! ! !Compiler methodsFor: 'error handling'! notify: aString "Refer to the comment in Object|notify:." ^self notify: aString at: sourceStream position + 1! ! !Compiler methodsFor: 'error handling'! notify: aString at: location "Refer to the comment in Object|notify:." requestor == nil ifTrue: [^SyntaxError errorInClass: class withCode: (sourceStream contents copyReplaceFrom: location to: location - 1 with: aString)] ifFalse: [^requestor notify: aString at: location in: sourceStream]! ! !Compiler methodsFor: 'public access'! compile: textOrStream in: aClass notifying: aRequestor ifFail: failBlock "Answer a MethodNode for the argument, textOrStream. If the MethodNode can not be created, notify the argument, aRequestor; if aRequestor is nil, evaluate failBlock instead. The MethodNode is the root of a parse tree. It can be told to generate a CompiledMethod to be installed in the method dictionary of the argument, aClass." self from: textOrStream class: aClass context: nil notifying: aRequestor. ^self translate: sourceStream noPattern: false ifFail: failBlock! ! !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]! ! !Compiler methodsFor: 'public access'! parse: textOrStream in: aClass notifying: req "Compile the argument, textOrStream, with respect to the class, aClass, and answer the MethodNode that is the root of the resulting parse tree. Notify the argument, req, if an error occurs. The failBlock is defaulted to an empty block." self from: textOrStream class: aClass context: nil notifying: req. ^self translate: sourceStream noPattern: false ifFail: []! ! !Compiler methodsFor: 'private'! format: aStream noPattern: noPattern ifFail: failBlock | tree | tree _ Parser new parse: aStream class: class noPattern: noPattern context: context notifying: requestor ifFail: [^failBlock value]. ^tree! ! !Compiler methodsFor: 'private'! from: textOrStream class: aClass context: aContext notifying: req (textOrStream isKindOf: PositionableStream) ifTrue: [sourceStream _ textOrStream] ifFalse: [sourceStream _ ReadStream on: textOrStream asString]. class _ aClass. context _ aContext. requestor _ req! ! !Compiler methodsFor: 'private'! translate: aStream noPattern: noPattern ifFail: failBlock | tree | tree _ Parser new parse: aStream class: class noPattern: noPattern context: context notifying: requestor ifFail: [^failBlock value]. ^tree! ! !Compiler methodsFor: 'private'! translate: aStream withLocals: localDict noPattern: noPattern ifFail: failBlock | tree | tree _ Parser new parse: aStream class: class noPattern: noPattern locals: localDict notifying: requestor ifFail: [^failBlock value]. ^tree! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Compiler class instanceVariableNames: ''! !Compiler class methodsFor: 'accessing'! parserClass "Return a parser class to use for parsing method headers." ^Parser! ! !Compiler class methodsFor: 'evaluating'! evaluate: textOrString "See Compiler|evaluate:for:notifying:logged:. If a compilation error occurs, a Syntax Error view is created rather than notifying any requestor. Compilation is carried out with respect to nil, i.e., no object, and the invocation is not logged." ^self evaluate: textOrString for: nil logged: false! ! !Compiler class methodsFor: 'evaluating'! evaluate: textOrString for: anObject logged: logFlag "See Compiler|evaluate:for:notifying:logged:. If a compilation error occurs, a Syntax Error view is created rather than notifying any requestor." ^self evaluate: textOrString for: anObject notifying: nil logged: logFlag! ! !Compiler class methodsFor: 'evaluating'! evaluate: textOrString for: anObject notifying: aController logged: logFlag "Compile and execute the argument, textOrString with respect to the class of anObject. If a compilation error occurs, notify aController. If both compilation and execution are successful then, if logFlag is true, log (write) the text onto a system changes file so that it can be replayed if necessary." | val | val _ self new evaluate: textOrString in: nil to: anObject notifying: aController ifFail: [^nil]. logFlag ifTrue: [Smalltalk logChange: textOrString]. ^val! ! !Compiler class methodsFor: 'evaluating'! evaluate: textOrString logged: logFlag "See Compiler|evaluate:for:notifying:logged:. If a compilation error occurs, a Syntax Error view is created rather than notifying any requestor. Compilation is carried out with respect to nil, i.e., no object." ^self evaluate: textOrString for: nil logged: logFlag! ! !Compiler class methodsFor: 'evaluating'! evaluate: textOrString notifying: aController logged: logFlag "See Compiler|evaluate:for:notifying:logged:. Compilation is carried out with respect to nil, i.e., no object." ^self evaluate: textOrString for: nil notifying: aController logged: logFlag! ! Player subclass: #Component instanceVariableNames: 'model pinSpecs ' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Components'! !Component methodsFor: 'initialize' stamp: 'di 5/3/1998 20:23'! initComponentIn: aLayout model _ aLayout model. self nameMeIn: aLayout world. self color: Color lightCyan. self showPins. model addDependent: self! ! !Component methodsFor: 'naming' stamp: 'di 5/3/1998 19:48'! chooseNameLike: someName | stem otherNames i partName | stem _ someName. (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 asSet. "otherNames addAll: self world allKnownNames." i _ 1. [otherNames includes: (partName _ stem , i printString)] whileTrue: [i _ i + 1]. partName _ FillInTheBlank request: 'Please give this part a name' initialAnswer: partName. partName isEmpty ifTrue: [^ nil]. (otherNames includes: partName) ifTrue: [self inform: 'Sorry, that name is already used'. ^ nil]. ^ partName! ! !Component methodsFor: 'naming' stamp: 'di 5/3/1998 19:58'! externalName ^ self class name! ! !Component methodsFor: 'naming' stamp: 'di 5/3/1998 19:50'! nameMeIn: aWorld | stem otherNames i partName className | className _ self class name. stem _ className. (stem size > 5 and: [stem endsWith: 'Morph']) ifTrue: [stem _ stem copyFrom: 1 to: stem size - 5]. stem _ stem first asLowercase asString , stem allButFirst. otherNames _ Set newFrom: aWorld allKnownNames. i _ 1. [otherNames includes: (partName _ stem , i printString)] whileTrue: [i _ i + 1]. self setNamePropertyTo: partName! ! !Component methodsFor: 'naming' stamp: 'di 5/3/1998 19:51'! renameMe | newName | newName _ self chooseNameLike: self knownName. newName ifNil: [^ nil]. self setNamePropertyTo: newName! ! !Component methodsFor: 'drag and drop' stamp: 'di 5/3/1998 20:08'! justDroppedInto: aMorph event: anEvent | theModel | theModel _ aMorph model. ((aMorph isKindOf: ComponentLayout) and: [theModel isKindOf: Component]) ifFalse: ["Disconnect prior to removal by move" (theModel isKindOf: Component) ifTrue: [self unwire. model _ nil]. ^ self]. theModel == model ifTrue: [^ self "Presumably just a move"]. self initComponentIn: aMorph! ! !Component methodsFor: 'variables' stamp: 'di 5/3/1998 19:46'! addVariableNamed: varName | otherNames i partName | "Adjust name if necessary and add it" otherNames _ self class allInstVarNames. i _ nil. [i == nil ifTrue: [partName _ varName] ifFalse: [partName _ varName, i printString]. otherNames includes: partName] whileTrue: [i == nil ifTrue: [i _ 1] ifFalse: [i _ i + 1]]. self class addInstVarName: partName. "Now compile read method and write-with-change method" self class compile: (String streamContents: [:s | s nextPutAll: partName; cr; tab; nextPutAll: '^', partName]) classified: 'view access' notifying: nil. self class compile: (String streamContents: [:s | s nextPutAll: partName, 'Set: newValue'; cr; tab; nextPutAll: partName, ' _ newValue.'; cr; tab; nextPutAll: 'self changed: #', partName]) classified: 'view access' notifying: nil. ^ Array with: partName asSymbol with: (partName , 'Set:') asSymbol! ! !Component methodsFor: 'variables' stamp: 'di 5/3/1998 19:58'! removeVariableNamed: varName self class removeSelector: varName. self class removeSelector: (varName , 'Set:') asSymbol. self class removeInstVarName: varName asString! ! !Component methodsFor: 'misc' stamp: 'di 5/3/1998 20:01'! addAddHandMenuItemsForHalo: aMenu hand: aHandMorph super addAddHandMenuItemsForHalo: aMenu hand: aHandMorph. aMenu add: 'delete' action: #dismissMorph! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Component class instanceVariableNames: ''! !Component class methodsFor: 'all' stamp: 'di 4/17/1998 14:02'! acceptsLoggingOfCompilation "Log everything for now" ^ true! ! !Component class methodsFor: 'all' stamp: 'di 4/18/1998 11:08'! addSlotNamed: aName (self allInstVarNames includes: aName) ifTrue: [self error: 'Duplicate slot name']. self addInstVarName: aName. ! ! !Component class methodsFor: 'all' stamp: 'di 5/2/1998 10:40'! compileAccessorsFor: varName "This should come around and invoke the new implementation inherited from Player (instance)" ^ self basicNew compileAccessorsFor: varName ! ! !Component class methodsFor: 'all' stamp: 'di 4/13/98 12:15'! includeInNewMorphMenu "Only include instances of subclasses of me" ^ self ~~ Component! ! !Component class methodsFor: 'all' stamp: 'di 5/3/1998 19:55'! wantsChangeSetLogging "Log changes for Component itself, but not for automatically-created subclasses like Component1, Component2" "^ self == Component or: [(self class name beginsWith: 'Component') not]" "Log everything for now" false ifTrue: [self halt "DONT FORGET TO REORDER FILEOUT"]. ^ true! ! Component subclass: #Component1 instanceVariableNames: 'printComponent1value listComponent1selectedItem functionComponent1output listComponent2selectedItem functionComponent2output functionComponent3output listComponent3selectedItem functionComponent4output listComponent4selectedItem functionComponent5output ' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Components-Demo'! !Component1 methodsFor: 'view access' stamp: 'di 5/8/1998 23:31'! functionComponent1output ^functionComponent1output! ! !Component1 methodsFor: 'view access' stamp: 'di 5/8/1998 23:31'! functionComponent1outputSet: newValue functionComponent1output _ newValue. self changed: #functionComponent1output! ! !Component1 methodsFor: 'view access' stamp: 'di 5/8/1998 23:35'! functionComponent2output ^functionComponent2output! ! !Component1 methodsFor: 'view access' stamp: 'di 5/8/1998 23:35'! functionComponent2outputSet: newValue functionComponent2output _ newValue. self changed: #functionComponent2output! ! !Component1 methodsFor: 'view access' stamp: 'di 5/8/1998 23:35'! functionComponent3output ^functionComponent3output! ! !Component1 methodsFor: 'view access' stamp: 'di 5/8/1998 23:35'! functionComponent3outputSet: newValue functionComponent3output _ newValue. self changed: #functionComponent3output! ! !Component1 methodsFor: 'view access' stamp: 'di 5/8/1998 23:42'! functionComponent4output ^functionComponent4output! ! !Component1 methodsFor: 'view access' stamp: 'di 5/8/1998 23:42'! functionComponent4outputSet: newValue functionComponent4output _ newValue. self changed: #functionComponent4output! ! !Component1 methodsFor: 'view access' stamp: 'di 5/8/1998 23:49'! functionComponent5output ^functionComponent5output! ! !Component1 methodsFor: 'view access' stamp: 'di 5/8/1998 23:49'! functionComponent5outputSet: newValue functionComponent5output _ newValue. self changed: #functionComponent5output! ! !Component1 methodsFor: 'view access' stamp: 'di 5/8/1998 23:30'! listComponent1selectedItem ^listComponent1selectedItem! ! !Component1 methodsFor: 'view access' stamp: 'di 5/8/1998 23:30'! listComponent1selectedItemSet: newValue listComponent1selectedItem _ newValue. self changed: #listComponent1selectedItem! ! !Component1 methodsFor: 'view access' stamp: 'di 5/8/1998 23:32'! listComponent2selectedItem ^listComponent2selectedItem! ! !Component1 methodsFor: 'view access' stamp: 'di 5/8/1998 23:32'! listComponent2selectedItemSet: newValue listComponent2selectedItem _ newValue. self changed: #listComponent2selectedItem! ! !Component1 methodsFor: 'view access' stamp: 'di 5/8/1998 23:41'! listComponent3selectedItem ^listComponent3selectedItem! ! !Component1 methodsFor: 'view access' stamp: 'di 5/8/1998 23:41'! listComponent3selectedItemSet: newValue listComponent3selectedItem _ newValue. self changed: #listComponent3selectedItem! ! !Component1 methodsFor: 'view access' stamp: 'di 5/8/1998 23:48'! listComponent4selectedItem ^listComponent4selectedItem! ! !Component1 methodsFor: 'view access' stamp: 'di 5/8/1998 23:48'! listComponent4selectedItemSet: newValue listComponent4selectedItem _ newValue. self changed: #listComponent4selectedItem! ! !Component1 methodsFor: 'view access' stamp: 'di 5/8/1998 23:29'! printComponent1value ^printComponent1value! ! !Component1 methodsFor: 'view access' stamp: 'di 5/8/1998 23:29'! printComponent1valueSet: newValue printComponent1value _ newValue. self changed: #printComponent1value! ! !Component1 methodsFor: 'functions' stamp: 'di 5/8/1998 23:31'! functionComponent1a: a ^ SystemOrganization listAtCategoryNamed: a! ! !Component1 methodsFor: 'functions' stamp: 'di 5/8/1998 23:36'! functionComponent2a: a ^ Smalltalk at: a! ! !Component1 methodsFor: 'functions' stamp: 'di 5/8/1998 23:36'! functionComponent3a: a ^ a organization categories! ! !Component1 methodsFor: 'functions' stamp: 'di 5/8/1998 23:43'! functionComponent4a: a b: b ^ a organization listAtCategoryNamed: b! ! !Component1 methodsFor: 'functions' stamp: 'di 5/8/1998 23:51'! functionComponent5a: a b: b ^ a sourceCodeAt: b! ! PasteUpMorph subclass: #ComponentLayout instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Components'! !ComponentLayout methodsFor: 'all' stamp: 'di 5/3/1998 10:17'! acceptDroppingMorph: aMorph event: evt "Eschew all of PasteUp's mechanism for now" self addMorph: aMorph. ! ! !ComponentLayout methodsFor: 'all' stamp: 'di 5/3/1998 09:44'! addCustomMenuItems: menu hand: aHandMorph super addCustomMenuItems: menu hand: aHandMorph. menu addLine. menu add: 'inspect model in morphic' action: #inspectModelInMorphic! ! !ComponentLayout methodsFor: 'all' stamp: 'di 5/5/1998 01:02'! allKnownNames ^ (self submorphs collect: [:m | m knownName] thenSelect: [:m | m ~~ nil])! ! !ComponentLayout methodsFor: 'all' stamp: 'di 5/2/1998 21:36'! createCustomModel "Create a model object for this world if it does not yet have one. The default model for an EditView is a Component." model == nil ifFalse: [^ self]. "already has a model" model _ Component newSubclass new. ! ! !ComponentLayout methodsFor: 'all' stamp: 'di 5/4/1998 08:01'! initialize super initialize. self extent: 384@256! ! !ComponentLayout methodsFor: 'all' stamp: 'di 5/3/1998 09:41'! inspectModelInMorphic | insp | insp _ InspectorBrowser openAsMorphOn: self model. self world addMorph: insp; startStepping: insp! ! MorphicModel subclass: #ComponentLikeModel instanceVariableNames: 'pinSpecs ' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Components'! !ComponentLikeModel methodsFor: 'initialization' stamp: 'di 5/3/1998 09:24'! duplicate: newGuy from: oldGuy "oldGuy has just been duplicated and will stay in this world. Make sure all the ComponentLikeModel requirements are carried out for the copy. Ask user to rename it. " newGuy installModelIn: oldGuy pasteUpMorph. newGuy copySlotMethodsFrom: oldGuy slotName.! ! !ComponentLikeModel methodsFor: 'compilation' stamp: 'di 5/3/1998 09:25'! choosePartName "When I am renamed, get a slot, make default methods, move any existing methods." | old | (self pasteUpMorph model isKindOf: Component) ifTrue: [self knownName ifNil: [^ self nameMeIn: self pasteUpMorph] ifNotNil: [^ self renameMe]]. 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!!"! ! !ComponentLikeModel methodsFor: 'components' stamp: 'di 5/3/1998 22:10'! addAddHandMenuItemsForHalo: aMenu hand: aHandMorph super addAddHandMenuItemsForHalo: aMenu hand: aHandMorph. aMenu addLine. aMenu add: 'inspect' action: #inspectMorph. aMenu add: 'delete' action: #dismissMorph! ! !ComponentLikeModel methodsFor: 'components' stamp: 'di 5/1/1998 16:14'! addPinFromSpec: pinSpec | pin | pin _ PinMorph new component: self pinSpec: pinSpec. self addMorph: pin. pin placeFromSpec. ^ pin! ! !ComponentLikeModel methodsFor: 'components' stamp: 'di 5/16/1998 16:36'! delete (model isKindOf: Component) ifTrue: [^ self deleteComponent]. (model isKindOf: MorphicModel) ifFalse: [^ 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. ! ! !ComponentLikeModel methodsFor: 'components' stamp: 'di 5/2/1998 15:07'! deleteComponent model removeDependent: self. self pinsDo: [:pin | pin delete]. ^ super delete! ! !ComponentLikeModel methodsFor: 'components' stamp: 'di 4/29/1998 09:49'! extent: newExtent super extent: newExtent. self submorphsDo: [:m | (m isKindOf: PinMorph) ifTrue: [m placeFromSpec]]! ! !ComponentLikeModel methodsFor: 'components' stamp: 'di 5/5/1998 00:57'! initComponentIn: aLayout model _ aLayout model. self nameMeIn: aLayout. self color: Color lightCyan. self initPinSpecs. self initFromPinSpecs. self showPins. model addDependent: self! ! !ComponentLikeModel methodsFor: 'components' stamp: 'di 5/1/1998 16:31'! initFromPinSpecs "no-op for default"! ! !ComponentLikeModel methodsFor: 'components' stamp: 'di 5/3/1998 20:11'! initPinSpecs "no-op for default" pinSpecs _ Array new. ! ! !ComponentLikeModel methodsFor: 'components' stamp: 'di 5/3/1998 20:07'! justDroppedInto: aMorph event: anEvent | theModel | theModel _ aMorph model. ((aMorph isKindOf: ComponentLayout) and: [theModel isKindOf: Component]) ifFalse: ["Disconnect prior to removal by move" (theModel isKindOf: Component) ifTrue: [self unwire. model _ nil]. ^ self]. theModel == model ifTrue: [^ self "Presumably just a move"]. self initComponentIn: aMorph! ! !ComponentLikeModel methodsFor: 'components' stamp: 'di 4/26/1998 10:40'! nameMeIn: aWorld | stem otherNames i partName className | className _ self class name. stem _ className. (stem size > 5 and: [stem endsWith: 'Morph']) ifTrue: [stem _ stem copyFrom: 1 to: stem size - 5]. stem _ stem first asLowercase asString , stem allButFirst. otherNames _ Set newFrom: aWorld allKnownNames. i _ 1. [otherNames includes: (partName _ stem , i printString)] whileTrue: [i _ i + 1]. self setNamePropertyTo: partName! ! !ComponentLikeModel methodsFor: 'components' stamp: 'di 5/3/1998 20:18'! pinSpecs ^ pinSpecs! ! !ComponentLikeModel methodsFor: 'components' stamp: 'di 5/2/1998 15:09'! pinsDo: pinBlock self submorphsDo: [:m | (m isKindOf: PinMorph) ifTrue: [pinBlock value: m]]! ! !ComponentLikeModel methodsFor: 'components' stamp: 'di 5/3/1998 09:26'! renameMe | otherNames newName | otherNames _ Set newFrom: self pasteUpMorph allKnownNames. newName _ FillInTheBlank request: 'Please give this new a name' initialAnswer: self knownName. newName isEmpty ifTrue: [^ nil]. (otherNames includes: newName) ifTrue: [self inform: 'Sorry, that name is already used'. ^ nil]. self setNamePropertyTo: newName! ! !ComponentLikeModel methodsFor: 'components' stamp: 'di 4/29/1998 15:16'! showPins "Make up sensitized pinMorphs for each of my interface variables" self pinSpecs do: [:pinSpec | self addPinFromSpec: pinSpec]! ! MorphicTransform subclass: #CompositeTransform instanceVariableNames: 'globalTransform localTransform ' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Support'! !CompositeTransform commentStamp: 'di 5/22/1998 16:33' prior: 0! A composite transform provides the effect of several levels of coordinate transformations. This class is a subclass of MorphicTransform, only to inherit some generic transformation methods. It would be better for both classes to inherit these methods from a common superclass.! !CompositeTransform methodsFor: 'initialization' stamp: 'di 3/4/98 19:17'! globalTransform: gt localTransform: lt globalTransform _ gt. localTransform _ lt! ! !CompositeTransform methodsFor: 'testing' stamp: 'di 3/4/98 19:18'! isIdentity ^ globalTransform isIdentity and: [localTransform isIdentity]! ! !CompositeTransform methodsFor: 'testing' stamp: 'di 3/4/98 19:18'! isPureTranslation ^ globalTransform isPureTranslation and: [localTransform isPureTranslation]! ! !CompositeTransform methodsFor: 'transformations' stamp: 'di 3/4/98 19:20'! invert: aPoint ^ globalTransform invert: (localTransform transform: aPoint)! ! !CompositeTransform methodsFor: 'transformations' stamp: 'di 3/4/98 19:20'! transform: aPoint ^ localTransform transform: (globalTransform transform: aPoint)! ! CharacterScanner subclass: #CompositionScanner instanceVariableNames: 'spaceX spaceIndex lineHeight baseline lineHeightAtSpace baselineAtSpace ' classVariableNames: '' poolDictionaries: 'TextConstants ' category: 'Graphics-Support'! !CompositionScanner commentStamp: 'di 5/22/1998 16:33' prior: 0! CompositionScanner comment: 'CompositionScanners are used to measure text and determine where line breaks and space padding should occur.'! !CompositionScanner methodsFor: 'initialize-release'! in: aParagraph "Initialize the paragraph to be scanned as the argument, aParagraph. Set the composition frame for the paragraph." super initializeFromParagraph: aParagraph clippedBy: aParagraph clippingRectangle! ! !CompositionScanner methodsFor: 'accessing'! rightX "Meaningful only when a line has just been composed -- refers to the line most recently composed. This is a subtrefuge to allow for easy resizing of a composition rectangle to the width of the maximum line. Useful only when there is only one line in the form or when each line is terminated by a carriage return. Handy for sizing menus and lists." ^spaceX! ! !CompositionScanner methodsFor: 'scanning' stamp: 'di 11/29/97 08:46'! composeFrom: startIndex inRectangle: lineRectangle firstLine: firstLine leftSide: leftSide rightSide: rightSide "Answer an instance of TextLineInterval that represents the next line in the paragraph." | runLength done stopCondition | "Set up margins" leftMargin _ lineRectangle left. leftSide ifTrue: [leftMargin _ leftMargin + (firstLine ifTrue: [textStyle firstIndent] ifFalse: [textStyle restIndent])]. spaceX _ destX _ leftMargin. rightMargin _ lineRectangle right. rightSide ifTrue: [rightMargin _ rightMargin - textStyle rightIndent]. lastIndex _ startIndex. "scanning sets last index" destY _ lineRectangle top. lineHeight _ baseline _ 0. "Will be increased by setFont" self setStopConditions. "also sets font" runLength _ text runLengthFor: startIndex. runStopIndex _ (lastIndex _ startIndex) + (runLength - 1). line _ (TextLine start: lastIndex stop: 0 internalSpaces: 0 paddingWidth: 0) rectangle: lineRectangle; leftMargin: leftMargin. spaceCount _ 0. done _ false. [done] whileFalse: [stopCondition _ self scanCharactersFrom: lastIndex to: runStopIndex in: text string rightX: rightMargin stopConditions: stopConditions kern: kern 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' stamp: 'di 10/29/97 12:17'! 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 _ self scanCharactersFrom: lastIndex to: runStopIndex in: text string rightX: rightMargin stopConditions: stopConditions kern: kern 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' stamp: 'di 10/24/97 09:15'! setActualFont: aFont "Keep track of max height and ascent for auto lineheight" | descent | super setActualFont: aFont. lineHeight == nil ifTrue: [descent _ font descent. baseline _ font ascent. lineHeight _ baseline + descent] ifFalse: [descent _ lineHeight - baseline max: font descent. baseline _ baseline max: font ascent. lineHeight _ lineHeight max: baseline + descent]! ! !CompositionScanner methodsFor: 'stop conditions'! cr "Answer true. Set up values for the text line interval currently being composed." line stop: lastIndex. spaceX _ destX. line paddingWidth: rightMargin - destX. ^true! ! !CompositionScanner methodsFor: 'stop conditions' stamp: 'di 11/10/97 10:35'! 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." spaceCount >= 1 ifTrue: ["The common case. First back off to the space at which we wrap." line stop: spaceIndex. lineHeight _ lineHeightAtSpace. baseline _ baselineAtSpace. spaceCount _ spaceCount - 1. spaceIndex _ spaceIndex - 1. "Check to see if any spaces preceding the one at which we wrap. Double space after punctuation, 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 _ text fontAt: spaceIndex withStyle: textStyle. spaceIndex _ spaceIndex - 1. spaceX _ spaceX - (font widthOf: Space)]. line paddingWidth: rightMargin - spaceX. line internalSpaces: spaceCount] ifFalse: ["Neither internal nor trailing spaces -- almost never happens." lastIndex _ lastIndex - 1. [destX <= rightMargin] whileFalse: [destX _ destX - (font widthOf: (text at: lastIndex)). lastIndex _ lastIndex - 1]. spaceX _ destX. line paddingWidth: rightMargin - destX. line stop: (lastIndex max: line first)]. ^true! ! !CompositionScanner methodsFor: 'stop conditions'! endOfRun "Answer true if scanning has reached the end of the paragraph. Otherwise step conditions (mostly install potential new font) and answer false." | runLength | lastIndex = text size ifTrue: [line stop: lastIndex. spaceX _ destX. line paddingWidth: rightMargin - destX. ^true] ifFalse: [runLength _ (text runLengthFor: (lastIndex _ lastIndex + 1)). runStopIndex _ lastIndex + (runLength - 1). self setStopConditions. ^false] ! ! !CompositionScanner methodsFor: 'stop conditions' stamp: 'di 11/13/97 12:13'! placeEmbeddedObject: anchoredMorph | descent | (super placeEmbeddedObject: anchoredMorph) ifFalse: [^ false]. descent _ lineHeight - baseline. lineHeight _ lineHeight max: anchoredMorph height. baseline _ lineHeight - descent. ^ true! ! !CompositionScanner methodsFor: 'stop conditions'! setStopConditions "Set the font and the stop conditions for the current run." self setFont! ! !CompositionScanner methodsFor: 'stop conditions' stamp: 'di 11/5/97 07:46'! space "Record left x and character index of the space character just encounted. Used for wrap-around. Answer whether the character has crossed the right edge of the composition rectangle of the paragraph." spaceX _ destX. destX _ spaceX + spaceWidth. spaceIndex _ lastIndex. lineHeightAtSpace _ lineHeight. baselineAtSpace _ baseline. lastIndex _ lastIndex + 1. spaceCount _ spaceCount + 1. destX > rightMargin ifTrue: [^self crossedX]. ^false ! ! !CompositionScanner methodsFor: 'stop conditions'! tab "Advance destination x according to tab settings in the paragraph's textStyle. Answer whether the character has crossed the right edge of the composition rectangle of the paragraph." destX _ textStyle nextTabXFrom: destX leftMargin: leftMargin rightMargin: rightMargin. destX > rightMargin ifTrue: [^self crossedX]. lastIndex _ lastIndex + 1. ^false ! ! AlignmentMorph subclass: #CompoundTileMorph instanceVariableNames: 'type testPart yesPart noPart ' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Scripting-Tiles'! !CompoundTileMorph commentStamp: 'di 5/22/1998 16:33' prior: 0! CompoundTileMorph comment: 'A statement with other whole statements inside it. If-Then. Test.'! !CompoundTileMorph methodsFor: 'all'! acceptDroppingMorph: aMorph event: evt "Forward the dropped morph to the appropriate part." (self targetPartFor: aMorph) acceptDroppingMorph: aMorph event: evt. ! ! !CompoundTileMorph methodsFor: 'all'! codeString | s | s _ WriteStream on: ''. self storeCodeOn: s. ^ s contents ! ! !CompoundTileMorph methodsFor: 'all' stamp: 'di 10/17/97 21:31'! enclosingEditor "Return the next scriptor outward in the containment hierarchy" | current | current _ owner. [current == nil] whileFalse: [((current isKindOf: ScriptEditorMorph) or: [current isKindOf: CompoundTileMorph]) ifTrue: [^ current]. current _ current owner]. ^ nil! ! !CompoundTileMorph methodsFor: 'all' stamp: 'di 10/17/97 21:36'! handlesMouseOver: evt ^ true ! ! !CompoundTileMorph methodsFor: 'all' stamp: 'sw 5/13/1998 14:49'! initialize | r | super initialize. self color: Color orange muchLighter. self borderWidth: 1. self inset: 2. self orientation: #vertical. r _ AlignmentMorph newRow color: color; inset: 0. r setProperty: #demandsBoolean toValue: true. r addMorphBack: (Morph new color: color; extent: 2@5). "spacer" r addMorphBack: (StringMorph new contents: 'Test'). r addMorphBack: (Morph new color: color; extent: 5@5). "spacer" r addMorphBack: (testPart _ BooleanScriptEditor new borderWidth: 0; inset: 1). testPart color: Color transparent. self addMorphBack: r. r _ AlignmentMorph newRow color: color; inset: 0. r addMorphBack: (Morph new color: color; extent: 30@5). "spacer" r addMorphBack: (StringMorph new contents: 'Yes'). r addMorphBack: (Morph new color: color; extent: 5@5). "spacer" r addMorphBack: (yesPart _ ScriptEditorMorph new borderWidth: 0; inset: 2). yesPart color: Color transparent. self addMorphBack: r. r _ AlignmentMorph newRow color: color; inset: 0. r addMorphBack: (Morph new color: color; extent: 35@5). "spacer" r addMorphBack: (StringMorph new contents: 'No'). r addMorphBack: (Morph new color: color; extent: 5@5). "spacer" r addMorphBack: (noPart _ ScriptEditorMorph new borderWidth: 0; inset: 2). noPart color: Color transparent. self addMorphBack: r. self extent: 5@5. "will grow to fit" ! ! !CompoundTileMorph methodsFor: 'all' stamp: 'sw 10/18/97 18:03'! install "Backstop for obscure cases"! ! !CompoundTileMorph methodsFor: 'all' stamp: 'tk 10/1/97 18:25'! isTileLike "Can be dropped into a script" ^ true! ! !CompoundTileMorph methodsFor: 'all' stamp: 'sw 10/13/97 21:25'! markEdited "Pertains only when the test is outside a script?!!" ! ! !CompoundTileMorph methodsFor: 'all' stamp: 'jm 10/18/97 21:03'! mouseEnter: evt "Resume drop-tracking in enclosing editor" | ed | (ed _ self enclosingEditor) ifNotNil: [ed mouseLeave: evt]! ! !CompoundTileMorph methodsFor: 'all' stamp: 'jm 10/18/97 21:02'! mouseLeave: evt "Resume drop-tracking in enclosing editor" | ed | (ed _ self enclosingEditor) ifNotNil: [ed mouseEnter: evt]! ! !CompoundTileMorph methodsFor: 'all' stamp: 'sw 2/16/98 03:40'! player ^ nil! ! !CompoundTileMorph methodsFor: 'all' stamp: 'sw 2/1/98 16:40'! prepareToUndoDropOf: aMorph "needs to be here, as a no-op, owing to being hit obscurely on occasion"! ! !CompoundTileMorph methodsFor: 'all' stamp: 'di 10/17/97 16:31'! resultType ^ #command! ! !CompoundTileMorph methodsFor: 'all' stamp: 'sw 5/13/1998 15:19'! rowOfRightTypeFor: aLayoutMorph forActor: anActor aLayoutMorph demandsBoolean ifTrue: [^ self error: 'oops, cannot do that, please close this']. ^ self! ! !CompoundTileMorph methodsFor: 'all' stamp: 'sw 10/13/97 21:23'! scriptEdited "Pertains only when the test is outside a script?!!"! ! !CompoundTileMorph methodsFor: 'all' stamp: 'sw 10/13/97 21:23'! scriptee "Pertains only when the test is outside a script?!!" ^ nil! ! !CompoundTileMorph methodsFor: 'all' stamp: 'jm 11/3/97 16:37'! storeCodeBlockFor: scriptPart on: aStream | lastTile | lastTile _ nil. scriptPart allMorphsDo: [:m | (m isKindOf: TileMorph) ifTrue: [ (self tile: m isOnLineAfter: lastTile) ifTrue: [ lastTile ~~ nil ifTrue: [aStream nextPut: $.; cr]. aStream tab; tab. ] ifFalse: [ (lastTile ~= nil) ifTrue: [aStream space]]. m storeCodeOn: aStream. lastTile _ m]]. ! ! !CompoundTileMorph methodsFor: 'all' stamp: 'jm 11/3/97 16:30'! storeCodeOn: aStream aStream nextPut: $(. testPart storeCodeOn: aStream. aStream nextPut: $); cr; tab; nextPutAll: 'ifTrue: ['; cr. self storeCodeBlockFor: yesPart on: aStream. aStream nextPut: $]; cr; tab; nextPutAll: 'ifFalse: ['; cr. self storeCodeBlockFor: noPart on: aStream. aStream nextPut: $]; cr. ! ! !CompoundTileMorph methodsFor: 'all'! targetPartFor: aMorph "Return the row into which the given morph should be inserted." | centerY | centerY _ aMorph fullBounds center y. (Array with: testPart with: yesPart with: noPart) do: [:m | (centerY <= m bounds bottom) ifTrue: [^ m]]. ^ noPart ! ! !CompoundTileMorph methodsFor: 'all' stamp: 'di 5/6/1998 21:10'! tile: tile isOnLineAfter: previousTile "Return true if the given tile is not on the same line at the previous tile or if the previous tile is nil." | tileRow previousRow | previousTile ifNil: [^ true]. tileRow _ tile owner. [tileRow isMemberOf: AlignmentMorph] whileFalse: [tileRow _ tileRow owner]. "find the owning row" previousRow _ previousTile owner. [previousRow isMemberOf: AlignmentMorph] whileFalse: [previousRow _ previousRow owner]. "find the owning row" ^ tileRow ~~ previousRow ! ! !CompoundTileMorph methodsFor: 'all' stamp: 'tk 10/10/97 17:28'! tileRows "See if this works for insertion" ^ Array with: (Array with: self fullCopy)! ! !CompoundTileMorph methodsFor: 'all' stamp: 'sw 10/13/97 20:25'! topEditor | editor | editor _ self outermostMorphThat: [:m | (m isKindOf: ScriptEditorMorph) or: [m isKindOf: CompoundTileMorph]]. ^ editor ifNil: [self] ifNotNil: [editor]! ! !CompoundTileMorph methodsFor: 'all'! type ^ #compound ! ! !CompoundTileMorph methodsFor: 'all'! wantsDroppedMorph: aMorph event: evt ^ (aMorph isKindOf: TileMorph) or: [(aMorph isKindOf: ScriptEditorMorph) or: [(aMorph isKindOf: CompoundTileMorph) or: [aMorph isKindOf: CommandTilesMorph]]] ! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! CompoundTileMorph class instanceVariableNames: ''! !CompoundTileMorph class methodsFor: 'instance creation' stamp: 'di 6/22/97 09:07'! includeInNewMorphMenu "Not to be instantiated from the menu" ^ false! ! Object subclass: #ConnectionQueue instanceVariableNames: 'portNumber maxQueueLength connections accessSema socket process ' classVariableNames: '' poolDictionaries: '' category: 'System-Network'! !ConnectionQueue commentStamp: 'di 5/22/1998 16:33' prior: 0! A ConnectionQueue listens on a given port number and collects a queue of client connections. In order to handle state changes quickly, a ConnectionQueue has its own process that: (a) tries to keep a socket listening on the port whenever the queue isn't already full of connections and (b) prunes stale connections out of the queue to make room for fresh ones. ! !ConnectionQueue methodsFor: 'public' stamp: 'jm 3/10/98 17:31'! connectionCount "Return an estimate of the number of currently queued connections. This is only an estimate since a new connection could be made, or an existing one aborted, at any moment." | count | self pruneStaleConnections. accessSema critical: [count _ connections size]. ^ count ! ! !ConnectionQueue methodsFor: 'public' stamp: 'jm 3/9/98 14:34'! destroy "Terminate the listener process and destroy all sockets in my possesion." process ifNotNil: [ process terminate. process _ nil]. socket ifNotNil: [ socket destroy. socket _ nil]. connections do: [:s | s destroy]. connections _ OrderedCollection new. ! ! !ConnectionQueue methodsFor: 'public' stamp: 'jm 3/10/98 09:18'! getConnectionOrNil "Return a connected socket, or nil if no connection has been established." | result | accessSema critical: [ connections isEmpty ifTrue: [result _ nil] ifFalse: [ result _ connections removeFirst. ((result isValid) and: [result isConnected]) ifFalse: [ "stale connection" result destroy. result _ nil]]]. ^ result ! ! !ConnectionQueue methodsFor: 'private' stamp: 'jm 3/10/98 11:07'! initPortNumber: anInteger queueLength: queueLength "Private!! Initialize the receiver to listen on the given port number. Up to queueLength connections will be queued." portNumber _ anInteger. maxQueueLength _ queueLength. connections _ OrderedCollection new. accessSema _ Semaphore forMutualExclusion. socket _ nil. process _ [self listenLoop] newProcess. process priority: Processor highIOPriority. process resume. ! ! !ConnectionQueue methodsFor: 'private' stamp: 'jm 3/13/98 14:31'! listenLoop "Private!! This loop is run in a separate process. It will establish up to maxQueueLength connections on the given port." "Details: When out of sockets or queue is full, retry more frequently, since a socket may become available, space may open in the queue, or a previously queued connection may be aborted by the client, making it available for a fresh connection." [true] whileTrue: [ ((socket == nil) and: [connections size < maxQueueLength]) ifTrue: [ "try to create a new socket for listening" socket _ Socket createIfFail: [nil]]. socket == nil ifTrue: [(Delay forMilliseconds: 100) wait] ifFalse: [ socket isUnconnected ifTrue: [socket listenOn: portNumber]. socket waitForConnectionUntil: (Socket deadlineSecs: 10). socket isConnected ifTrue: [ "connection established" accessSema critical: [connections addLast: socket]. socket _ nil] ifFalse: [ (socket isWaitingForConnection or: [socket isUnconnected]) ifFalse: [socket destroy. socket _ nil]]]. "return to unconnected state" self pruneStaleConnections]. ! ! !ConnectionQueue methodsFor: 'private' stamp: 'jm 3/10/98 17:30'! pruneStaleConnections "Private!! The client may establish a connection and then disconnect while it is still in the connection queue. This method is called periodically to prune such sockets out of the connection queue and make room for fresh connections." | foundStaleConnection | accessSema critical: [ foundStaleConnection _ false. connections do: [:s | s isUnconnected ifTrue: [ s destroy. foundStaleConnection _ true]]. foundStaleConnection ifTrue: [ connections _ connections select: [:s | s isValid]]]. ! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ConnectionQueue class instanceVariableNames: ''! !ConnectionQueue class methodsFor: 'instance creation' stamp: 'jm 3/9/98 14:09'! portNumber: anInteger queueLength: queueLength ^ self new initPortNumber: anInteger queueLength: queueLength ! ! InstructionStream subclass: #ContextPart instanceVariableNames: 'stackp ' classVariableNames: 'TryPrimitiveMethods TryPrimitiveSelectors ' poolDictionaries: '' category: 'Kernel-Methods'! !ContextPart commentStamp: 'di 5/22/1998 16:33' prior: 0! ContextPart comment: 'To the instruction parsing ability of InstructionStream I add the actual semantics for execution. The execution state is stored in the indexable fields of my subclasses. This includes temporary variables and a stack of values used in evaluating expressions. The actual semantics of execution can be found in my category "system simulation" and "instruction decode". These methods exactly parallel the operation of the Smalltalk machine itself. The simulator is a group of my methods that do what the Smalltalk interpreter does: execute Smalltalk bytecodes. By adding code to the simulator, you may take statistics on the running of Smalltalk methods. For example, Transcript show: (ContextPart runSimulated: [3 factorial]) printString.'! !ContextPart methodsFor: 'accessing'! client "Answer the client, that is, the object that sent the message that created this context." ^sender receiver! ! !ContextPart methodsFor: 'accessing'! home "Answer the context in which the receiver was defined." self subclassResponsibility! ! !ContextPart methodsFor: 'accessing'! method "Answer the method of this context." self subclassResponsibility! ! !ContextPart methodsFor: 'accessing'! receiver "Answer the receiver of the message that created this context." self subclassResponsibility! ! !ContextPart methodsFor: 'accessing'! tempAt: index "Answer the value of the temporary variable whose index is the argument, index." self subclassResponsibility! ! !ContextPart methodsFor: 'accessing'! tempAt: index put: value "Store the argument, value, as the temporary variable whose index is the argument, index." self subclassResponsibility! ! !ContextPart methodsFor: 'instruction decoding'! doDup "Simulate the action of a 'duplicate top of stack' bytecode." self push: self top! ! !ContextPart methodsFor: 'instruction decoding'! doPop "Simulate the action of a 'remove top of stack' bytecode." self pop! ! !ContextPart methodsFor: 'instruction decoding'! jump: distance "Simulate the action of a 'unconditional jump' bytecode whose offset is the argument, distance." pc _ pc + distance! ! !ContextPart methodsFor: 'instruction decoding'! jump: distance if: condition "Simulate the action of a 'conditional jump' bytecode whose offset is the argument, distance, and whose condition is the argument, condition." (self pop eqv: condition) ifTrue: [self jump: distance]! ! !ContextPart methodsFor: 'instruction decoding'! methodReturnConstant: value "Simulate the action of a 'return constant' bytecode whose value is the argument, value. This corresponds to a source expression like '^0'." ^self return: value to: self home sender! ! !ContextPart methodsFor: 'instruction decoding'! methodReturnReceiver "Simulate the action of a 'return receiver' bytecode. This corresponds to the source expression '^self'." ^self return: self receiver to: self home sender! ! !ContextPart methodsFor: 'instruction decoding'! methodReturnTop "Simulate the action of a 'return top of stack' bytecode. This corresponds to source expressions like '^something'." ^self return: self pop to: self home sender! ! !ContextPart methodsFor: 'instruction decoding'! popIntoLiteralVariable: value "Simulate the action of bytecode that removes the top of the stack and stores it into a literal variable of my method." value value: self pop! ! !ContextPart methodsFor: 'instruction decoding'! popIntoReceiverVariable: offset "Simulate the action of bytecode that removes the top of the stack and stores it into an instance variable of my receiver." self receiver instVarAt: offset + 1 put: self pop! ! !ContextPart methodsFor: 'instruction decoding'! popIntoTemporaryVariable: offset "Simulate the action of bytecode that removes the top of the stack and stores it into one of my temporary variables." self home at: offset + 1 put: self pop! ! !ContextPart methodsFor: 'instruction decoding'! pushActiveContext "Simulate the action of bytecode that pushes the the active context on the top of its own stack." self push: self! ! !ContextPart methodsFor: 'instruction decoding'! pushConstant: value "Simulate the action of bytecode that pushes the constant, value, on the top of the stack." self push: value! ! !ContextPart methodsFor: 'instruction decoding'! pushLiteralVariable: value "Simulate the action of bytecode that pushes the contents of the literal variable whose index is the argument, index, on the top of the stack." self push: value value! ! !ContextPart methodsFor: 'instruction decoding'! pushReceiver "Simulate the action of bytecode that pushes the active context's receiver on the top of the stack." self push: self receiver! ! !ContextPart methodsFor: 'instruction decoding'! pushReceiverVariable: offset "Simulate the action of bytecode that pushes the contents of the receiver's instance variable whose index is the argument, index, on the top of the stack." self push: (self receiver instVarAt: offset + 1)! ! !ContextPart methodsFor: 'instruction decoding'! pushTemporaryVariable: offset "Simulate the action of bytecode that pushes the contents of the temporary variable whose index is the argument, index, on the top of the stack." self push: (self home at: offset + 1)! ! !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: 'instruction decoding'! storeIntoLiteralVariable: value "Simulate the action of bytecode that stores the top of the stack into a literal variable of my method." value value: self top! ! !ContextPart methodsFor: 'instruction decoding'! storeIntoReceiverVariable: offset "Simulate the action of bytecode that stores the top of the stack into an instance variable of my receiver." self receiver instVarAt: offset + 1 put: self top! ! !ContextPart methodsFor: 'instruction decoding'! storeIntoTemporaryVariable: offset "Simulate the action of bytecode that stores the top of the stack into one of my temporary variables." self home at: offset + 1 put: self top! ! !ContextPart methodsFor: 'debugger access'! depthBelow: aContext "Answer how many calls there are between this and aContext." | this depth | this _ self. depth _ 0. [this == aContext or: [this == nil]] whileFalse: [this _ this sender. depth _ depth + 1]. ^depth! ! !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'! pc "Answer the index of the next bytecode to be executed." ^pc! ! !ContextPart methodsFor: 'debugger access'! release "Remove information from the receiver and all of the contexts on its sender chain in order to break circularities." self releaseTo: nil! ! !ContextPart methodsFor: 'debugger access'! releaseTo: caller "Remove information from the receiver and the contexts on its sender chain up to caller in order to break circularities." | c s | c _ self. [c == nil or: [c == caller]] whileFalse: [s _ c sender. c singleRelease. c _ s]! ! !ContextPart methodsFor: 'debugger access'! selector "Answer the selector of the method that created the receiver." ^self receiver class selectorAtMethod: self method setClass: [:ignored]! ! !ContextPart methodsFor: 'debugger access'! sender "Answer the context that sent the message that created the receiver." ^sender! ! !ContextPart methodsFor: 'debugger access' stamp: 'tk 4/16/1998 12:00'! shortStack "Answer a String showing the top four contexts on my sender chain." | shortStackStream | shortStackStream _ WriteStream on: (String new: 55*10). (self stackOfSize: 10) do: [:item | shortStackStream print: item; cr]. ^shortStackStream contents! ! !ContextPart methodsFor: 'debugger access'! singleRelease "Remove information from the receiver in order to break circularities." stackp == nil ifFalse: [1 to: stackp do: [:i | self at: i put: nil]]. sender _ nil! ! !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'! stack "Answer an Array of the contexts on the receiver's sender chain." ^self stackOfSize: 9999! ! !ContextPart methodsFor: 'debugger access'! stackOfSize: limit "Answer an OrderedCollection of the top 'limit' contexts on the receiver's sender chain." | a stack | stack _ OrderedCollection new. stack addLast: (a _ self). [(a _ a sender) ~~ nil and: [stack size < limit]] whileTrue: [stack addLast: a]. ^ stack! ! !ContextPart methodsFor: 'debugger access'! swapSender: coroutine "Replace the receiver's sender with coroutine and answer the receiver's previous sender. For use in coroutining." | oldSender | oldSender _ sender. sender _ coroutine. ^oldSender! ! !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: 'debugger access'! tempsAndValues "Return a string of the temporary variabls and their current values" | aStream | aStream _ WriteStream on: (String new: 100). self tempNames doWithIndex: [:title :index | aStream nextPutAll: title; nextPut: $:; space; tab. (self tempAt: index) printOn: aStream. aStream cr]. ^aStream contents! ! !ContextPart methodsFor: 'controlling'! activateMethod: newMethod withArgs: args receiver: rcvr class: class "Answer a ContextPart initialized with the arguments." ^MethodContext sender: self receiver: rcvr method: newMethod arguments: args! ! !ContextPart methodsFor: 'controlling'! blockCopy: numArgs "Primitive. Distinguish a block of code from its enclosing method by creating a new BlockContext for that block. The compiler inserts into all methods that contain blocks the bytecodes to send the message blockCopy:. Do not use blockCopy: in code that you write!! Only the compiler can decide to send the message blockCopy:. Fail if numArgs is not a SmallInteger. Optional. No Lookup. See Object documentation whatIsAPrimitive." ^(BlockContext new: self size) home: self home startpc: pc + 2 nargs: numArgs! ! !ContextPart methodsFor: 'controlling'! hasSender: context "Answer whether the receiver is strictly above context on the stack." | s | self == context ifTrue: [^false]. s _ sender. [s == nil] whileFalse: [s == context ifTrue: [^true]. s _ s sender]. ^false! ! !ContextPart methodsFor: 'controlling'! pop "Answer the top of the receiver's stack and remove the top of the stack." | val | val _ self at: stackp. self at: stackp put: nil. stackp _ stackp - 1. ^val! ! !ContextPart methodsFor: 'controlling'! push: val "Push val on the receiver's stack." self at: (stackp _ stackp + 1) put: val! ! !ContextPart methodsFor: 'controlling'! return: value to: sendr "Simulate the return of value to sendr." self releaseTo: sendr. ^sendr push: value! ! !ContextPart methodsFor: 'controlling'! send: selector to: rcvr with: args super: superFlag "Simulate the action of sending a message with selector, selector, and arguments, args, to receiver. The argument, superFlag, tells whether the receiver of the message was specified with 'super' in the source method." | class meth val | class _ superFlag ifTrue: [(self method literalAt: self method numLiterals) value superclass] ifFalse: [rcvr class]. [class == nil] whileFalse: [(class includesSelector: selector) ifTrue: [meth _ class compiledMethodAt: selector. val _ self tryPrimitiveFor: meth receiver: rcvr args: args. val == #simulatorFail ifFalse: [^val]. (selector == #doesNotUnderstand: and: [class == Object]) ifTrue: [ ^ self error: 'Simulated message ' , (args at: 1) selector , ' not understood' ]. ^self activateMethod: meth withArgs: args receiver: rcvr class: class]. class _ class superclass]. ^self send: #doesNotUnderstand: to: rcvr with: (Array with: (Message selector: selector arguments: args)) super: superFlag! ! !ContextPart methodsFor: 'controlling'! top "Answer the top of the receiver's stack." ^self at: stackp! ! !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: 'di 1/5/98 11:20'! completeCallee: aContext "Simulate the execution of bytecodes until a return to the receiver." | ctxt current | ctxt _ aContext. [ctxt == current or: [ctxt hasSender: self]] whileTrue: [current _ ctxt. ctxt _ ctxt step]. self stepToSendOrReturn! ! !ContextPart methodsFor: 'system simulation' stamp: 'di 1/5/98 11:20'! runSimulated: aBlock contextAtEachStep: block2 "Simulate the execution of the argument, aBlock, until it ends. aBlock MUST NOT contain an '^'. Evaluate block2 with the current context prior to each instruction executed. Answer the simulated value of aBlock." | current | aBlock hasMethodReturn ifTrue: [self error: 'simulation of blocks with ^ can run loose']. current _ aBlock. current pushArgs: Array new from: self. [current == self] whileFalse: [block2 value: current. current _ current step]. ^self pop! ! !ContextPart methodsFor: 'system simulation'! step "Simulate the execution of the receiver's next bytecode. Answer the context that would be the active context after this bytecode." ^self interpretNextInstructionFor: self! ! !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' stamp: 'di 1/4/98 23:16'! 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 " | 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]. value _ receiver tryPrimitive: primitiveIndex withArgs: arguments. value == #simulatorFail ifTrue: [^ #simulatorFail] ifFalse: [^ self push: value]! ! !ContextPart methodsFor: 'private'! pop: numObjects toAddable: anAddableCollection "Pop the top numObjects elements from the stack, and store them in anAddableCollection, topmost element last. Do not call directly. Called indirectly by {1. 2. 3} constructs." | oldTop i | i _ stackp _ (oldTop _ stackp) - numObjects. [(i _ i + 1) <= oldTop] whileTrue: [anAddableCollection add: (self at: i). self at: i put: nil]! ! !ContextPart methodsFor: 'private'! pop: numObjects toIndexable: anIndexableCollection "Pop the top numObjects elements from the stack, and store them in anIndexableCollection, topmost element last. Do not call directly. Called indirectly by {1. 2. 3} constructs." | oldTop i | i _ stackp _ (oldTop _ stackp) - numObjects. [(i _ i + 1) <= oldTop] whileTrue: [anIndexableCollection at: i-stackp put: (self at: i). self at: i put: nil]! ! !ContextPart methodsFor: 'private'! push: numObjects fromIndexable: anIndexableCollection "Push the elements of anIndexableCollection onto the receiver's stack. Do not call directly. Called indirectly by {1. 2. 3} constructs." | i | i _ 0. [(i _ i + 1) <= numObjects] whileTrue: [self at: (stackp _ stackp + 1) put: (anIndexableCollection at: i)]! ! !ContextPart methodsFor: 'private'! stackPtr "For use only by the SystemTracer" ^ stackp! ! !ContextPart methodsFor: 'private'! tryPrimitiveFor: method receiver: receiver args: arguments "Simulate a primitive method, method for the receiver and arguments given as arguments to this message. Answer resuming the context if successful, else answer the symbol, #simulatorFail." | flag primIndex | (primIndex _ method primitive) = 0 ifTrue: [^#simulatorFail]. ^ self doPrimitive: primIndex receiver: receiver args: arguments! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ContextPart class instanceVariableNames: ''! !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! ! !ContextPart class methodsFor: 'simulation'! runSimulated: aBlock "Simulate the execution of the argument, current. Answer the result it returns." ^ thisContext sender runSimulated: aBlock contextAtEachStep: [:ignored] "ContextPart runSimulated: [Pen new defaultNib: 5; go: 100]"! ! Inspector subclass: #ContextVariablesInspector instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Interface-Debugger'! !ContextVariablesInspector commentStamp: 'di 5/22/1998 16:33' prior: 0! ContextVariablesInspector comment: 'I represent a query path into the internal representation of a ContextPart. Typically this is a context at a point in the query path of a Debugger. As a StringHolder, the string I represent is the value of the currently selected variable of the observed temporary variable of the context.'! !ContextVariablesInspector methodsFor: 'accessing'! fieldList "Refer to the comment in Inspector|fieldList." object == nil ifTrue: [^Array with: 'thisContext']. ^(Array with: 'thisContext' with: 'all temp vars') , object tempNames! ! !ContextVariablesInspector methodsFor: 'accessing' stamp: 'sw 9/12/97 21:47'! selectedSlotName ^ object tempNames at: (self selectionIndex - 2)! ! !ContextVariablesInspector methodsFor: 'selecting'! replaceSelectionValue: anObject "Refer to the comment in Inspector|replaceSelectionValue:." selectionIndex = 1 ifTrue: [^object] ifFalse: [^object tempAt: selectionIndex - 2 put: anObject]! ! !ContextVariablesInspector methodsFor: 'selecting'! selection "Refer to the comment in Inspector|selection." selectionIndex = 1 ifTrue: [^object]. selectionIndex = 2 ifTrue: [^object tempsAndValues] ifFalse: [^object tempAt: selectionIndex - 2]! ! !ContextVariablesInspector methodsFor: 'code'! doItContext ^object! ! !ContextVariablesInspector methodsFor: 'code'! doItReceiver ^object receiver! ! Object subclass: #ControlManager instanceVariableNames: 'scheduledControllers activeController activeControllerProcess screenController newTopClicked ' classVariableNames: 'CmdDotEnabled ' poolDictionaries: '' category: 'Interface-Framework'! !ControlManager commentStamp: 'di 5/22/1998 16:33' prior: 0! ControlManager comment: 'I represent the top level control over scheduling which controller of a view on the screen the user is actively using. ScheduledControllers is the global reference to an instance of me, the one attached to the Project currently being used.'! !ControlManager methodsFor: 'initialize-release'! initialize "Initialize the receiver to refer to only the background controller." | screenView | screenController _ ScreenController new. screenView _ FormView new. screenView model: (InfiniteForm with: Color gray) controller: screenController. screenView window: Display boundingBox. scheduledControllers _ OrderedCollection with: screenController! ! !ControlManager methodsFor: 'initialize-release'! release "Refer to the comment in Object|release." scheduledControllers == nil ifFalse: [scheduledControllers do: [:controller | (controller isKindOf: Controller) ifTrue: [controller view release] ifFalse: [controller release]]. scheduledControllers _ nil]! ! !ControlManager methodsFor: 'accessing'! activeController "Answer the currently active controller." ^activeController! ! !ControlManager methodsFor: 'accessing'! activeController: aController "Set aController to be the currently active controller. Give the user control in it." activeController _ aController. (activeController == screenController) ifFalse: [self promote: activeController]. activeControllerProcess _ [activeController startUp. self searchForActiveController] newProcess. activeControllerProcess priority: Processor userSchedulingPriority. activeControllerProcess resume! ! !ControlManager methodsFor: 'accessing'! activeControllerNoTerminate: aController andProcess: aProcess "Set aController to be the currently active controller and aProcess to be the the process that handles controller scheduling activities in the system. This message differs from activeController:andProcess: in that it does not send controlTerminate to the currently active controller." self inActiveControllerProcess ifTrue: [aController~~nil ifTrue: [(scheduledControllers includes: aController) ifTrue: [self promote: aController] ifFalse: [self error: 'Old controller not scheduled']]. activeController _ aController. activeController == nil ifFalse: [activeController controlInitialize]. activeControllerProcess _ aProcess. activeControllerProcess resume] ifFalse: [self error: 'New active controller process must be set from old one'] ! ! !ControlManager methodsFor: 'accessing'! activeControllerProcess "Answer the process that is currently handling controller scheduling activities in the system." ^activeControllerProcess! ! !ControlManager methodsFor: 'accessing'! controllerSatisfying: aBlock "Return the first scheduled controller which satisfies the 1-argument boolean-valued block, or nil if none. 7/25/96 sw" scheduledControllers do: [:aController | (aBlock value: aController) == true ifTrue: [^ aController]]. ^ nil! ! !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'! controllerWhoseModelSatisfies: aBlock "Return the first scheduled controller whose model satisfies the 1-argument boolean-valued block, or nil if none. 5/6/96 sw" scheduledControllers do: [:aController | (aBlock value: aController model) == true ifTrue: [^ aController]]. ^ nil! ! !ControlManager methodsFor: 'accessing'! includes: aController ^ scheduledControllers includes: aController! ! !ControlManager methodsFor: 'accessing'! noteNewTop newTopClicked _ 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'! scheduledControllers "Answer a copy of the ordered collection of scheduled controllers." ^scheduledControllers copy! ! !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: 'accessing'! screenController ^ screenController! ! !ControlManager methodsFor: 'accessing'! windowOriginsInUse "Answer a collection of the origins of windows currently on the screen in the current project. 5/21/96 sw" ^ self scheduledWindowControllers collect: [:aController | aController view displayBox origin].! ! !ControlManager methodsFor: 'scheduling'! activateController: aController "Make aController, which must already be a scheduled controller, the active window. 5/8/96 sw" self activeController: aController. (activeController view labelDisplayBox intersect: Display boundingBox) area < 200 ifTrue: [activeController move]. Processor terminateActive! ! !ControlManager methodsFor: 'scheduling'! activateTranscript "There is known to be a Transcript open in the current project; activate it. 2/5/96 sw" | itsController | itsController _ scheduledControllers detect: [:controller | controller model == Transcript] ifNone: [^ self]. self activeController: itsController. (activeController view labelDisplayBox intersect: Display boundingBox) area < 200 ifTrue: [activeController move]. Processor terminateActive! ! !ControlManager methodsFor: 'scheduling' stamp: 'sw 9/30/97 13:26'! cmdDotEnabled ^ CmdDotEnabled ~~ false! ! !ControlManager methodsFor: 'scheduling' stamp: 'sw 9/30/97 13:26'! cmdDotEnabled: aBoolean CmdDotEnabled _ aBoolean! ! !ControlManager methodsFor: 'scheduling' stamp: 'di 5/19/1998 09:03'! findWindow "Present a menu of window titles, and activate the one that gets chosen." ^ self findWindowSatisfying: [:c | true]! ! !ControlManager methodsFor: 'scheduling' stamp: 'sw 10/12/97 21:48'! findWindowSatisfying: aBlock "Present a menu of window titles, and activate the one that gets chosen" | controllers labels index listToUse sortAlphabetically | sortAlphabetically _ Sensor optionKeyPressed. controllers _ OrderedCollection new. scheduledControllers do: [:controller | controller == screenController ifFalse: [(aBlock value: controller) ifTrue: [controllers addLast: controller]]]. controllers size == 0 ifTrue: [^ self]. listToUse _ sortAlphabetically ifTrue: [controllers asSortedCollection: [:a :b | a view label < b view label]] ifFalse: [controllers]. labels _ String streamContents: [:strm | listToUse do: [:controller | strm nextPutAll: (controller view label contractTo: 40); cr]. strm skip: -1 "drop last cr"]. index _ (PopUpMenu labels: labels) startUp. index > 0 ifTrue: [self activateController: (controllers at: index)]! ! !ControlManager methodsFor: 'scheduling'! inActiveControllerProcess "Answer whether the active scheduling process is the actual active process in the system." ^activeControllerProcess == Processor activeProcess! ! !ControlManager methodsFor: 'scheduling' stamp: 'tk 4/16/1998 15:38'! 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 _ (Debugger openInterrupt: labelString onProcess: activeControllerProcess) controller. newActiveController centerCursorInView. self activeController: newActiveController. ! ! !ControlManager methodsFor: 'scheduling' stamp: 'sw 9/30/97 13:27'! maybeForkInterrupt self cmdDotEnabled ifTrue: [[self interruptName: 'User Interrupt'] fork]! ! !ControlManager methodsFor: 'scheduling'! promote: aController "Make aController be the first scheduled controller in the ordered collection." scheduledControllers remove: aController. scheduledControllers addFirst: aController! ! !ControlManager methodsFor: 'scheduling'! scheduleActive: aController "Make aController be scheduled as the active controller. Presumably the active scheduling process asked to schedule this controller and that a new process associated this controller takes control. So this is the last act of the active scheduling process." self scheduleActiveNoTerminate: aController. Processor terminateActive! ! !ControlManager methodsFor: 'scheduling'! scheduleActiveNoTerminate: aController "Make aController be the active controller. Presumably the process that requested the new active controller wants to keep control to do more activites before the new controller can take control. Therefore, do not terminate the currently active process." self schedulePassive: aController. self scheduled: aController from: Processor activeProcess! ! !ControlManager methodsFor: 'scheduling'! scheduleOnBottom: aController "Make aController be scheduled as a scheduled controller, but not the active one. Put it at the end of the ordered collection of controllers." scheduledControllers addLast: aController! ! !ControlManager methodsFor: 'scheduling'! schedulePassive: aController "Make aController be scheduled as a scheduled controller, but not the active one. Put it at the beginning of the ordered collection of controllers." scheduledControllers addFirst: aController! ! !ControlManager methodsFor: 'scheduling'! searchForActiveController "Find a scheduled controller that wants control and give control to it. If none wants control, then see if the System Menu has been requested." | aController | activeController _ nil. activeControllerProcess _ Processor activeProcess. self activeController: self nextActiveController. Processor terminateActive! ! !ControlManager methodsFor: 'scheduling'! unschedule: aController "Remove the view, aController, from the collection of scheduled controllers." scheduledControllers remove: aController ifAbsent: []! ! !ControlManager methodsFor: 'scheduling'! windowFromUser "Present a menu of window titles, and returns the StandardSystemController belonging to the one that gets chosen, or nil if none" | controllers labels index | controllers _ OrderedCollection new. labels _ String streamContents: [:strm | scheduledControllers do: [:controller | controller == screenController ifFalse: [controllers addLast: controller. strm nextPutAll: (controller view label contractTo: 40); cr]]. strm skip: -1 "drop last cr"]. index _ (PopUpMenu labels: labels) startUp. ^ index > 0 ifTrue: [controllers at: index] ifFalse: [nil]! ! !ControlManager methodsFor: 'displaying'! backgroundForm: aForm screenController view model: aForm. ScheduledControllers restore " QDPen new mandala: 30 diameter: 640. ScheduledControllers backgroundForm: (Form fromDisplay: Display boundingBox). ScheduledControllers backgroundForm: (InfiniteForm with: Form gray). "! ! !ControlManager methodsFor: 'displaying' stamp: 'di 2/26/98 08:58'! 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'! restore: aRectangle "Restore all windows visible in aRectangle" ^ self restore: aRectangle below: 1 without: nil! ! !ControlManager methodsFor: 'displaying'! restore: aRectangle below: index without: aView "Restore all windows visible in aRectangle, but without aView" | view | view _ (scheduledControllers at: index) view. view == aView ifTrue: [index >= scheduledControllers size ifTrue: [^ self]. ^ self restore: aRectangle below: index+1 without: aView]. view displayOn: ((BitBlt toForm: Display) clipRect: aRectangle). index >= scheduledControllers size ifTrue: [^ self]. (aRectangle areasOutside: view windowBox) do: [:rect | self restore: rect below: index + 1 without: aView]! ! !ControlManager methodsFor: 'displaying'! restore: aRectangle without: aView "Restore all windows visible in aRectangle" ^ self restore: aRectangle below: 1 without: aView! ! !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 methodsFor: 'private'! nextActiveController "Answer the controller that would like control. If there was a click outside the active window, it's the top window that now has the mouse, otherwise it's just the top window." (newTopClicked notNil and: [newTopClicked]) ifTrue: [newTopClicked _ false. ^ scheduledControllers detect: [:aController | aController isControlWanted] ifNone: [scheduledControllers first]] ifFalse: [^ scheduledControllers first]! ! !ControlManager methodsFor: 'private'! scheduled: aController from: aProcess activeControllerProcess==aProcess ifTrue: [activeController ~~ nil ifTrue: [activeController controlTerminate]. aController centerCursorInView. self activeController: aController]! ! !ControlManager methodsFor: 'private'! unCacheWindows scheduledControllers do: [:aController | aController view uncacheBits]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ControlManager class instanceVariableNames: ''! !ControlManager class methodsFor: 'instance creation' stamp: 'sw 9/30/97 13:25'! initialize "ControlManager initialize" CmdDotEnabled _ true! ! !ControlManager class methodsFor: 'instance creation'! new ^super new initialize! ! !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! ! !ControlManager class methodsFor: 'snapshots'! startUp ScheduledControllers restore! ! Object subclass: #Controller instanceVariableNames: 'model view sensor ' classVariableNames: '' poolDictionaries: '' category: 'Interface-Framework'! !Controller commentStamp: 'di 5/22/1998 16:33' prior: 0! Controller comment: 'A Controller coordinates a View, its model, and user actions. It provides scheduling (control) behavior to determine when the user wants to communicate with the model or view.'! !Controller methodsFor: 'initialize-release'! initialize "Initialize the state of the receiver. Subclasses should include 'super initialize' when redefining this message to insure proper initialization." sensor _ InputSensor default! ! !Controller methodsFor: 'initialize-release'! release "Breaks the cycle between the receiver and its view. It is usually not necessary to send release provided the receiver's view has been properly released independently." model _ nil. view ~~ nil ifTrue: [view controller: nil. view _ nil]! ! !Controller methodsFor: 'model access'! model "Answer the receiver's model which is the same as the model of the receiver's view." ^model! ! !Controller methodsFor: 'model access'! model: aModel "Controller|model: and Controller|view: are sent by View|controller: in order to coordinate the links between the model, view, and controller. In ordinary usage, the receiver is created and passed as the parameter to View|controller: so that the receiver's model and view links can be set up by the view." model _ aModel! ! !Controller methodsFor: 'view access'! inspectView view notNil ifTrue: [^ view inspect]! ! !Controller methodsFor: 'view access'! view "Answer the receiver's view." ^view! ! !Controller methodsFor: 'view access'! view: aView "Controller|view: and Controller|model: are sent by View|controller: in order to coordinate the links between the model, view, and controller. In ordinary usage, the receiver is created and passed as the parameter to View|controller: and the receiver's model and view links are set up automatically by the view." view _ aView! ! !Controller methodsFor: 'sensor access'! sensor "Answer the receiver's sensor. Subclasses may use other objects that are not instances of Sensor or its subclasses if more general kinds of input/output functions are required." ^sensor! ! !Controller methodsFor: 'sensor access'! sensor: aSensor "Set the receiver's sensor to aSensor." sensor _ aSensor! ! !Controller methodsFor: 'basic control sequence'! controlInitialize "Sent by Controller|startUp as part of the standard control sequence, it provides a place in the standard control sequence for initializing the receiver (taking into account the current state of its model and view). It should be redefined in subclasses to perform some specific action." ^self! ! !Controller methodsFor: 'basic control sequence'! controlLoop "Sent by Controller|startUp as part of the standard control sequence. Controller|controlLoop sends the message Controller|isControlActive to test for loop termination. As long as true is returned, the loop continues. When false is returned, the loop ends. Each time through the loop, the message Controller|controlActivity is sent." [self isControlActive] whileTrue: [self controlActivity. Processor yield]! ! !Controller methodsFor: 'basic control sequence'! controlTerminate "Provide a place in the standard control sequence for terminating the receiver (taking into account the current state of its model and view). It should be redefined in subclasses to perform some specific action." ^self! ! !Controller methodsFor: 'basic control sequence'! startUp "Give control to the receiver. The default control sequence is to initialize (see Controller|controlInitialize), to loop (see Controller|controlLoop), and then to terminate (see Controller|controlTerminate). After this sequence, control is returned to the sender of Control|startUp. The receiver's control sequence is used to coordinate the interaction of its view and model. In general, this consists of polling the sensor for user input, testing the input with respect to the current display of the view, and updating the model to reflect intended changes." self controlInitialize. self controlLoop. self controlTerminate! ! !Controller methodsFor: 'basic control sequence'! terminateAndInitializeAround: aBlock "1/12/96 sw" self controlTerminate. aBlock value. self controlInitialize! ! !Controller methodsFor: 'control defaults'! controlActivity "Pass control to the next control level (that is, to the Controller of a subView of the receiver's view) if possible. It is sent by Controller|controlLoop each time through the main control loop. It should be redefined in a subclass if some other action is needed." self controlToNextLevel! ! !Controller methodsFor: 'control defaults'! controlToNextLevel "Pass control to the next control level (that is, to the Controller of a subView of the receiver's view) if possible. The receiver finds the subView (if any) of its view whose inset display box (see View|insetDisplayBox) contains the sensor's cursor point. The Controller of this subView is then given control if it answers true in response to the message Controller|isControlWanted." | aView | aView _ view subViewWantingControl. aView ~~ nil ifTrue: [aView controller startUp]! ! !Controller methodsFor: 'control defaults'! isControlActive "Answer whether receiver wishes to continue evaluating its controlLoop method. It is sent by Controller|controlLoop in order to determine when the receiver's control loop should terminate, and should be redefined in a subclass if some special condition for terminating the main control loop is needed." ^ self viewHasCursor & sensor blueButtonPressed not & sensor yellowButtonPressed not "& sensor cmdKeyPressed not"! ! !Controller methodsFor: 'control defaults'! isControlWanted "Answer whether the cursor is inside the inset display box (see View|insetDisplayBox) of the receiver's view. It is sent by Controller|controlNextLevel in order to determine whether or not control should be passed to this receiver from the Controller of the superView of this receiver's view." ^self viewHasCursor! ! !Controller methodsFor: 'cursor'! centerCursorInView "Position sensor's mousePoint (which is assumed to be connected to the cursor) to the center of its view's inset display box (see Sensor|mousePoint: and View|insetDisplayBox)." ^sensor cursorPoint: view insetDisplayBox center! ! !Controller methodsFor: 'cursor'! viewHasCursor "Answer whether the cursor point of the receiver's sensor lies within the inset display box of the receiver's view (see View|insetDisplayBox). Controller|viewHasCursor is normally used in internal methods." ^view containsPoint: sensor cursorPoint! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Controller class instanceVariableNames: ''! !Controller class methodsFor: 'instance creation'! new ^super new initialize! ! Form subclass: #Cursor instanceVariableNames: '' classVariableNames: 'BlankCursor CornerCursor CrossHairCursor CurrentCursor DownCursor MarkerCursor MenuCursor MoveCursor NormalCursor OriginCursor ReadCursor RightArrowCursor SquareCursor UpCursor WaitCursor WriteCursor XeqCursor ' poolDictionaries: '' category: 'Graphics-Display Objects'! !Cursor commentStamp: 'di 5/22/1998 16:33' prior: 0! Cursor comment: 'I am a 16 x 16 dot matrix suitable for use as the Alto hardware cursor.'! !Cursor methodsFor: 'updating'! changed: aParameter self == CurrentCursor ifTrue: [self beCursor]. super changed: aParameter! ! !Cursor methodsFor: 'displaying'! beCursor "Primitive. Tell the interpreter to use the receiver as the current cursor image. Fail if the receiver does not match the size expected by the hardware. Essential. See Object documentation whatIsAPrimitive." self primitiveFailed! ! !Cursor methodsFor: 'displaying'! show "Make the current cursor shape be the receiver." Sensor currentCursor: self! ! !Cursor methodsFor: 'displaying'! showGridded: gridPoint "Make the current cursor shape be the receiver, forcing the location of the cursor to the point nearest gridPoint." Sensor cursorPoint: (Sensor cursorPoint grid: gridPoint). Sensor currentCursor: self! ! !Cursor methodsFor: 'displaying'! showWhile: aBlock "While evaluating the argument, aBlock, make the receiver be the cursor shape." | oldcursor value | oldcursor _ Sensor currentCursor. self show. value _ aBlock value. oldcursor show. ^value! ! !Cursor methodsFor: 'printing'! printOn: aStream self storeOn: aStream base: 2! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Cursor class instanceVariableNames: ''! !Cursor class methodsFor: 'class initialization'! initCorner CornerCursor _ (Cursor extent: 16@16 fromArray: #( 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r1111111111111111 2r1111111111111111) offset: -16@-16). ! ! !Cursor class methodsFor: 'class initialization'! initCrossHair CrossHairCursor _ (Cursor extent: 16@16 fromArray: #( 2r0000000100000000 2r0000000100000000 2r0000000100000000 2r0000000100000000 2r0000000100000000 2r0000000100000000 2r0000000100000000 2r1111111111111110 2r0000000100000000 2r0000000100000000 2r0000000100000000 2r0000000100000000 2r0000000100000000 2r0000000100000000 2r0000000100000000 2r0) offset: -7@-7). ! ! !Cursor class methodsFor: 'class initialization'! initDown DownCursor _ (Cursor extent: 16@16 fromArray: #( 2r11000000000000 2r11000000000000 2r11000000000000 2r11000000000000 2r11000000000000 2r11000000000000 2r11000000000000 2r1111110000000000 2r111100000000000 2r11000000000000 2r0 2r0 2r0 2r0 2r0 2r0) offset: 0@0). ! ! !Cursor class methodsFor: 'class initialization'! initialize "Create all the standard cursors Cursor origin Cursor rightArrow Cursor menu Cursor corner Cursor read Cursor write Cursor wait Cursor blank Cursor xeq Cursor square Cursor normal Cursor crossHair Cursor marker Cursor up Cursor down Cursor move" self initOrigin. self initRightArrow. self initMenu. self initCorner. self initRead. self initWrite. self initWait. BlankCursor _ Cursor new. self initXeq. self initSquare. self initNormal. self initCrossHair. self initMarker. self initUp. self initDown. self initMove. "Cursor initialize" ! ! !Cursor class methodsFor: 'class initialization'! initMarker MarkerCursor _ Cursor extent: 16@16 fromArray: #( 2r0111000000000000 2r1111100000000000 2r1111100000000000 2r0111000000000000 2r0 2r0 2r0 2r0 2r0 2r0 2r0 2r0 2r0 2r0 2r0 2r0) offset: 0@0. ! ! !Cursor class methodsFor: 'class initialization'! initMenu MenuCursor _ (Cursor extent: 16@16 fromArray: #( 2r1111111111100000 2r1000000000100000 2r1010011000100000 2r1000000000100000 2r1011001010100000 2r1000000000100000 2r1010110010100000 2r1000000000100000 2r1010010100100000 2r1000000000100000 2r1111111111100000 2r1101001101100000 2r1111111111100000 2r1000000000100000 2r1010101100100000 2r1111111111100000) offset: 0@0). ! ! !Cursor class methodsFor: 'class initialization'! initMove MoveCursor _ Cursor extent: 16@16 fromArray: #( 2r1111111111111111 2r1111111111111111 2r1100000110000011 2r1100000110000011 2r1100000110000011 2r1100000110000011 2r1100000110000011 2r1111111111111111 2r1111111111111111 2r1100000110000011 2r1100000110000011 2r1100000110000011 2r1100000110000011 2r1100000110000011 2r1111111111111111 2r1111111111111111) offset: 0@0. ! ! !Cursor class methodsFor: 'class initialization'! initNormal NormalCursor _ (Cursor extent: 16@16 fromArray: #( 2r1000000000000000 2r1100000000000000 2r1110000000000000 2r1111000000000000 2r1111100000000000 2r1111110000000000 2r1111111000000000 2r1111100000000000 2r1111100000000000 2r1001100000000000 2r0000110000000000 2r0000110000000000 2r0000011000000000 2r0000011000000000 2r0000001100000000 2r0000001100000000) offset: 0@0). ! ! !Cursor class methodsFor: 'class initialization'! initOrigin OriginCursor _ (Cursor extent: 16@16 fromArray: #( 2r1111111111111111 2r1111111111111111 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000) offset: 0@0). ! ! !Cursor class methodsFor: 'class initialization'! initRead ReadCursor _ (Cursor extent: 16@16 fromArray: #( 2r0000110000000110 2r0001001000001001 2r0001001000001001 2r0010000000010000 2r0100000000100000 2r1111101111100000 2r1000010000100000 2r1000010000100000 2r1011010110100000 2r0111101111000000 2r0 2r0 2r0 2r0 2r0 2r0) offset: 0@0). ! ! !Cursor class methodsFor: 'class initialization'! initRightArrow RightArrowCursor _ (Cursor extent: 16@16 fromArray: #( 2r100000000000 2r111000000000 2r1111111110000000 2r111000000000 2r100000000000 2r0 2r0 2r0 2r0 2r0 2r0 2r0 2r0 2r0 2r0 2r0) offset: 0@0). "Cursor initRightArrow"! ! !Cursor class methodsFor: 'class initialization'! initSquare SquareCursor _ (Cursor extent: 16@16 fromArray: #( 2r0 2r0 2r0 2r0 2r0 2r0000001111000000 2r0000001111000000 2r0000001111000000 2r0000001111000000 2r0 2r0 2r0 2r0 2r0 2r0 2r0) offset: -8@-8). ! ! !Cursor class methodsFor: 'class initialization'! initUp UpCursor _ (Cursor extent: 16@16 fromArray: #( 2r11000000000000 2r111100000000000 2r1111110000000000 2r11000000000000 2r11000000000000 2r11000000000000 2r11000000000000 2r11000000000000 2r11000000000000 2r11000000000000 2r0 2r0 2r0 2r0 2r0 2r0) offset: 0@0). ! ! !Cursor class methodsFor: 'class initialization'! initWait WaitCursor _ (Cursor extent: 16@16 fromArray: #( 2r1111111111111111 2r1000000000000001 2r0100000000000010 2r0010000000000100 2r0001110000111000 2r0000111101110000 2r0000011011100000 2r0000001111000000 2r0000001111000000 2r0000010110100000 2r0000100010010000 2r0001000110001000 2r0010001101000100 2r0100111111110010 2r1011111111111101 2r1111111111111111) offset: 0@0). ! ! !Cursor class methodsFor: 'class initialization'! initWrite WriteCursor _ (Cursor extent: 16@16 fromArray: #( 2r0000000000000110 2r0000000000001111 2r0000000000010110 2r0000000000100100 2r0000000001001000 2r0000000010010000 2r0000000100100000 2r0000001001000011 2r0000010010000010 2r0000100100000110 2r0001001000001000 2r0010010000001000 2r0111100001001000 2r0101000010111000 2r0110000110000000 2r1111111100000000) offset: 0@0). ! ! !Cursor class methodsFor: 'class initialization'! initXeq XeqCursor _ (Cursor extent: 16@16 fromArray: #( 2r1000000000010000 2r1100000000010000 2r1110000000111000 2r1111000111111111 2r1111100011000110 2r1111110001000100 2r1111111001111100 2r1111000001101100 2r1101100011000110 2r1001100010000010 2r0000110000000000 2r0000110000000000 2r0000011000000000 2r0000011000000000 2r0000001100000000 2r0000001100000000) offset: 0@0). ! ! !Cursor class methodsFor: 'class initialization'! startUp self currentCursor: self currentCursor! ! !Cursor class methodsFor: 'instance creation'! extent: extentPoint fromArray: anArray offset: offsetPoint "Answer a new instance of me with width and height specified by extentPoint, offset by offsetPoint, and bits from anArray. NOTE: This has been kluged to take an array of 16-bit constants, and shift them over so they are left-justified in a 32-bit bitmap" extentPoint = (16 @ 16) ifTrue: [^ super extent: extentPoint fromArray: (anArray collect: [:bits | bits bitShift: 16]) offset: offsetPoint] ifFalse: [self error: 'cursors must be 16@16']! ! !Cursor class methodsFor: 'instance creation'! new ^self extent: 16 @ 16 fromArray: Array new offset: 0 @ 0 "Cursor new bitEdit show"! ! !Cursor class methodsFor: 'current cursor'! currentCursor "Answer the instance of Cursor that is the one currently displayed." ^CurrentCursor! ! !Cursor class methodsFor: 'current cursor'! currentCursor: aCursor "Make the instance of cursor, aCursor, be the current cursor. Display it. Create an error if the argument is not a Cursor." aCursor class == self ifTrue: [CurrentCursor _ aCursor. aCursor beCursor] ifFalse: [self error: 'The new cursor must be an instance of class Cursor']! ! !Cursor class methodsFor: 'constants'! blank "Answer the instance of me that is all white." ^BlankCursor! ! !Cursor class methodsFor: 'constants'! bottomLeft "Cursor bottomLeft showWhile: [Sensor waitButton]" ^ (Cursor extent: 16@16 fromArray: #( 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1111111111111111 2r1111111111111111) offset: 0@-16). ! ! !Cursor class methodsFor: 'constants'! bottomRight "Cursor bottomRight showWhile: [Sensor waitButton]" ^ (Cursor extent: 16@16 fromArray: #( 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r1111111111111111 2r1111111111111111) offset: -16@-16). ! ! !Cursor class methodsFor: 'constants'! corner "Answer the instance of me that is the shape of the bottom right corner of a rectangle." ^CornerCursor! ! !Cursor class methodsFor: 'constants'! crossHair "Answer the instance of me that is the shape of a cross." ^CrossHairCursor! ! !Cursor class methodsFor: 'constants'! down "Answer the instance of me that is the shape of an arrow facing downward." ^DownCursor! ! !Cursor class methodsFor: 'constants'! execute "Answer the instance of me that is the shape of an arrow slanted left with a star next to it." ^XeqCursor! ! !Cursor class methodsFor: 'constants'! marker "Answer the instance of me that is the shape of a small ball." ^MarkerCursor! ! !Cursor class methodsFor: 'constants'! menu "Answer the instance of me that is the shape of a menu." ^MenuCursor! ! !Cursor class methodsFor: 'constants'! move "Answer the instance of me that is the shape of a cross inside a square." ^MoveCursor! ! !Cursor class methodsFor: 'constants'! normal "Answer the instance of me that is the shape of an arrow slanted left." ^NormalCursor! ! !Cursor class methodsFor: 'constants'! origin "Answer the instance of me that is the shape of the top left corner of a rectangle." ^OriginCursor! ! !Cursor class methodsFor: 'constants'! read "Answer the instance of me that is the shape of eyeglasses." ^ReadCursor! ! !Cursor class methodsFor: 'constants'! rightArrow "Answer the instance of me that is the shape of an arrow pointing to the right." ^RightArrowCursor! ! !Cursor class methodsFor: 'constants'! square "Answer the instance of me that is the shape of a square." ^SquareCursor! ! !Cursor class methodsFor: 'constants'! topLeft "Cursor topLeft showWhile: [Sensor waitButton]" ^ (Cursor extent: 16@16 fromArray: #( 2r1111111111111111 2r1111111111111111 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000) offset: 0@0). ! ! !Cursor class methodsFor: 'constants'! topRight "Cursor topRight showWhile: [Sensor waitButton]" ^ (Cursor extent: 16@16 fromArray: #( 2r1111111111111111 2r1111111111111111 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011) offset: -16@0). ! ! !Cursor class methodsFor: 'constants'! up "Answer the instance of me that is the shape of an arrow facing upward." ^UpCursor! ! !Cursor class methodsFor: 'constants' stamp: 'sw 8/15/97 13:28'! wait "Answer the instance of me that is the shape of an Hourglass (was in the shape of three small balls)." ^WaitCursor! ! !Cursor class methodsFor: 'constants'! write "Answer the instance of me that is the shape of a pen writing." ^WriteCursor! ! Path subclass: #CurveFitter instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Graphics-Paths'! !CurveFitter commentStamp: 'di 5/22/1998 16:33' prior: 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'! displayOn: aDisplayMedium at: aPoint clippingBox: clipRect rule: anInteger fillColor: aForm | pa pb k s p1 p2 p3 line | line _ Line new. line form: self form. collectionOfPoints size < 3 ifTrue: [self error: 'Curve must have three points']. p1 _ self firstPoint. p2 _ self secondPoint. p3 _ self thirdPoint. s _ Path new. s add: p1. pa _ p2 - p1. pb _ p3 - p2. k _ 5 max: pa x abs + pa y abs + pb x abs + pb y abs // 20. "k is a guess as to how many line segments to use to approximate the curve." 1 to: k do: [:i | s add: pa * i // k + p1 * (k - i) + (pb * (i - 1) // k + p2 * (i - 1)) // (k - 1)]. s add: p3. 1 to: s size - 1 do: [:i | line beginPoint: (s at: i). line endPoint: (s at: i + 1). line displayOn: aDisplayMedium at: aPoint clippingBox: clipRect rule: anInteger fillColor: aForm]! ! !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 instanceVariableNames: ''! !CurveFitter class methodsFor: 'instance creation'! new | newSelf | newSelf _ super new: 3. newSelf add: 0@0. newSelf add: 0@0. newSelf add: 0@0. ^newSelf! ! !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"! ! PolygonMorph subclass: #CurveMorph instanceVariableNames: 'coefficients ntfPoint ntlPoint ' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Basic'! !CurveMorph methodsFor: 'private' stamp: 'di 9/26/97 10:31'! addHandles super addHandles. self updateHandles! ! !CurveMorph 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)]]! ! !CurveMorph methodsFor: 'private' stamp: 'di 12/3/97 11:00'! 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 asIntegerPoint]. curveBounds _ curveBounds encompass: p2 asIntegerPoint. ntlPoint _ p1 asIntegerPoint]. ^ curveBounds expandBy: borderWidth+1//2! ! !CurveMorph 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))]! ! !CurveMorph methodsFor: 'private' stamp: 'di 12/4/97 09:45'! isCurve ^ true! ! !CurveMorph methodsFor: 'private' stamp: 'di 11/29/97 20:54'! 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 value: endPoint. beginPoint _ endPoint]. endPoint _ (x _ (coefficients at: 1) at: i+1) @ (y _ (coefficients at: 5) at: i+1). endPointsBlock value: beginPoint value: endPoint. beginPoint _ endPoint]! ! !CurveMorph methodsFor: 'private' stamp: '6/9/97 12:08 di'! nextToFirstPoint "For arrow direction" ^ ntfPoint! ! !CurveMorph methodsFor: 'private' stamp: '6/9/97 12:08 di'! nextToLastPoint "For arrow direction" ^ ntlPoint! ! !CurveMorph methodsFor: 'private' stamp: '6/9/97 13:57 di'! privateMoveBy: delta super privateMoveBy: delta. self computeCurve! ! !CurveMorph methodsFor: 'private' stamp: 'di 1/26/98 23:54'! updateHandles | midPts nextVertIx tweens newVert p2i | midPts _ OrderedCollection new. nextVertIx _ 2. tweens _ OrderedCollection new. self lineSegmentsDo: [:p1 :p2 | p2i _ p2 asIntegerPoint. tweens addLast: p2i. p2i = (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)]].! ! SelectionMenu subclass: #CustomMenu instanceVariableNames: 'labels dividers lastDivider ' classVariableNames: '' poolDictionaries: '' category: 'Interface-Menus'! !CustomMenu commentStamp: 'di 5/22/1998 16:33' prior: 0! 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 addLine After the menu is constructed, it may be invoked with one of the following messages: invoke: initialSelection invoke I 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: 'construction' stamp: 'jm 3/29/98 07:09'! addList: listOfPairs "Add a menu item to the receiver for each pair in the given list of the form ( ). Add a line for each dash (-) in the list." "CustomMenu new addList: #( ('apples' buyApples) ('oranges' buyOranges) - ('milk' buyMilk)); startUp" listOfPairs do: [:pair | #- = pair ifTrue: [self addLine] ifFalse: [self add: pair first action: pair last]]. ! ! !CustomMenu methodsFor: 'construction' stamp: 'jm 5/6/1998 19:47'! labels: aString lines: linesArray selections: selectionsArray "This method allows the receiver to accept old-style SelectionMenu creation messages. It should be used only for backward compatibility during the MVC-to-Morphic transition. New code should be written using the other menu construction protocol such as addList:." | labelList | labelList _ (aString findTokens: String cr) asArray. 1 to: labelList size do: [:i | self add: (labelList at: i) action: (selectionsArray at: i). (linesArray includes: i) ifTrue: [self addLine]]. ! ! !CustomMenu methodsFor: 'invocation' stamp: 'jm 11/17/97 16:54'! 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: [ sel numArgs = 0 ifTrue: [^ targetObject perform: sel] ifFalse: [^ targetObject perform: sel with: nil]]. ^ 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: 'invocation' stamp: 'sw 7/31/97 19:31'! startUpWithCaption: caption "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; use the provided caption" ^ self startUp: nil withCaption: 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 instanceVariableNames: ''! !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! ! Object subclass: #DamageRecorder instanceVariableNames: 'invalidRects totalRepaint ' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Support'! !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' stamp: 'jm 5/22/1998 14:07'! 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." | mergeRect | 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." "Note: The totalRepaint policy has poor behavior when many local rectangles (such as parts of a text selection) force repaint of the entire screen. As an alternative, this code performs a simple merge of all rects whenever there are more than 10." mergeRect _ Rectangle merging: invalidRects. self reset. invalidRects addLast: mergeRect]. "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 instanceVariableNames: ''! !DamageRecorder class methodsFor: 'instance creation'! new ^ super new reset ! ! UpdatingStringMorph subclass: #DataMorph instanceVariableNames: 'dataType status ' classVariableNames: '' poolDictionaries: '' category: 'Experimental-Miscellaneous'! !DataMorph commentStamp: 'di 5/22/1998 16:33' prior: 0! A morph representing data to be borne by a slot encompassing pasteUpMorph, as a step toward a stack/card architecture. This is work in progress, and should be approached with the mose extreme caution.! !DataMorph methodsFor: 'all' stamp: 'sw 5/2/1998 16:55'! becomeField | aStack slotNameChosen | aStack _ self pasteUpMorph assuredCostumee. slotNameChosen _ aStack addSlotNamedLike: self externalName withValue: self valueFromContents. self getSelector: (Utilities getterSelectorFor: slotNameChosen). self putSelector: (Utilities setterSelectorFor: slotNameChosen). self target: aStack. status _ #field. aStack updateAllViewers! ! !DataMorph methodsFor: 'all' stamp: 'sw 5/8/1998 13:41'! dockUpToInstance: anInstance "The enclosing PasteUpMorph's current instance has changed (i.e., a new card is been 'gone to'), so do what is necessary" | oldTarget | self flag: #deferred. "Not ready for use" oldTarget _ target. target _ anInstance. self readFromTarget. contents == nil ifTrue: [contents _ '']. getSelector == nil ifTrue: [self isThisEverCalled]. oldTarget == target ifFalse: [oldTarget updateAllViewers]! ! !DataMorph methodsFor: 'all' stamp: 'sw 5/2/1998 17:18'! drawOn: aCanvas | borderColorToUse | borderColorToUse _ status == #field ifTrue: [Color blue muchLighter] ifFalse: [Color red lighter]. aCanvas frameAndFillRectangle: bounds fillColor: Color blue veryMuchLighter borderWidth: 1 borderColor: borderColorToUse. super drawOn: aCanvas.! ! !DataMorph methodsFor: 'all' stamp: 'sw 4/27/1998 19:04'! holdsDataForEachInstance ^ status == #field! ! !DataMorph methodsFor: 'all' stamp: 'sw 5/6/1998 16:32'! initializeAsAuthoringPrototypeOfType: typeSymbol dataType _ typeSymbol. typeSymbol == #string ifTrue: [self useStringFormat] ifFalse: [self useDefaultFormat]. status _ #field. lastValue _ contents _ 'Data'. self setNameTo: 'field'! ! !DataMorph methodsFor: 'all' stamp: 'sw 5/6/1998 16:41'! setLiteral: anObject "Like much else here, not yet in service" dataType _ #literal. lastValue _ anObject. contents _ anObject ! ! !DataMorph methodsFor: 'all' stamp: 'sw 4/27/1998 16:58'! wantsKeyboardFocusFor: aSubmorph ^ self inPartsBin not! ! !DataMorph methodsFor: 'all' stamp: 'sw 5/6/1998 16:33'! wouldAcceptKeyboardFocus ^ self inPartsBin not! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! DataMorph class instanceVariableNames: ''! !DataMorph class methodsFor: 'as yet unclassified' stamp: 'sw 4/27/1998 16:32'! authoringPrototype ^ self new initializeAsAuthoringPrototypeOfType: #string! ! Stream subclass: #DataStream instanceVariableNames: 'byteStream topCall basePos ' classVariableNames: 'TypeMap ' poolDictionaries: '' category: 'System-Object Storage'! !DataStream commentStamp: 'di 5/22/1998 16:33' prior: 0! 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 a ReferenceStream instead of a DataStream. (Or SmartRefStream.) ReferenceStream is typically faster 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: . rr close. To get it back: rr _ ReferenceStream fileNamed: ''test.obj''. _ 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: size NOTE: A DataStream should be treated as a read-stream *or* as a write-stream, *not* as a read/write-stream. [TBD] We should be able to make this much faster via tight-loop byte-string I/O. It looks like FileStream (and WriteStream) nextPutAll: do a reasonable job *if* it doesn''t have to push the writeLimit, in which case it iterates with nextPut:. It could in many cases set the writeLimit and then use the fast case (replaceFrom:to:with:startingAt:), or fill a buffer at at time via the fast case working on a substring. This approach would handle Strings, ByteArrays, and all other variable-byte classes. If(nextPutAll: aCollection) in some cases still reverts to (aCollection do: [:e | self nextPut: e]), then we''d want to make Obj respond to do:. Then we could speed up inner loop 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 always know when the stream is started or ended. [TBD] Cf. notes in DataStream>>beginInstance:size: and Object>>readDataFrom:size:. [TBD] We could save disk space & I/O time by using short, 1-byte size fields whenever possible. E.g. almost all Symbols are shorter than 256 chars. We could do this either by (1) using different typeID codes to indicate when a 1-byte length follows, a scheme which could still read all the old files but would take more code, or (2) a variable-length code for sizes. -- 11/15/92 jhm'! !DataStream methodsFor: 'all'! atEnd "Answer true if the stream is at the end." ^ byteStream atEnd! ! !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'! beginReference: anObject "WeÕre starting to read anObject. Remember it and its reference position (if we care; ReferenceStream cares). Answer the reference position." ^ 0! ! !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'! errorWriteReference: anInteger "PRIVATE -- Raise an error because this case of nextPut:Õs perform: shouldn't be called. -- 11/15/92 jhm" self error: 'This should never be called'! ! !DataStream methodsFor: 'all'! flush "Guarantee that any writes to me are actually recorded on disk. -- 11/17/92 jhm" ^ byteStream flush! ! !DataStream methodsFor: 'all'! getCurrentReference "PRIVATE -- Return the currentReference posn. Overridden by ReferenceStream." ^ 0! ! !DataStream methodsFor: 'all'! internalize: externalObject "PRIVATE -- We just read externalObject. Give it a chance to internalize. Return the internalized object." ^ externalObject comeFullyUpOnReload! ! !DataStream methodsFor: 'all' stamp: 'tk 7/24/97 18:29'! 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." false ifTrue: ["So Senders will find the perform: here" self readNil; readTrue; readFalse; readInteger; readString; readSymbol; readByteArray; readArray; readInstance; readReference; readBitmap; readClass; readUser; readFloat; readRectangle; readShortInst]. 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'! next: anInteger "Answer an Array of the next anInteger objects in the stream." | array | array _ Array new: anInteger. 1 to: anInteger do: [:i | array at: i put: self next]. ^ array! ! !DataStream methodsFor: 'all' stamp: 'tk 11/24/97 16:31'! nextAndClose "Speedy way to grab one object. Only use when we are inside an object binary file. Do not use for the start of a SmartRefStream mixed code-and-object file." | obj | byteStream peek = 4 ifFalse: ["Try to fix the user's sins..." self inform: 'Should be using fileInObjectAndCode'. byteStream ascii. byteStream fileIn. obj _ SmartRefStream scannedObject. SmartRefStream scannedObject: nil. ^ obj]. obj _ self next. self close. ^ obj! ! !DataStream methodsFor: 'all' stamp: 'tk 3/13/98 22:16'! 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 _ (self objectIfBlocked: anObject) objectToStoreOnDataStream. objectToStore == 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'! nextPutAll: aCollection "Write each of the objects in aCollection to the receiver stream. Answer aCollection." ^ aCollection do: [:each | self nextPut: each]! ! !DataStream methodsFor: 'all'! noteCurrentReference: typeID "PRIVATE -- If we support references for type typeID, remember the current byteStream position so we can add the next object to the ÔobjectsÕ dictionary, and return true. Else return false. This method is here to be overridden by ReferenceStream" ^ false! ! !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: 'tk 3/13/98 22:16'! objectIfBlocked: anObject "We don't do any blocking" ^ 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'! readBitmap "PRIVATE -- Read the contents of a Bitmap." ^ Bitmap newFromStream: byteStream "Note that the reader knows that the size is in long words, but the data is in bytes."! ! !DataStream methodsFor: 'all'! readBoolean "PRIVATE -- Read the contents of a Boolean. This is here only for compatibility with old data files." ^ byteStream next ~= 0! ! !DataStream methodsFor: 'all'! readByteArray "PRIVATE -- Read the contents of a ByteArray." | count buffer | count _ byteStream nextNumber: 4. ^ (ByteArray new: count) replaceFrom: 1 to: count with: (byteStream next: count)! ! !DataStream methodsFor: 'all' stamp: 'tk 3/24/98 10:29'! readClass "Should never be executed because a DiskProxy, not a clas comes in." ^ self error: 'Classes should be filed in'! ! !DataStream methodsFor: 'all'! readFalse "PRIVATE -- Read the contents of a False." ^ false! ! !DataStream methodsFor: 'all'! readFloat "PRIVATE -- Read the contents of a Float. This is the fast way to read a Float. We support 8-byte Floats here. Non-IEEE" | new | new _ Float new: 2. "To get an instance" new at: 1 put: (byteStream nextNumber: 4). new at: 2 put: (byteStream nextNumber: 4). ^ new! ! !DataStream methodsFor: 'all'! readFloatString "PRIVATE -- Read the contents of a Float string. This is the slow way to read a Float--via its string repÕn. It's here for compatibility with old data files." ^ Float readFrom: (byteStream next: (byteStream nextNumber: 4))! ! !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'! readInteger "PRIVATE -- Read the contents of a SmallInteger." ^ byteStream nextInt32 "signed!!!!!!"! ! !DataStream methodsFor: 'all'! readNil "PRIVATE -- Read the contents of an UndefinedObject." ^ nil! ! !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'! readString "PRIVATE -- Read the contents of a String." ^ byteStream nextString! ! !DataStream methodsFor: 'all'! readSymbol "PRIVATE -- Read the contents of a Symbol." ^ self readString asSymbol! ! !DataStream methodsFor: 'all'! readTrue "PRIVATE -- Read the contents of a True." ^ true! ! !DataStream methodsFor: 'all'! readUser "Reconstruct both the private class and the instance. 7/29/96 tk" | instSize aSymbol refPosn anObject | anObject _ self readInstance. "Will create new unique class" ^ anObject! ! !DataStream methodsFor: 'all'! reset "Reset the stream." byteStream reset! ! !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'! setCurrentReference: refPosn "PRIVATE -- Set currentReference to refPosn. Noop here. Cf. ReferenceStream."! ! !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'! size "Answer the stream's size." ^ byteStream size! ! !DataStream methodsFor: 'all'! 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. For DataStream this is trivial. ReferenceStream overrides this." ^ false! ! !DataStream methodsFor: 'all' stamp: 'tk 3/15/98 12:35'! typeIDFor: anObject "Return the typeID for anObject's class. This is where the tangle of objects is clipped to stop everything from going out. Classes can control their instance variables by defining objectToStoreOnDataStream. Any object in blockers is not written out. See ReferenceStream.objectIfBlocked: and DataStream nextPut:. Morphs do not write their owners. See Morph.storeDataOn: Each morph tells itself to 'prepareToBeSaved' before writing out." ^ 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'! writeArray: anArray "PRIVATE -- Write the contents of an Array." byteStream nextNumber: 4 put: anArray size. self nextPutAll: anArray.! ! !DataStream methodsFor: 'all' stamp: 'jm 12/3/97 21:39'! writeBitmap: aBitmap "PRIVATE -- Write the contents of a Bitmap." (byteStream isKindOf: DummyStream) ifTrue: [^ self]. aBitmap writeOn: byteStream "Note that this calls (byteStream nextPutAll: aBitmap) which knows enough to put 4-byte quantities on the stream!! Reader must know that size is in long words."! ! !DataStream methodsFor: 'all'! writeBoolean: aBoolean "PRIVATE -- Write the contents of a Boolean. This method is now obsolete." byteStream nextPut: (aBoolean ifTrue: [1] ifFalse: [0])! ! !DataStream methodsFor: 'all' stamp: 'jm 12/3/97 20:45'! writeByteArray: aByteArray "PRIVATE -- Write the contents of a ByteArray." (byteStream isKindOf: DummyStream) ifTrue: [^ self]. byteStream nextNumber: 4 put: aByteArray size. "May have to convert types here..." byteStream nextPutAll: aByteArray.! ! !DataStream methodsFor: 'all' stamp: 'tk 3/24/98 10:27'! writeClass: aClass "Write out a DiskProxy for the class. It will look up the class's name in Smalltalk in the new sustem. Never write classes or methodDictionaries as objects. For novel classes, front part of file is a fileIn of the new class." "This method never executed because objectToStoreOnDataStream returns a DiskProxy. See DataStream.nextPut:" ^ self error: 'Write a DiskProxy instead'! ! !DataStream methodsFor: 'all'! writeFalse: aFalse "PRIVATE -- Write the contents of a False."! ! !DataStream methodsFor: 'all'! writeFloat: aFloat "PRIVATE -- Write the contents of a Float. We support 8-byte Floats here." byteStream nextNumber: 4 put: (aFloat at: 1). byteStream nextNumber: 4 put: (aFloat at: 2). ! ! !DataStream methodsFor: 'all'! writeFloatString: aFloat "PRIVATE -- Write the contents of a Float string. This is the slow way to write a Float--via its string repÕn." self writeByteArray: (aFloat printString)! ! !DataStream methodsFor: 'all'! writeInstance: anObject "PRIVATE -- Write the contents of an arbitrary instance." ^ anObject storeDataOn: self! ! !DataStream methodsFor: 'all'! writeInteger: anInteger "PRIVATE -- Write the contents of a SmallInteger." byteStream nextInt32Put: anInteger "signed!!!!!!!!!!"! ! !DataStream methodsFor: 'all'! writeNil: anUndefinedObject "PRIVATE -- Write the contents of an UndefinedObject."! ! !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 methodsFor: 'all' stamp: 'jm 12/3/97 20:45'! writeString: aString "PRIVATE -- Write the contents of a String." (byteStream isKindOf: DummyStream) ifTrue: [^ self]. aString size < 16384 ifTrue: [byteStream nextStringPut: aString] ifFalse: [self writeByteArray: aString]. "takes more space"! ! !DataStream methodsFor: 'all'! writeSymbol: aSymbol "PRIVATE -- Write the contents of a Symbol." self writeString: aSymbol! ! !DataStream methodsFor: 'all'! writeTrue: aTrue "PRIVATE -- Write the contents of a True."! ! !DataStream methodsFor: 'all'! writeUser: anObject "Write the contents of an arbitrary User instance (and its devoted class)." " 7/29/96 tk" "If anObject is an instance of a unique user class, will lie and say it has a generic class" ^ anObject storeDataOn: self! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! DataStream class instanceVariableNames: ''! !DataStream class methodsFor: 'all'! example "An example and test of DataStream/ReferenceStream. 11/19/92 jhm: Use self testWith:." "DataStream example" "ReferenceStream example" | input sharedPoint | "Construct the test data." input _ Array new: 9. input at: 1 put: nil. input at: 2 put: true. input at: 3 put: (Form extent: 63 @ 50 depth: 8). (input at: 3) fillWithColor: Color lightBlue. input at: 4 put: #(3 3.0 'three'). input at: 5 put: false. input at: 6 put: 1024 @ -2048. input at: 7 put: #x. input at: 8 put: (Array with: (sharedPoint _ 0 @ -30000)). input at: 9 put: sharedPoint. "Write it out, read it back, and return it for inspection." ^ self testWith: input! ! !DataStream class methodsFor: 'all'! exampleWithPictures "DataStream exampleWithPictures" | file result | file _ FileStream fileNamed: 'Test-Picture'. file binary. (DataStream on: file) nextPut: (Form fromUser). file close. file _ FileStream fileNamed: 'Test-Picture'. file binary. result _ (DataStream on: file) next. file close. result display. ^ result! ! !DataStream class methodsFor: 'all'! fileNamed: aString "Here is the way to use DataStream and ReferenceStream: rr _ ReferenceStream fileNamed: 'test.obj'. rr nextPut: . 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' stamp: 'di 2/15/98 14:03'! new ^ self basicNew! ! !DataStream class methodsFor: 'all'! newFileNamed: aString "Here is the way to use DataStream and ReferenceStream: rr _ ReferenceStream fileNamed: 'test.obj'. rr nextPut: . 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:" ! ! !DataStream class methodsFor: 'all' stamp: 'jm 12/3/97 19:36'! testWith: anObject "As a test of DataStream/ReferenceStream, write out anObject and read it back. 11/19/92 jhm: Set the file type. More informative file name." "DataStream testWith: 'hi'" "ReferenceStream testWith: 'hi'" | file result | file _ FileStream fileNamed: (self name, ' test'). file binary. (self on: file) nextPut: anObject. file close. file _ FileStream fileNamed: (self name, ' test'). file binary. result _ (self on: file) next. file close. ^ result! ! Magnitude subclass: #Date instanceVariableNames: 'day year ' classVariableNames: 'DaysInMonth FirstDayOfMonth MonthNames SecondsInDay WeekDayNames ' poolDictionaries: '' category: 'Numeric-Magnitudes'! !Date commentStamp: 'di 5/22/1998 16:33' prior: 0! Date comment: 'I represent a date. My printing format consists of an array of six elements. The first three elements contain the numbers 1, 2, 3, in any order. 1 indicates that the day appears in this position, 2 indicates that the month appears in this position, and 3 indicates that the year appears in this position. The fourth element is the ascii value of the character separator or the character itself. The fifth element is the month format, where 1 indicates print as a number, 2 indicates print the first three characters, and 3 indicates print the entire name. The six element is the year format, where 1 indicates print as a number, and 2 indicates print the number modulo 100. Examples: #(1 2 3 32 2 1) prints as 12 Dec 1981 #(2 1 3 $/ 1 2) prints as 12/12/81'! !Date methodsFor: 'accessing'! day "Answer the day of the year represented by the receiver." ^day! ! !Date methodsFor: 'accessing'! leap "Answer whether the receiver's year is a leap year." ^Date leapYear: year! ! !Date methodsFor: 'accessing'! monthIndex "Answer the index of the month in which the receiver falls." | leap firstDay | leap _ self leap. 12 to: 1 by: -1 do: [ :monthIndex | firstDay _ (FirstDayOfMonth at: monthIndex) + (monthIndex > 2 ifTrue: [leap] ifFalse: [0]). firstDay<= day ifTrue: [^monthIndex]]. self error: 'illegal month'! ! !Date methodsFor: 'accessing'! monthName "Answer the name of the month in which the receiver falls." ^MonthNames at: self monthIndex! ! !Date methodsFor: 'accessing'! weekday "Answer the name of the day of the week on which the receiver falls." ^WeekDayNames at: self weekdayIndex! ! !Date methodsFor: 'accessing'! year "Answer the year in which the receiver falls." ^year! ! !Date methodsFor: 'arithmetic'! addDays: dayCount "Answer a Date that is dayCount days after the receiver." ^Date newDay: day + dayCount year: year! ! !Date methodsFor: 'arithmetic'! subtractDate: aDate "Answer the number of days between the receiver and aDate." year = aDate year ifTrue: [^day - aDate day] ifFalse: [^year - 1 // 4 - (aDate year // 4) + day + aDate daysLeftInYear + (year - 1 - aDate year * 365)]! ! !Date methodsFor: 'arithmetic'! subtractDays: dayCount "Answer a Date that is dayCount days before the receiver." ^Date newDay: day - dayCount year: year! ! !Date methodsFor: 'comparing'! < aDate "Answer whether aDate precedes the date of the receiver." year = aDate year ifTrue: [^day < aDate day] ifFalse: [^year < aDate year]! ! !Date methodsFor: 'comparing'! = aDate "Answer whether aDate is the same day as the receiver." self species = aDate species ifTrue: [^day = aDate day & (year = aDate year)] ifFalse: [^false]! ! !Date methodsFor: 'comparing'! hash "Hash is reimplemented because = is implemented." ^(year hash bitShift: 3) bitXor: day! ! !Date methodsFor: 'inquiries'! dayOfMonth "Answer which day of the month is represented by the receiver." ^day - (self firstDayOfMonthIndex: self monthIndex) + 1! ! !Date methodsFor: 'inquiries'! daysInMonth "Answer the number of days in the month represented by the receiver." ^(DaysInMonth at: self monthIndex) + (self monthIndex = 2 ifTrue: [self leap] ifFalse: [0])! ! !Date methodsFor: 'inquiries'! daysInYear "Answer the number of days in the year represented by the receiver." ^Date daysInYear: self year! ! !Date methodsFor: 'inquiries'! daysLeftInYear "Answer the number of days in the year after the date of the receiver." ^self daysInYear - self day! ! !Date methodsFor: 'inquiries'! firstDayOfMonth "Answer the index of the day of the year that is the first day of the receiver's month." ^self firstDayOfMonthIndex: self monthIndex! ! !Date methodsFor: 'inquiries'! previous: dayName "Answer the previous date whose weekday name is dayName." ^self subtractDays: 7 + self weekdayIndex - (Date dayOfWeek: dayName) \\ 7! ! !Date methodsFor: 'converting'! asSeconds "Answer the seconds between a time on 1 January 1901 and the same time in the receiver's day." ^SecondsInDay * (self subtractDate: (Date newDay: 1 year: 1901))! ! !Date methodsFor: 'printing' stamp: 'tk 4/10/1998 09:20'! mmddyy "Please use mmddyyyy instead, so dates in 2000 will be unambiguous" "Answer the receiver rendered in standard fmt mm/dd/yy. 1/17/96 sw. 2/1/96 sw Fixed to show day of month, not day. Note that the name here is slightly misleading -- the month and day numbers don't show leading zeros, so that for example feb 1 1996 is 2/1/96" "Date today mmddyy" ^ self printFormat: #(2 1 3 $/ 1 2)! ! !Date methodsFor: 'printing' stamp: 'tk 1/27/98 08:30'! mmddyyyy "Answer the receiver rendered in standard fmt mm/dd/yyyy. Good for avoiding year 2000 bugs. Note that the name here is slightly misleading -- the month and day numbers don't show leading zeros, so that for example feb 1 1996 is 2/1/96" "Date today mmddyyyy" ^ self printFormat: #(2 1 3 $/ 1 1)! ! !Date methodsFor: 'printing'! printFormat: formatArray "Answer a String describing the receiver using the format denoted by the argument, formatArray." | aStream | aStream _ WriteStream on: (String new: 16). self printOn: aStream format: formatArray. ^aStream contents! ! !Date methodsFor: 'printing'! printOn: aStream self printOn: aStream format: #(1 2 3 $ 3 1 )! ! !Date methodsFor: 'printing'! printOn: aStream format: formatArray "Print a description of the receiver on aStream using the format denoted by the argument, formatArray: #(item item item sep monthfmt yearfmt twoDigits) items: 1=day 2=month 3=year will appear in the order given, separated by sep which is eaither an ascii code or character. monthFmt: 1=09 2=Sep 3=September yearFmt: 1=1996 2=96 digits: (missing or)1=9 2=09. See the examples in printOn: and mmddyy" | monthIndex element monthFormat twoDigits monthDay | twoDigits _ formatArray size > 6 and: [(formatArray at: 7) > 1]. monthIndex _ self monthIndex. 1 to: 3 do: [:elementIndex | element _ formatArray at: elementIndex. element = 1 ifTrue: [monthDay _ day - self firstDayOfMonth + 1. twoDigits & (monthDay < 10) ifTrue: [aStream nextPutAll: '0']. monthDay printOn: aStream]. element = 2 ifTrue: [monthFormat _ formatArray at: 5. monthFormat = 1 ifTrue: [twoDigits & (monthIndex < 10) ifTrue: [aStream nextPutAll: '0']. monthIndex printOn: aStream]. monthFormat = 2 ifTrue: [aStream nextPutAll: ((MonthNames at: monthIndex) copyFrom: 1 to: 3)]. monthFormat = 3 ifTrue: [aStream nextPutAll: (MonthNames at: monthIndex)]]. element = 3 ifTrue: [(formatArray at: 6) = 1 ifTrue: [year printOn: aStream] ifFalse: [twoDigits & ((year \\ 100) < 10) ifTrue: [aStream nextPutAll: '0']. (year \\ 100) printOn: aStream]]. elementIndex < 3 ifTrue: [(formatArray at: 4) ~= 0 ifTrue: [aStream nextPut: (formatArray at: 4) asCharacter]]]! ! !Date methodsFor: 'printing'! storeOn: aStream aStream nextPutAll: '(', self class name, ' readFromString: '; print: self printString; nextPut: $)! ! !Date methodsFor: 'private'! day: dayInteger year: yearInteger day _ dayInteger. year _ yearInteger! ! !Date methodsFor: 'private'! firstDayOfMonthIndex: monthIndex "Answer the day of the year (an Integer) that is the first day of my month" ^(FirstDayOfMonth at: monthIndex) + (monthIndex > 2 ifTrue: [self leap] ifFalse: [0])! ! !Date methodsFor: 'private' stamp: 'jm 1/6/98 13:38'! weekdayIndex "Monday=1, ... , Sunday=7" | yearIndex dayIndex | day < (self firstDayOfMonthIndex: 3) ifTrue: [yearIndex _ year - 1. dayIndex _ 307] ifFalse: [yearIndex _ year. dayIndex _ -58 - self leap]. ^dayIndex + day + yearIndex + (yearIndex // 4) + (yearIndex // 400) - (yearIndex // 100) \\ 7 + 1! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Date class instanceVariableNames: ''! !Date class methodsFor: 'class initialization'! initialize "Initialize class variables representing the names of the months and days and the number of seconds, days in each month, and first day of each month." MonthNames _ #(January February March April May June July August September October November December ). SecondsInDay _ 24 * 60 * 60. DaysInMonth _ #(31 28 31 30 31 30 31 31 30 31 30 31 ). FirstDayOfMonth _ #(1 32 60 91 121 152 182 213 244 274 305 335 ). WeekDayNames _ #(Monday Tuesday Wednesday Thursday Friday Saturday Sunday ) "Date initialize." ! ! !Date class methodsFor: 'instance creation'! fromDays: dayCount "Answer an instance of me which is dayCount days after January 1, 1901." ^self newDay: 1 + (dayCount asInteger rem: 1461) "There are 1461 days in a 4-year cycle. 2000 is a leap year, so no extra correction is necessary. " year: 1901 + ((dayCount asInteger quo: 1461) * 4)! ! !Date class methodsFor: 'instance creation'! fromString: aString "Answer an instance of created from a string with format DD.MM.YYYY." | fields | fields := aString findTokens: './'. ^self newDay: (fields at: 1) asNumber month: (fields at: 2) asNumber year: (fields at: 3) asNumber! ! !Date class methodsFor: 'instance creation' stamp: 'tk 4/10/1998 06:40'! newDay: day month: monthName year: year "Answer an instance of me which is the day'th day of the month named monthName in the year'th year. The year may be specified as the actual number of years since the beginning of the Roman calendar or the number of years since 1900. **Note** two digit dates are always from 1900. 1/1/01 will NOT mean 2001." "Tolerate a month index instead of a month name." | monthIndex daysInMonth firstDayOfMonth | year < 100 ifTrue: [^ self newDay: day month: monthName year: 1900 + year]. monthIndex _ monthName isInteger ifTrue: [monthName] ifFalse: [self indexOfMonth: monthName]. monthIndex = 2 ifTrue: [daysInMonth _ (DaysInMonth at: monthIndex) + (self leapYear: year)] ifFalse: [daysInMonth _ DaysInMonth at: monthIndex]. monthIndex > 2 ifTrue: [firstDayOfMonth _ (FirstDayOfMonth at: monthIndex) + (self leapYear: year)] ifFalse: [firstDayOfMonth _ FirstDayOfMonth at: monthIndex]. (day < 1 or: [day > daysInMonth]) ifTrue: [self error: 'illegal day in month'] ifFalse: [^self new day: day - 1 + firstDayOfMonth year: year]! ! !Date class methodsFor: 'instance creation'! newDay: dayCount year: referenceYear "Answer an instance of me which is dayCount days after the beginning of the year referenceYear." | day year daysInYear | day _ dayCount. year _ referenceYear. [day > (daysInYear _ self daysInYear: year)] whileTrue: [year _ year + 1. day _ day - daysInYear]. [day <= 0] whileTrue: [year _ year - 1. day _ day + (self daysInYear: year)]. ^self new day: day year: year! ! !Date class methodsFor: 'instance creation'! readFrom: aStream "Read a Date from the stream in any of the forms: (5 April 1982; 5-APR-82) (April 5, 1982) (4/5/82)" | day month | aStream peek isDigit ifTrue: [day _ Integer readFrom: aStream]. [aStream peek isAlphaNumeric] whileFalse: [aStream skip: 1]. aStream peek isLetter ifTrue: "number/name... or name..." [month _ WriteStream on: (String new: 10). [aStream peek isLetter] whileTrue: [month nextPut: aStream next]. month _ month contents. day isNil ifTrue: "name/number..." [[aStream peek isAlphaNumeric] whileFalse: [aStream skip: 1]. day _ Integer readFrom: aStream]] ifFalse: "number/number..." [month _ Date nameOfMonth: day. day _ Integer readFrom: aStream]. [aStream peek isAlphaNumeric] whileFalse: [aStream skip: 1]. ^self newDay: day month: month year: (Integer readFrom: aStream) "Date readFrom: (ReadStream on: '5APR82')" ! ! !Date class methodsFor: 'instance creation'! today "Answer an instance of me representing the day and year right now." ^self dateAndTimeNow at: 1! ! !Date class methodsFor: 'general inquiries'! dateAndTimeNow "Answer an Array whose first element is Date today and second element is Time now." ^Time dateAndTimeNow! ! !Date class methodsFor: 'general inquiries'! dayOfWeek: dayName "Answer the index in a week, 1-7, of the day named dayName. Create an error notification if no such day exists." 1 to: 7 do: [:index | (WeekDayNames at: index) = dayName ifTrue: [^index]]. self error: dayName asString , ' is not a day of the week'! ! !Date class methodsFor: 'general inquiries'! daysInMonth: monthName forYear: yearInteger "Answer the number of days in the month named monthName in the year yearInteger." ^(self newDay: 1 month: monthName year: yearInteger) daysInMonth! ! !Date class methodsFor: 'general inquiries'! daysInYear: yearInteger "Answer the number of days in the year, yearInteger." ^365 + (self leapYear: yearInteger)! ! !Date class methodsFor: 'general inquiries'! firstWeekdayOfMonth: mn year: yr "Answer the weekday index (Sunday=1, etc) of the first day in the month named mn in the year yr." ^(self newDay: 1 month: mn year: yr) weekdayIndex + 7 \\ 7 + 1! ! !Date class methodsFor: 'general inquiries'! indexOfMonth: monthName "Answer the index, 1-12, of the month monthName. Create an error notification if no such month exists." 1 to: 12 do: [ :index | (monthName , '*' match: (MonthNames at: index)) ifTrue: [^index]]. self error: monthName , ' is not a recognized month name'! ! !Date class methodsFor: 'general inquiries'! leapYear: yearInteger "Answer 1 if the year yearInteger is a leap year; answer 0 if it is not." (yearInteger \\ 4 ~= 0 or: [yearInteger \\ 100 = 0 and: [yearInteger \\ 400 ~= 0]]) ifTrue: [^0] ifFalse: [^1]! ! !Date class methodsFor: 'general inquiries'! nameOfDay: dayIndex "Answer a symbol representing the name of the day indexed by dayIndex, 1-7." ^WeekDayNames at: dayIndex! ! !Date class methodsFor: 'general inquiries'! nameOfMonth: monthIndex "Answer a String representing the name of the month indexed by monthIndex, 1-12." ^MonthNames at: monthIndex! ! StringHolder subclass: #Debugger instanceVariableNames: 'interruptedProcess interruptedController contextStack contextStackTop contextStackIndex contextStackList receiverInspector contextVariablesInspector externalInterrupt proceedValue selectingPC sourceMap tempNames ' classVariableNames: 'ContextStackKeystrokes ErrorRecursion ' poolDictionaries: '' category: 'Interface-Debugger'! !Debugger commentStamp: 'di 5/22/1998 16:33' prior: 0! Debugger comment: 'I represent the machine state at the time of an interrupted process. I also represent a query path into the state of the process. As a StringHolder, the string to be viewed is the interrupted method at some point in the sequence of message-sends that have been initiated but not completed.'! !Debugger methodsFor: 'initialize' stamp: 'tm 5/10/1998 15:08'! buildMVCDebuggerViewLabel: aString minSize: aPoint | topView stackListView stackCodeView rcvrVarView rcvrValView ctxtVarView ctxtValView | self expandStack. topView _ StandardSystemView new model: self. topView borderWidth: 1. stackListView _ PluggableListView on: self list: #contextStackList selected: #contextStackIndex changeSelected: #toggleContextStackIndex: menu: #contextStackMenu:shifted: keystroke: #contextStackKey:from:. stackListView window: (0 @ 0 extent: 150 @ 50). topView addSubView: stackListView. stackCodeView _ PluggableTextView on: self text: #contents accept: #contents:notifying: readSelection: #contentsSelection menu: #codePaneMenu:shifted:. stackCodeView window: (0 @ 0 extent: 150 @ 75). topView addSubView: stackCodeView below: stackListView. rcvrVarView _ PluggableListView on: self receiverInspector list: #fieldList selected: #selectionIndex changeSelected: #toggleIndex: menu: #fieldListMenu: keystroke: #inspectorKey:from:. rcvrVarView window: (0 @ 0 extent: 25 @ 50). topView addSubView: rcvrVarView below: stackCodeView. rcvrValView _ PluggableTextView on: self receiverInspector text: #contents accept: #accept: readSelection: #contentsSelection menu: #codePaneMenu:shifted:. rcvrValView window: (0 @ 0 extent: 50 @ 50). topView addSubView: rcvrValView toRightOf: rcvrVarView. ctxtVarView _ PluggableListView on: self contextVariablesInspector list: #fieldList selected: #selectionIndex changeSelected: #toggleIndex: menu: #fieldListMenu: keystroke: #inspectorKey:from:. ctxtVarView window: (0 @ 0 extent: 25 @ 50). topView addSubView: ctxtVarView toRightOf: rcvrValView. ctxtValView _ PluggableTextView on: self contextVariablesInspector text: #contents accept: #accept: readSelection: #contentsSelection menu: #codePaneMenu:shifted:. ctxtValView window: (0 @ 0 extent: 50 @ 50). topView addSubView: ctxtValView toRightOf: ctxtVarView. topView label: aString. topView minimumSize: aPoint. ^ topView ! ! !Debugger methodsFor: 'initialize' stamp: 'jm 5/1/1998 17:47'! buildMVCNotifierViewLabel: aString message: messageString minSize: aPoint | topView aStringHolderView | topView _ StandardSystemView new model: self. topView borderWidth: 1. aStringHolderView _ PluggableTextView on: self text: #contents accept: #doNothing: readSelection: #contentsSelection menu: #debugProceedMenu:. aStringHolderView editString: messageString; askBeforeDiscardingEdits: false. topView addSubView: aStringHolderView; label: aString; minimumSize: aPoint. ^ topView ! ! !Debugger methodsFor: 'initialize' stamp: 'di 5/6/1998 21:37'! buildMorphicNotifierLabelled: label message: messageString | notifyPane window | window _ (SystemWindow labelled: label) model: self. notifyPane _ PluggableTextMorph on: self text: #contents accept: #doNothing: readSelection: #contentsSelection menu: #debugProceedMenu:. notifyPane editString: messageString; askBeforeDiscardingEdits: false. window addMorph: notifyPane frame: (0@0 corner: 1@1). ^ window openInWorldExtent: 350@116! ! !Debugger methodsFor: 'initialize'! defaultBackgroundColor ^ #lightRed! ! !Debugger methodsFor: 'initialize' stamp: 'tm 5/10/1998 15:08'! openFullMorphicLabel: labelString | window | self expandStack. window _ (SystemWindow labelled: labelString) model: self. window addMorph: (PluggableListMorph on: self list: #contextStackList selected: #contextStackIndex changeSelected: #toggleContextStackIndex: menu: #contextStackMenu:shifted: keystroke: #contextStackKey:from:) frame: (0@0 corner: 1@0.3). window addMorph: (PluggableTextMorph on: self text: #contents accept: #contents:notifying: readSelection: #contentsSelection menu: #codePaneMenu:shifted:) frame: (0@0.3 corner: 1@0.7). window addMorph: (PluggableListMorph on: self receiverInspector list: #fieldList selected: #selectionIndex changeSelected: #toggleIndex: menu: #fieldListMenu: keystroke: #inspectorKey:from:) frame: (0@0.7 corner: 0.2@1). window addMorph: (PluggableTextMorph on: self receiverInspector text: #contents accept: #accept: readSelection: #contentsSelection menu: #codePaneMenu:shifted:) frame: (0.2@0.7 corner: 0.5@1). window addMorph: (PluggableListMorph on: self contextVariablesInspector list: #fieldList selected: #selectionIndex changeSelected: #toggleIndex: menu: #fieldListMenu: keystroke: #inspectorKey:from:) frame: (0.5@0.7 corner: 0.7@1). window addMorph: (PluggableTextMorph on: self contextVariablesInspector text: #contents accept: #accept: readSelection: #contentsSelection menu: #codePaneMenu:shifted:) frame: (0.7@0.7 corner: 1@1). ^ window openInWorld ! ! !Debugger methodsFor: 'initialize' stamp: 'jm 5/1/1998 18:03'! openFullNoSuspendLabel: aString "Create and schedule a full debugger with the given label. Do not terminate the current active process." | topView | topView _ self buildMVCDebuggerViewLabel: aString minSize: 300@200. topView controller openNoTerminate. ^ topView ! ! !Debugger methodsFor: 'initialize' stamp: 'di 5/4/1998 23:01'! openNotifierContents: msgString label: label "Create and schedule a notifier view with the given label and message. A notifier view shows just the message or the first several lines of the stack, with a menu that allows the user to open a full debugger if so desired. Do not terminate the current active process." | msg topView p newActiveProcess | Sensor flushKeyboard. (label beginsWith: 'Space is low') ifTrue: [msg _ self lowSpaceChoices, msgString] ifFalse: [msg _ msgString]. World ifNotNil: [self buildMorphicNotifierLabelled: label message: msg. newActiveProcess _ [[true] whileTrue: [World doOneCycle. Processor yield]] newProcess priority: Processor userSchedulingPriority. ^ newActiveProcess resume]. Display fullScreen. Cursor normal show. topView _ self buildMVCNotifierViewLabel: label message: msg minSize: 350@((14 * 5) + 16). ScheduledControllers activeController ifNil: [p _ Display boundingBox center] ifNotNil: [p _ ScheduledControllers activeController view displayBox center]. topView controller openNoTerminateDisplayAt: (p max: (200@60)). ^ topView ! ! !Debugger methodsFor: 'initialize'! release interruptedProcess ~~ nil ifTrue: [interruptedProcess terminate]. interruptedProcess _ nil. interruptedController _ nil. contextStack _ nil. contextStackTop _ nil. receiverInspector _ nil. contextVariablesInspector _ nil. Smalltalk installLowSpaceWatcher. "restart low space handler" super release.! ! !Debugger methodsFor: 'accessing'! contents "Depending on the current selection, different information is retrieved. Answer a string description of that information. This information is the method in the currently selected context." contents == nil ifTrue: [^'']. ^contents! ! !Debugger methodsFor: 'accessing' stamp: 'tk 12/6/97 21:31'! contents: aText 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 from which 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: aText 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: aText fromParseNode: parseNode class: classOfMethod category: category inFile: 2 priorMethod: priorMethod. classOfMethod organization classify: selector under: category]. contents _ aText copy. self selectedContext restartWith: method. contextVariablesInspector object: nil. self resetContext: self selectedContext. ^true! ! !Debugger methodsFor: 'accessing'! contextVariablesInspector "Answer the instance of Inspector that is providing a view of the variables of the selected context." ^contextVariablesInspector! ! !Debugger methodsFor: 'accessing' stamp: 'tk 4/16/1998 12:16'! doNothing: newText "Notifier window can't accept text"! ! !Debugger methodsFor: 'accessing'! interruptedContext "Answer the suspended context of the interrupted process." ^contextStackTop! ! !Debugger methodsFor: 'accessing'! interruptedProcess "Answer the interrupted process." ^interruptedProcess! ! !Debugger methodsFor: 'accessing' stamp: 'tk 4/16/1998 15:47'! isNotifier "Return true if this debugger has not been expanded into a full sized window" ^ receiverInspector == nil! ! !Debugger methodsFor: 'accessing'! proceedValue "Answer the value to return to the selected context when the interrupted process proceeds." ^proceedValue! ! !Debugger methodsFor: 'accessing'! proceedValue: anObject "Set the value to be returned to the selected context when the interrupted process proceeds." proceedValue _ anObject! ! !Debugger methodsFor: 'accessing'! receiver "Answer the receiver of the selected context, if any. Answer nil otherwise." contextStackIndex = 0 ifTrue: [^nil] ifFalse: [^self selectedContext receiver]! ! !Debugger methodsFor: 'accessing'! receiverInspector "Answer the instance of Inspector that is providing a view of the variables of the selected context's receiver." ^receiverInspector! ! !Debugger methodsFor: 'notifier menu' stamp: 'di 5/5/1998 00:00'! debug "Open a full DebuggerView." | topView | topView _ self topView. topView model: nil. "so close won't release me." World ifNotNil: [self openFullMorphicLabel: topView label. ^ topView delete]. topView controller controlTerminate. topView deEmphasizeView; erase. self openFullNoSuspendLabel: topView label. topView controller closeAndUnscheduleNoErase. Processor terminateActive. ! ! !Debugger methodsFor: 'context stack (message list)'! contextStackIndex "Answer the index of the selected context." ^contextStackIndex! ! !Debugger methodsFor: 'context stack (message list)'! contextStackList "Answer the array of contexts." ^contextStackList! ! !Debugger methodsFor: 'context stack (message list)' stamp: 'tk 4/17/1998 18:05'! expandStack "A Notifier is being turned into a full debugger. Show a substantial amount of stack in the context pane." self newStack: (contextStackTop stackOfSize: 20). contextStackIndex _ 0. receiverInspector _ Inspector inspect: nil. contextVariablesInspector _ ContextVariablesInspector inspect: nil. proceedValue _ nil! ! !Debugger methodsFor: 'context stack (message list)'! fullyExpandStack "Expand the stack to include all of it, rather than the first four or five contexts." self okToChange ifFalse: [^ self]. self newStack: contextStackTop stack. self changed: #contextStackList! ! !Debugger methodsFor: 'context stack (message list)'! messageListIndex "Answer the index of the currently selected context." ^contextStackIndex! ! !Debugger methodsFor: 'context stack (message list)'! selectedMessage "Answer the source code of the currently selected context." contents == nil ifTrue: [contents _ self selectedContext sourceCode]. ^contents! ! !Debugger methodsFor: 'context stack (message list)'! selectedMessageName "Answer the message selector of the currently selected context." ^self selectedContext selector! ! !Debugger methodsFor: 'context stack (message list)' stamp: 'tk 4/6/98 23:00'! spawn: aString "Create and schedule a message browser on the message, aString. Any edits already made are retained." self messageListIndex > 0 ifTrue: [^Browser openMessageBrowserForClass: self selectedClass selector: self selectedMessageName editString: aString]! ! !Debugger methodsFor: 'context stack (message list)'! toggleContextStackIndex: anInteger "If anInteger is the same as the index of the selected context, deselect it. Otherwise, the context whose index is anInteger becomes the selected context." self contextStackIndex: (contextStackIndex = anInteger ifTrue: [0] ifFalse: [anInteger]) oldContextWas: (contextStackIndex = 0 ifTrue: [nil] ifFalse: [contextStack at: contextStackIndex])! ! !Debugger methodsFor: 'context stack menu' stamp: 'wod 5/15/1998 00:24'! browseMessages "Present a menu of all messages sent by the currently selected message. Open a message set browser of all implementors of the message chosen. Do nothing if no message is chosen." contextStackIndex = 0 ifTrue: [^ self]. super browseMessages.! ! !Debugger methodsFor: 'context stack menu' stamp: 'wod 5/15/1998 00:23'! browseSendersOfMessages "Present a menu of the currently selected message, as well as all messages sent by it. Open a message set browser of all implementors of the message chosen." contextStackIndex = 0 ifTrue: [^ self]. super browseSendersOfMessages! ! !Debugger methodsFor: 'context stack menu' stamp: 'sw 8/6/97 14:26'! browseVersions "Create and schedule a message set browser on all versions of the currently selected message selector." | class selector | class _ self selectedClassOrMetaClass. selector _ self selectedMessageName. ChangeList browseVersionsOf: (class compiledMethodAt: selector) class: self selectedClass meta: self selectedClass isMeta category: self selectedMessageCategoryName selector: selector! ! !Debugger methodsFor: 'context stack menu' stamp: 'tk 4/6/98 23:00'! buildMessageBrowser "Create and schedule a message browser on the current method." contextStackIndex = 0 ifTrue: [^ self]. ^ Browser openMessageBrowserForClass: self selectedClassOrMetaClass selector: self selectedMessageName editString: nil! ! !Debugger methodsFor: 'context stack menu'! close: aScheduledController "The argument is a controller on a view of the receiver. That view is closed." aScheduledController close ! ! !Debugger methodsFor: 'context stack menu' stamp: 'tk 4/18/1998 09:24'! contextStackKey: aChar from: view "Respond to a keystroke in the context list" | selector | selector _ ContextStackKeystrokes at: aChar ifAbsent: [nil]. selector ifNil: [self messageListKey: aChar from: view] ifNotNil: [self perform: selector]! ! !Debugger methodsFor: 'context stack menu' stamp: 'tk 4/21/1998 07:51'! contextStackMenu: aMenu shifted: shifted ^ shifted ifFalse: [aMenu labels: 'fullStack (f) restart (r) proceed (p) step (t) send (e) where (w) senders of... implementors of... method inheritance versions inst var refs... inst var defs... class var refs... class variables class refs browse full more...' lines: #(6 10 12 15) selections: #(fullStack restart proceed step send where browseSendersOfMessages browseMessages methodHierarchy browseVersions browseInstVarRefs browseInstVarDefs browseClassVarRefs browseClassVariables browseClassRefs browseMethodFull shiftedYellowButtonActivity)] ifTrue: [aMenu labels: 'browse class hierarchy browse class browse method implementors of sent messages change sets with this method inspect instances inspect subinstances remove from current change set more...' lines: #(5 7 9) selections: #(classHierarchy browseClass buildMessageBrowser browseAllMessages findMethodInChangeSets inspectInstances inspectSubInstances removeFromCurrentChanges unshiftedYellowButtonActivity)] ! ! !Debugger methodsFor: 'context stack menu' stamp: 'sw 8/6/97 13:45'! currentCompiledMethod ^ self selectedClassOrMetaClass compiledMethodAt: self selectedMessageName! ! !Debugger methodsFor: 'context stack menu' stamp: 'tk 4/16/1998 12:19'! debugProceedMenu: aMenu ^ aMenu labels: 'proceed debug' lines: #() selections: #(proceed debug ) ! ! !Debugger methodsFor: 'context stack menu' stamp: 'tk 4/15/1998 16:55'! down "move down the context stack to the previous (enclosing) context" self toggleContextStackIndex: contextStackIndex+1! ! !Debugger methodsFor: 'context stack menu' stamp: 'tk 4/17/1998 18:06'! fullStack "Change from displaying the minimal stack to a full one." self contextStackList size > 20 "Already expanded" ifTrue: [self changed: #flash] ifFalse: [self contextStackIndex = 0 ifFalse: [ self toggleContextStackIndex: self contextStackIndex]. self fullyExpandStack]! ! !Debugger methodsFor: 'context stack menu' stamp: 'di 5/5/1998 00:07'! proceed "Proceed execution of the receiver's model, starting after the expression at which an interruption occurred." Smalltalk okayToProceedEvenIfSpaceIsLow ifTrue: [ self proceed: self topView]. ! ! !Debugger methodsFor: 'context stack menu' stamp: 'di 5/5/1998 00:07'! proceed: aTopView "Proceed from the interrupted state of the currently selected context. The argument is the topView of the receiver. That view is closed." self okToChange ifFalse: [^ self]. self checkContextSelection. contextStackIndex > 1 | externalInterrupt not ifTrue: [self selectedContext push: proceedValue]. self resumeProcess: aTopView! ! !Debugger methodsFor: 'context stack menu' stamp: 'di 5/5/1998 00:08'! restart "Proceed execution of the receiver's model, starting at the beginning of the currently selected method." self restart: self topView. ! ! !Debugger methodsFor: 'context stack menu' stamp: 'di 5/5/1998 00:08'! restart: aTopView "Proceed from the initial state of the currently selected context. The argument is a controller on a view of the receiver. That view is closed." self okToChange ifFalse: [^ self]. self checkContextSelection. (self selectedContext isKindOf: MethodContext) ifFalse: [(self confirm: 'I will have to revert to the method from which this block originated. Is that OK?') ifTrue: [self resetContext: self selectedContext home] ifFalse: [^self]]. self selectedContext restart. self resumeProcess: aTopView! ! !Debugger methodsFor: 'context stack menu'! selectPC "Toggle the flag telling whether to automatically select the expression currently being executed by the selected context." selectingPC _ selectingPC not! ! !Debugger methodsFor: 'context stack menu' stamp: 'tk 4/16/1998 11:36'! 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: 'context stack menu' stamp: 'tk 4/18/1998 15:08'! shiftedYellowButtonActivity "Invoke the model's other menu. Just do what the controller would have done." | menu | menu _ self contextStackMenu: (CustomMenu new) shifted: true. menu == nil ifTrue: [Sensor waitNoButton] ifFalse: [menu invokeOn: self]. ! ! !Debugger methodsFor: 'context stack menu' 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: 'context stack menu' stamp: 'tk 4/21/1998 09:05'! unshiftedYellowButtonActivity "Invoke the model's other menu. Just do what the controller would have done." | menu | menu _ self contextStackMenu: (CustomMenu new) shifted: false. menu == nil ifTrue: [Sensor waitNoButton] ifFalse: [menu invokeOn: self]. ! ! !Debugger methodsFor: 'context stack menu' stamp: 'tk 4/15/1998 16:55'! up "move up the context stack to the next (enclosed) context" contextStackIndex > 1 ifTrue: [self toggleContextStackIndex: contextStackIndex-1]! ! !Debugger methodsFor: 'context stack menu' stamp: 'tk 4/15/1998 16:54'! where "Select the expression whose evaluation was interrupted." self selectPC! ! !Debugger methodsFor: 'code pane' stamp: 'tk 4/15/1998 18:31'! contentsSelection ^ self pcRange! ! !Debugger methodsFor: 'code pane'! doItContext "Answer the context in which a text selection can be evaluated." contextStackIndex = 0 ifTrue: [^super doItContext] ifFalse: [^self selectedContext]! ! !Debugger methodsFor: 'code pane'! doItReceiver "Answer the object that should be informed of the result of evaluating a text selection." ^self receiver! ! !Debugger methodsFor: 'code pane' stamp: 'tk 5/2/1998 10:04'! pc ^ self pcRange! ! !Debugger methodsFor: 'code pane'! pcRange "Answer the indices in the source code for the method corresponding to the selected context's program counter value." | i methodNode pc end | (selectingPC and: [contextStackIndex ~= 0]) ifFalse: [^1 to: 0]. sourceMap == nil ifTrue: [methodNode _ self selectedClass compilerClass new parse: self selectedMessage in: self selectedClass notifying: nil. sourceMap _ methodNode sourceMap. tempNames _ methodNode tempNames. self selectedContext method cacheTempNames: tempNames]. sourceMap size = 0 ifTrue: [^1 to: 0]. pc_ self selectedContext pc - ((externalInterrupt and: [contextStackIndex=1]) ifTrue: [1] ifFalse: [2]). i _ sourceMap indexForInserting: (Association key: pc value: nil). i < 1 ifTrue: [^1 to: 0]. i > sourceMap size ifTrue: [end _ sourceMap inject: 0 into: [:prev :this | prev max: this value last]. ^ end+1 to: end]. ^(sourceMap at: i) value! ! !Debugger methodsFor: 'code pane menu' stamp: 'tk 4/17/1998 17:25'! perform: selector orSendTo: otherTarget "Selector was just chosen from a menu by a user. If can respond, then perform it on myself. If not, send it to otherTarget, presumably the editPane from which the menu was invoked." | result | (#(debug proceed) includes: selector) "When I am a notifier window" ifTrue: [^ self perform: selector] ifFalse: [result _ super perform: selector orSendTo: otherTarget. selector == #doIt ifTrue: [ result ~~ #failedDoit ifTrue: [self proceedValue: result]]. ^ result]! ! !Debugger methodsFor: 'message category list'! selectedMessageCategoryName "Answer the name of the message category of the message of the currently selected context." ^self selectedClass organization categoryOfElement: self selectedMessageName! ! !Debugger methodsFor: 'class list'! selectedClass "Answer the class in which the currently selected context's method was found." ^self selectedContext mclass! ! !Debugger methodsFor: 'class list'! selectedClassOrMetaClass "Answer the class in which the currently selected context's method was found." ^self selectedContext mclass! ! !Debugger methodsFor: 'dependents access'! updateInspectors "Update the inspectors on the receiver's variables." receiverInspector update. contextVariablesInspector update! ! !Debugger methodsFor: 'private'! checkContextSelection contextStackIndex = 0 ifTrue: [contextStackIndex _ 1]! ! !Debugger methodsFor: 'private' stamp: 'di 5/13/1998 14:07'! contextStackIndex: anInteger oldContextWas: oldContext | newMethod | contextStackIndex _ anInteger. anInteger = 0 ifTrue: [tempNames _ sourceMap _ contents _ nil. self changed: #contextStackIndex. self changed: #contents. contextVariablesInspector object: nil. receiverInspector object: self receiver. ^self]. (newMethod _ oldContext == nil or: [oldContext method ~~ self selectedContext method]) ifTrue: [tempNames _ sourceMap _ nil. contents _ self selectedContext sourceCode. self changed: #contents. self pcRange "will compute tempNamesunless noFrills"]. self changed: #contextStackIndex. tempNames == nil ifTrue: [tempNames _ self selectedClassOrMetaClass parserClass new parseArgsAndTemps: contents notifying: nil]. contextVariablesInspector object: self selectedContext. receiverInspector object: self receiver. newMethod ifFalse: [self changed: #contentsSelection]! ! !Debugger methodsFor: 'private'! externalInterrupt: aBoolean externalInterrupt _ aBoolean ! ! !Debugger methodsFor: 'private' stamp: 'jm 5/1/1998 16:20'! 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. (Trying to show the full stack will definitely use up all remaining memory if the low-space problem is caused by an infinite recursion!!). ' ! ! !Debugger methodsFor: 'private'! newStack: stack | oldStack diff | oldStack _ contextStack. contextStack _ stack. (oldStack == nil or: [oldStack last ~~ stack last]) ifTrue: [contextStackList _ contextStack collect: [:ctx | ctx printString]. ^ self]. "May be able to re-use some of previous list" diff _ stack size - oldStack size. contextStackList _ diff <= 0 ifTrue: [contextStackList copyFrom: 1-diff to: oldStack size] ifFalse: [diff > 1 ifTrue: [contextStack collect: [:ctx | ctx printString]] ifFalse: [(Array with: stack first printString) , contextStackList]]! ! !Debugger methodsFor: 'private'! process: aProcess controller: aController context: aContext super initialize. contents _ nil. interruptedProcess _ aProcess. interruptedController _ aController. contextStackTop _ aContext. self newStack: (contextStackTop stackOfSize: 1). contextStackIndex _ 1. externalInterrupt _ false. selectingPC _ true! ! !Debugger methodsFor: 'private' stamp: 'tk 4/15/1998 19:04'! resetContext: aContext "Used when a new context becomes top-of-stack, for instance when the method of the selected context is re-compiled, or the simulator steps or returns to a new method. There is room for much optimization here, first to save recomputing the whole stack list (and text), and secondly to avoid recomposing all that text (by editing the paragraph instead of recreating it)." | oldContext | oldContext _ self selectedContext. contextStackTop _ aContext. self newStack: contextStackTop stack. self changed: #contextStackList. self contextStackIndex: 1 oldContextWas: oldContext. self changed: #content.! ! !Debugger methodsFor: 'private' stamp: 'di 5/5/1998 00:20'! resumeProcess: aTopView World ifNil: [aTopView 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]. World ifNil: [ScheduledControllers activeControllerNoTerminate: interruptedController andProcess: interruptedProcess] ifNotNil: [interruptedProcess resume]]. "if old process was terminated, just terminate current one" interruptedProcess _ nil. World ifNil: [aTopView controller closeAndUnscheduleNoErase] ifNotNil: [aTopView delete]. Processor terminateActive ! ! !Debugger methodsFor: 'private'! selectedContext contextStackIndex = 0 ifTrue: [^contextStackTop] ifFalse: [^contextStack at: contextStackIndex]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Debugger class instanceVariableNames: ''! !Debugger class methodsFor: 'class initialization' stamp: 'di 5/22/1998 14:52'! initialize ErrorRecursion _ false. ContextStackKeystrokes _ Dictionary new at: $e put: #send; at: $t put: #step; at: $p put: #proceed; at: $r put: #restart; at: $f put: #fullStack; at: $w put: #where; yourself. "Debugger initialize"! ! !Debugger class methodsFor: 'instance creation' stamp: 'jm 5/1/1998 16:31'! context: aContext "Answer an instance of me for debugging the active process starting with the given context." ^ self new process: Processor activeProcess controller: (ScheduledControllers inActiveControllerProcess ifTrue: [ScheduledControllers activeController] ifFalse: [nil]) context: aContext ! ! !Debugger class methodsFor: 'opening' stamp: 'di 5/4/1998 15:43'! openContext: aContext label: aString contents: contentsString "Open a notifier in response to an error, halt, or notify. A notifier view just shows a short view of the sender stack and provides a menu that lets the user open a full debugger." ErrorRecursion ifTrue: [ErrorRecursion _ false. self primitiveError: aString]. ErrorRecursion _ true. (Debugger context: aContext) openNotifierContents: contentsString label: aString. ErrorRecursion _ false. Processor activeProcess suspend. ! ! !Debugger class methodsFor: 'opening' stamp: 'jm 5/1/1998 18:05'! openInterrupt: aString onProcess: interruptedProcess "Open a notifier in response to an interrupt. An interrupt occurs when the user types the interrupt key (cmd-. on Macs, ctrl-c or alt-. on other systems) or when the low-space watcher detects that memory is low." | debugger | debugger _ self new. debugger process: interruptedProcess controller: (ScheduledControllers activeControllerProcess == interruptedProcess ifTrue: [ScheduledControllers activeController]) context: interruptedProcess suspendedContext. debugger externalInterrupt: true. ^ debugger openNotifierContents: debugger interruptedContext shortStack label: aString ! ! InstructionStream subclass: #Decompiler instanceVariableNames: 'constructor method instVars tempVars constTable stack statements lastPc exit lastJumpPc lastReturnPc limit hasValue blockStackBase ' classVariableNames: 'ArgumentFlag CascadeFlag CaseFlag ' poolDictionaries: '' category: 'System-Compiler'! !Decompiler commentStamp: 'di 5/22/1998 16:33' prior: 0! Decompiler comment: 'I decompile a method in three phases: Reverser: postfix byte codes -> prefix symbolic codes (nodes and atoms) Parser: prefix symbolic codes -> node tree (same as the compiler) Printer: node tree -> text (done by the nodes)'! !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'! blockTo: end "Decompile a range of code as in statementsTo:, but return a block node." | exprs block oldBase | oldBase _ blockStackBase. blockStackBase _ stack size. exprs _ self statementsTo: 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: 'control'! statementsTo: 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." | blockPos stackPos t | blockPos _ statements size. stackPos _ stack size. [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'! blockReturnTop "No action needed"! ! !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'! doDup stack last == CascadeFlag ifFalse: ["Save position and mark cascade" stack addLast: statements size. stack addLast: CascadeFlag]. stack addLast: CascadeFlag! ! !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'! doStore: stackOrBlock "Only called internally, not from InstructionStream. StackOrBlock is stack for store, statements for storePop." | var expr | var _ stack removeLast. expr _ stack removeLast. stackOrBlock addLast: (expr == ArgumentFlag ifTrue: [var] ifFalse: [constructor codeAssignTo: var value: expr])! ! !Decompiler methodsFor: 'instruction decoding'! jump: dist exit _ pc + dist. lastJumpPc _ lastPc! ! !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: 'instruction decoding'! methodReturnConstant: value self pushConstant: value; methodReturnTop! ! !Decompiler methodsFor: 'instruction decoding'! methodReturnReceiver self pushReceiver; methodReturnTop! ! !Decompiler methodsFor: 'instruction decoding'! methodReturnTop | last | last _ stack removeLast. stack size > blockStackBase "get effect of elided pop before return" ifTrue: [statements addLast: stack removeLast]. exit _ method size + 1. lastJumpPc _ lastReturnPc _ lastPc. statements addLast: last! ! !Decompiler methodsFor: 'instruction decoding'! popIntoLiteralVariable: value self pushLiteralVariable: value; doStore: statements! ! !Decompiler methodsFor: 'instruction decoding'! popIntoReceiverVariable: offset self pushReceiverVariable: offset; doStore: statements! ! !Decompiler methodsFor: 'instruction decoding'! popIntoTemporaryVariable: offset self pushTemporaryVariable: offset; doStore: statements! ! !Decompiler methodsFor: 'instruction decoding'! pushActiveContext stack addLast: constructor codeThisContext! ! !Decompiler methodsFor: 'instruction decoding'! pushConstant: value | node | node _ value == true ifTrue: [constTable at: 2] ifFalse: [value == false ifTrue: [constTable at: 3] ifFalse: [value == nil ifTrue: [constTable at: 4] ifFalse: [constructor codeAnyLiteral: value]]]. stack addLast: node! ! !Decompiler methodsFor: 'instruction decoding'! pushLiteralVariable: assoc stack addLast: (constructor codeAnyLitInd: assoc)! ! !Decompiler methodsFor: 'instruction decoding'! pushReceiver stack addLast: (constTable at: 1)! ! !Decompiler methodsFor: 'instruction decoding'! pushReceiverVariable: offset | var | (var _ instVars at: offset + 1) == nil ifTrue: ["Not set up yet" instVars at: offset + 1 put: (var _ constructor codeInst: offset)]. stack addLast: var! ! !Decompiler methodsFor: 'instruction decoding'! pushTemporaryVariable: offset stack addLast: (tempVars at: offset + 1)! ! !Decompiler methodsFor: 'instruction decoding'! send: selector super: superFlag numArgs: numArgs | args rcvr selNode msgNode elements numElements messages | selector == #toBraceStack: ifTrue: [^self formBrace]. args _ Array new: numArgs. (numArgs to: 1 by: -1) do: [:i | args at: i put: stack removeLast]. rcvr _ stack removeLast. superFlag ifTrue: [rcvr _ constructor codeSuper]. (selector == #blockCopy: and: [self checkForBlock: rcvr]) ifFalse: [selNode _ constructor codeAnySelector: selector. rcvr == CascadeFlag ifTrue: [self willJumpIfFalse ifTrue: "= generated by a case macro" [selector ~= #= ifTrue: [self error: 'bad case: ', selector]. statements addLast: args first. stack addLast: rcvr. "restore CascadeFlag" ^self] ifFalse: [msgNode _ constructor codeCascadedMessage: selNode arguments: args]. stack last == CascadeFlag ifFalse: ["Last message of a cascade" statements addLast: msgNode. messages _ self popTo: stack removeLast. "Depth saved by first dup" msgNode _ constructor codeCascade: stack removeLast messages: messages]] ifFalse: [msgNode _ selector == #fromBraceStack: ifTrue: [numElements _ args first literalValue. elements _ Array new: numElements. numElements to: 1 by: -1 do: [:i | elements at: i put: stack removeLast]. constructor codeBrace: elements as: rcvr] ifFalse: [constructor codeMessage: rcvr selector: selNode arguments: args]]. stack addLast: msgNode]! ! !Decompiler methodsFor: 'instruction decoding'! storeIntoLiteralVariable: assoc self pushLiteralVariable: assoc; doStore: stack! ! !Decompiler methodsFor: 'instruction decoding'! storeIntoReceiverVariable: offset self pushReceiverVariable: offset; doStore: stack! ! !Decompiler methodsFor: 'instruction decoding'! storeIntoTemporaryVariable: offset self pushTemporaryVariable: offset; doStore: stack! ! !Decompiler methodsFor: 'public access'! decompile: aSelector in: aClass "See Decompiler|decompile:in:method:. The method is found by looking up the message, aSelector, in the method dictionary of the class, aClass." ^self decompile: aSelector in: aClass method: (aClass compiledMethodAt: aSelector)! ! !Decompiler methodsFor: 'public access'! decompile: aSelector in: aClass method: aMethod "Answer a MethodNode that is the root of the parse tree for the argument, aMethod, which is the CompiledMethod associated with the message, aSelector. Variables are determined with respect to the argument, aClass." ^self decompile: aSelector in: aClass method: aMethod using: DecompilerConstructor new! ! !Decompiler methodsFor: 'public access'! tempAt: offset "Needed by BraceConstructor=0]) primitive: method primitive class: aClass! ! !Decompiler methodsFor: 'private'! formBrace "A #toBraceStream: selector has been encountered as part of a sequence: ... where is either a or a sequence like the above. The top of the stack must therefore be a LiteralNode with the key n. Beneath that is usually the right-hand side of the assignment. However, there may be an intervening pair of CascadeFlags and a number beneath them. Create a BraceNode and let it consume the pop & stores to determine its variables. Create an AssignmentNode with the BraceNode as its variable and the right-hand-side as its value. Add the AssignmentNode to statements. If two CascadeFlags are encountered instead of the right-hand-side, pop them and the number beneath them to find the right-hand-side, and leave the Assignment node on the stack instead of adding it to statements (this happens in cases like x _ {a. b} _ ...)." | var expr dest | var _ constructor codeBrace: stack removeLast literalValue fromBytes: self. (expr _ stack removeLast) == CascadeFlag ifTrue: "multiple assignment, more to come" [stack removeLast; removeLast. "CascadeFlag, number" expr _ stack removeLast. dest _ stack] ifFalse: "store and pop" [dest _ statements]. dest addLast: (constructor codeAssignTo: var value: expr)! ! !Decompiler methodsFor: 'private'! popTo: oldPos | t | t _ Array new: statements size - oldPos. (t size to: 1 by: -1) do: [:i | t at: i put: statements removeLast]. ^t! ! !Decompiler methodsFor: 'private'! quickMethod ^ method isReturnSpecial ifTrue: [constructor codeBlock: (Array with: (constTable at: method primitive - 255)) returns: true] ifFalse: [method isReturnField ifTrue: [constructor codeBlock: (Array with: (constructor codeInst: method returnField)) returns: true] ifFalse: [self error: 'improper short method']]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Decompiler class instanceVariableNames: ''! !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"! ! ParseNode subclass: #DecompilerConstructor instanceVariableNames: 'method instVars nArgs literalValues tempVars ' classVariableNames: '' poolDictionaries: '' category: 'System-Compiler'! !DecompilerConstructor commentStamp: 'di 5/22/1998 16:33' prior: 0! DecompilerConstructor comment: 'I construct the node tree for a Decompiler.'! !DecompilerConstructor methodsFor: 'initialize-release'! method: aMethod class: aClass literals: literals method _ aMethod. instVars _ aClass allInstVarNames. nArgs _ method numArgs. literalValues _ literals! ! !DecompilerConstructor methodsFor: 'constructor'! codeAnyLiteral: value ^LiteralNode new key: value index: 0 type: LdLitType! ! !DecompilerConstructor methodsFor: 'constructor'! codeAnyLitInd: association ^VariableNode new name: association key key: association index: 0 type: LdLitIndType! ! !DecompilerConstructor methodsFor: 'constructor'! codeAnySelector: selector ^SelectorNode new key: selector index: 0 type: SendType! ! !DecompilerConstructor methodsFor: 'constructor'! codeArguments: args block: block ^block arguments: args! ! !DecompilerConstructor methodsFor: 'constructor'! codeAssignTo: variable value: expression ^AssignmentNode new variable: variable value: expression! ! !DecompilerConstructor methodsFor: 'constructor'! codeBlock: statements returns: returns ^BlockNode new statements: statements returns: returns! ! !DecompilerConstructor methodsFor: 'constructor'! codeBrace: elements ^BraceNode new elements: elements! ! !DecompilerConstructor methodsFor: 'constructor'! codeBrace: elements as: receiver | braceNode | braceNode _ self codeBrace: elements. ^(receiver isVariableReference and: [receiver key key == #Array]) ifTrue: [braceNode] ifFalse: [self codeMessage: (braceNode collClass: receiver) selector: (self codeSelector: #as: code: -1) arguments: (Array with: receiver)]! ! !DecompilerConstructor methodsFor: 'constructor'! codeBrace: numElements fromBytes: anInstructionStream ^BraceConstructor new codeBrace: numElements fromBytes: anInstructionStream withConstructor: self! ! !DecompilerConstructor methodsFor: 'constructor'! codeCascade: receiver messages: messages ^CascadeNode new receiver: receiver messages: messages! ! !DecompilerConstructor methodsFor: 'constructor'! codeCascadedMessage: selector arguments: arguments ^self codeMessage: nil selector: selector arguments: arguments! ! !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'! codeEmptyBlock ^BlockNode withJust: NodeNil! ! !DecompilerConstructor methodsFor: 'constructor'! codeInst: index ^VariableNode new name: (instVars at: index + 1) index: index type: LdInstType! ! !DecompilerConstructor methodsFor: 'constructor'! codeMessage: receiver selector: selector arguments: arguments | symbol | symbol _ selector key. ^MessageNode new receiver: receiver selector: selector arguments: arguments precedence: (symbol isInfix ifTrue: [2] ifFalse: [symbol isKeyword ifTrue: [3] ifFalse: [1]])! ! !DecompilerConstructor methodsFor: 'constructor'! codeMethod: selector block: block tempVars: vars primitive: primitive class: class | node precedence | node _ self codeSelector: selector code: nil. precedence _ selector isInfix ifTrue: [2] ifFalse: [selector isKeyword ifTrue: [3] ifFalse: [1]]. tempVars _ vars. ^MethodNode new selector: node arguments: (tempVars copyFrom: 1 to: nArgs) precedence: precedence temporaries: (tempVars copyFrom: nArgs + 1 to: tempVars size) block: block encoder: (Encoder new initScopeAndLiteralTables nTemps: tempVars size literals: literalValues class: class) primitive: primitive! ! !DecompilerConstructor methodsFor: 'constructor'! codeSelector: sel code: code ^SelectorNode new key: sel code: code! ! !DecompilerConstructor methodsFor: 'constructor'! codeSuper ^NodeSuper! ! !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! ! !DecompilerConstructor methodsFor: 'constructor'! codeThisContext ^NodeThisContext! ! Object subclass: #Delay instanceVariableNames: 'delayDuration resumptionTime delaySemaphore beingWaitedOn ' classVariableNames: 'AccessProtect ActiveDelay ActiveDelayStartTime SuspendedDelays TimingSemaphore ' poolDictionaries: '' category: 'Kernel-Processes'! !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 instanceVariableNames: ''! !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." self primitiveFailed ! ! Set subclass: #Dictionary instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Collections-Unordered'! !Dictionary commentStamp: 'di 5/22/1998 16:33' prior: 0! NewDictionary comment: 'I represent a set of elements that can be viewed from one of two perspectives: a set of associations, or a set of values that are externally named where the name can be any object that responds to =. The external name is referred to as the key.'! !Dictionary methodsFor: 'accessing'! associationAt: key ^ self associationAt: key ifAbsent: [self errorKeyNotFound]! ! !Dictionary methodsFor: 'accessing'! associationAt: key ifAbsent: aBlock "Answer the association with the given key. If key is not found, return the result of evaluating aBlock." | index assoc | index _ self findElementOrNil: key. assoc _ array at: index. nil == assoc ifTrue: [ ^ aBlock value ]. ^ assoc! ! !Dictionary methodsFor: 'accessing'! at: key "Answer the value associated with the key." ^ self at: key ifAbsent: [self errorKeyNotFound]! ! !Dictionary methodsFor: 'accessing'! at: key ifAbsent: aBlock | index assoc | index _ self findElementOrNil: key. assoc _ array at: index. nil == assoc ifTrue: [ ^ aBlock value ]. ^ assoc value! ! !Dictionary methodsFor: 'accessing' stamp: 'jm 5/15/1998 07:20'! at: key ifPresent: aBlock "Lookup the given key in the receiver. If it is present, answer the value of evaluating the given block with the value associated with the key. Otherwise, answer nil." | v | v _ self at: key ifAbsent: [^ nil]. ^ aBlock value: v ! ! !Dictionary methodsFor: 'accessing'! at: key put: anObject "Set the value at key to be anObject. If key is not found, create a new entry for key and set is value to anObject. Answer anObject." | index element | index _ self findElementOrNil: key. element _ array at: index. element == nil ifTrue: [self atNewIndex: index put: (Association key: key value: anObject)] ifFalse: [element value: anObject]. ^ anObject! ! !Dictionary methodsFor: 'accessing'! keyAtValue: value "Answer the key that is the external name for the argument, value. If there is none, answer nil." ^self keyAtValue: value ifAbsent: [self errorValueNotFound]! ! !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: 'testing'! includes: anObject self do: [:each | anObject = each ifTrue: [^true]]. ^false! ! !Dictionary methodsFor: 'testing'! includesKey: key "Answer whether the receiver has a key equal to the argument, key." | index | index _ self findElementOrNil: key. (array at: index) == nil ifTrue: [^ false] ifFalse: [^ true]! ! !Dictionary methodsFor: 'testing'! occurrencesOf: anObject "Answer how many of the receiver's elements are equal to anObject." | count | count _ 0. self do: [:each | anObject = each ifTrue: [count _ count + 1]]. ^count! ! !Dictionary methodsFor: 'adding'! add: anAssociation | index element | index _ self findElementOrNil: anAssociation key. element _ array at: index. element == nil ifTrue: [self atNewIndex: index put: anAssociation] ifFalse: [element value: anAssociation value]. ^ anAssociation! ! !Dictionary methodsFor: 'adding'! declare: key from: aDictionary "Add key to the receiver. If key already exists, do nothing. If aDictionary includes key, then remove it from aDictionary and use its association as the element of the receiver." (self includesKey: key) ifTrue: [^ self]. (aDictionary includesKey: key) ifTrue: [self add: (aDictionary associationAt: key). aDictionary removeKey: key] ifFalse: [self add: key -> nil]! ! !Dictionary methodsFor: 'removing'! remove: anObject self shouldNotImplement! ! !Dictionary methodsFor: 'removing'! remove: anObject ifAbsent: exceptionBlock self shouldNotImplement! ! !Dictionary methodsFor: 'removing'! removeKey: key "Remove key from the receiver. If key is not in the receiver, notify an error." ^ self removeKey: key ifAbsent: [self errorKeyNotFound]! ! !Dictionary methodsFor: 'removing'! removeKey: key ifAbsent: aBlock "Remove key (and its associated value) from the receiver. If key is not in the receiver, answer the result of evaluating aBlock. Otherwise, answer the value externally named by key." | index assoc | index _ self findElementOrNil: key. assoc _ array at: index. assoc == nil ifTrue: [ ^ aBlock value ]. array at: index put: nil. tally _ tally - 1. self fixCollisionsFrom: index. ^ assoc value! ! !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: 'enumerating'! associationsDo: aBlock "Evaluate aBlock for each of the receiver's elements (key/value associations)." super do: aBlock! ! !Dictionary methodsFor: 'enumerating'! collect: aBlock "Evaluate aBlock with each of my values as the argument. Collect the resulting values into a collection that is like me. Answer with the new collection." | newCollection | newCollection _ OrderedCollection new: self size. self do: [:each | newCollection add: (aBlock value: each)]. ^ newCollection! ! !Dictionary methodsFor: 'enumerating'! do: aBlock super do: [:assoc | aBlock value: assoc value]! ! !Dictionary methodsFor: 'enumerating'! keysDo: aBlock "Evaluate aBlock for each of the receiver's keys." self associationsDo: [:association | aBlock value: association key]! ! !Dictionary methodsFor: 'enumerating'! select: aBlock "Evaluate aBlock with each of my values as the argument. Collect into a new dictionary, only those associations for which aBlock evaluates to true." | newCollection | newCollection _ self species new. self associationsDo: [:each | (aBlock value: each value) ifTrue: [newCollection add: each]]. ^newCollection! ! !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: 'printing'! storeOn: aStream | noneYet | aStream nextPutAll: '(('. aStream nextPutAll: self class name. aStream nextPutAll: ' new)'. noneYet _ true. self associationsDo: [:each | noneYet ifTrue: [noneYet _ false] ifFalse: [aStream nextPut: $;]. aStream nextPutAll: ' add: '. aStream store: each]. noneYet ifFalse: [aStream nextPutAll: '; yourself']. aStream nextPut: $)! ! !Dictionary methodsFor: 'private' stamp: 'tk 8/21/97 16:12'! copy "Must copy the associations, or later store will effect both the original and the copy" ^ self shallowCopy withArray: (array collect: [:assoc | assoc ifNil: [nil] ifNotNil: [Association key: assoc key value: assoc value]])! ! !Dictionary methodsFor: 'private'! errorKeyNotFound self error: 'key not found'! ! !Dictionary methodsFor: 'private'! errorValueNotFound self error: 'value not found'! ! !Dictionary methodsFor: 'private'! keyAt: index "May be overridden by subclasses so that fixCollisions will work" | assn | assn _ array at: index. assn == nil ifTrue: [^ nil] ifFalse: [^ assn key]! ! !Dictionary methodsFor: 'private'! noCheckAdd: anObject "Must be defined separately for Dictionary because (self findElementOrNil:) expects a key, not an association. 9/7/96 tk" array at: (self findElementOrNil: anObject key) put: anObject. tally _ tally + 1! ! !Dictionary methodsFor: 'private'! rehash "Smalltalk rehash." | newSelf | newSelf _ self species new: self size. self associationsDo: [:each | newSelf noCheckAdd: each]. array _ newSelf array! ! !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: 'private'! valueAtNewKey: aKey put: anObject atIndex: index declareFrom: aDictionary "Support for coordinating class variable and global declarations with variables that have been put in Undeclared so as to redirect all references to the undeclared variable." (aDictionary includesKey: aKey) ifTrue: [self atNewIndex: index put: ((aDictionary associationAt: aKey) value: anObject). aDictionary removeKey: aKey] ifFalse: [self atNewIndex: index put: (Association key: aKey value: anObject)]! ! !Dictionary methodsFor: 'user interface' stamp: 'tk 4/12/1998 08:54'! inspect "Open a DictionaryInspector on the receiver. Use basicInspect to get a normal (less useful) type of inspector." DictionaryInspector openOn: self withEvalPane: true! ! !Dictionary methodsFor: 'user interface' stamp: 'tk 4/12/1998 08:54'! inspectFormsWithLabel: aLabel "Open a Form Dictionary inspector on the receiver, with the given label. " ^ DictionaryInspector openOn: self withEvalPane: true withLabel: aLabel valueViewClass: FormInspectView! ! !Dictionary methodsFor: 'user interface' stamp: 'tk 4/12/1998 08:54'! inspectWithLabel: aLabel "Open a DictionaryInspector on the receiver. Use basicInspect to get a normal (less useful) type of inspector." DictionaryInspector openOn: self withEvalPane: true withLabel: aLabel! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Dictionary class instanceVariableNames: ''! !Dictionary class methodsFor: 'instance creation'! fromBraceStack: itsSize "Answer an instance of me with itsSize elements, popped in reverse order from the stack of thisContext sender. Do not call directly: this is called by {1. 2. 3} constructs." ^ self newFrom: ((Array new: itsSize) fill: itsSize fromStack: thisContext sender)! ! !Dictionary class methodsFor: 'instance creation'! newFrom: aDict "Answer an instance of me containing the same associations as aDict. Error if any key appears twice." | newDictionary | newDictionary _ self new: aDict size. aDict associationsDo: [:x | (newDictionary includesKey: x key) ifTrue: [self error: 'Duplicate key: ', x key printString] ifFalse: [newDictionary add: x]]. ^ newDictionary " NewDictionary newFrom: {1->#a. 2->#b. 3->#c} {1->#a. 2->#b. 3->#c} as: NewDictionary NewDictionary newFrom: {1->#a. 2->#b. 1->#c} {1->#a. 2->#b. 1->#c} as: NewDictionary "! ! Inspector subclass: #DictionaryInspector instanceVariableNames: 'keyArray ' classVariableNames: '' poolDictionaries: '' category: 'Interface-Inspector'! !DictionaryInspector methodsFor: 'accessing'! fieldList ^ keyArray collect: [ :key | key printString ]! ! !DictionaryInspector methodsFor: 'accessing'! inspect: aDictionary "Initialize the receiver so that it is inspecting aDictionary. There is no current selection." self initialize. (aDictionary isKindOf: Dictionary) ifFalse: [^ self error: 'DictionaryInspectors can only inspect dictionaries' ]. object _ aDictionary. contents _ ''. self calculateKeyArray! ! !DictionaryInspector methodsFor: 'selecting' stamp: 'tk 4/11/1998 13:09'! addEntry: aKey object at: aKey put: nil. self calculateKeyArray. selectionIndex _ keyArray indexOf: aKey. self changed: #inspectObject. self changed: #fieldList. self update! ! !DictionaryInspector methodsFor: 'selecting'! calculateKeyArray "Recalculate the KeyArray from the object being inspected" | sortedKeys | sortedKeys _ SortedCollection new: object size. sortedKeys sortBlock: [ :x :y | (((x isKindOf: String) & (y isKindOf: String)) or: [(x isKindOf: Number) & (y isKindOf: Number)]) ifTrue: [ x < y] ifFalse: [ (x class = y class) ifTrue: [ x printString < y printString] ifFalse: [ x class name < y class name ] ] ]. object keysDo: [ :aKey | sortedKeys add: aKey. ]. keyArray _ sortedKeys asArray. selectionIndex _ 0. ! ! !DictionaryInspector methodsFor: 'selecting'! replaceSelectionValue: anObject ^ object at: (keyArray at: selectionIndex) put: anObject! ! !DictionaryInspector methodsFor: 'selecting' stamp: 'tk 4/11/1998 13:14'! selection selectionIndex = 0 ifTrue: [^ '']. ^ object at: (keyArray at: selectionIndex)! ! !DictionaryInspector methodsFor: 'selecting'! selectionUnmodifiable "For dicionary inspectors, any selection is modifiable" ^ selectionIndex <= 0! ! !DictionaryInspector methodsFor: 'selecting' stamp: 'tk 4/12/1998 08:11'! toggleIndex: anInteger "The receiver has a list of variables of its inspected object. One of these is selected. If anInteger is the index of this variable, then deselect it. Otherwise, make the variable whose index is anInteger be the selected item." selectionIndex = anInteger ifTrue: ["same index, turn off selection" selectionIndex _ 0. contents _ ''] ifFalse: ["different index, new selection" selectionIndex _ anInteger. (selectionIndex = 0) ifTrue: [contents _ self selection] ifFalse: [contents _ self selection printString]]. self changed: #contents. self changed: #selectionIndex.! ! !DictionaryInspector methodsFor: 'menu' stamp: 'tk 4/12/1998 08:15'! addEntry | newKey aKey | newKey _ FillInTheBlank request: 'Enter new key, then type RETURN. (Expression will be evaluated for value.) Examples: #Fred ''a string'' 3+4'. aKey _ Compiler evaluate: newKey. object at: aKey put: nil. self calculateKeyArray. selectionIndex _ keyArray indexOf: aKey. self changed: #inspectObject. self changed: #fieldList. self update! ! !DictionaryInspector methodsFor: 'menu' stamp: 'tk 4/12/1998 09:05'! 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 | sel _ '(self at: ', (String streamContents: [:strm | (keyArray at: selectionIndex) storeOn: strm]) , ')'. ParagraphEditor new clipboardTextPut: sel asText. "no undo allowed"! ! !DictionaryInspector methodsFor: 'menu' stamp: 'tk 4/12/1998 09:01'! dictionaryMenu: aMenu ^ aMenu labels: 'inspect copy name references objects pointing to this value add key remove basic inspect' lines: #( 4 6) selections: #(inspectSelection copyName selectionReferences objectReferencesToSelection addEntry removeSelection inspectBasic) ! ! !DictionaryInspector methodsFor: 'menu' stamp: 'tk 4/12/1998 08:19'! removeSelection selectionIndex = 0 ifTrue: [^ self changed: #flash]. object removeKey: (keyArray at: selectionIndex). selectionIndex _ 0. contents _ ''. self calculateKeyArray. self changed: #inspectObject. self changed: #fieldList. self changed: #selection. self changed: #selectionIndex.! ! !DictionaryInspector methodsFor: 'menu' stamp: 'tk 4/12/1998 08:42'! selectionReferences "Create a browser on all references to the association of the current selection." self selectionIndex = 0 ifTrue: [^ self changed: #flash]. object class == MethodDictionary ifTrue: [^ self changed: #flash]. Smalltalk browseAllCallsOn: (object associationAt: (keyArray at: selectionIndex)). ! ! Object subclass: #Discussion instanceVariableNames: 'notes title description relatedURL ' classVariableNames: '' poolDictionaries: '' category: 'PluggableWebServer'! !Discussion commentStamp: 'di 5/22/1998 16:33' prior: 0! A Discussion has some header information and a collection of related notes.! !Discussion methodsFor: 'access' stamp: 'mjg 11/17/97 14:25'! addNote: aNote notes isNil ifTrue: [notes _ OrderedCollection new.]. notes add: aNote. ^notes size ! ! !Discussion methodsFor: 'access' stamp: 'mjg 11/17/97 14:29'! at: aKey ^notes at: aKey! ! !Discussion methodsFor: 'access' stamp: 'mjg 11/17/97 14:24'! at: aKey addNote: aNote notes isNil ifTrue: [notes _ Dictionary new.]. notes at: aKey put: aNote. ! ! !Discussion methodsFor: 'access' stamp: 'mjg 11/17/97 14:21'! description ^description! ! !Discussion methodsFor: 'access' stamp: 'mjg 11/17/97 14:21'! description: aString description _ aString! ! !Discussion methodsFor: 'access' stamp: 'mjg 11/17/97 14:20'! notes ^notes ! ! !Discussion methodsFor: 'access' stamp: 'mjg 11/17/97 14:21'! relatedURL ^relatedURL! ! !Discussion methodsFor: 'access' stamp: 'mjg 11/17/97 14:21'! relatedURL: aString relatedURL _ aString! ! !Discussion methodsFor: 'access' stamp: 'mjg 12/8/97 11:11'! status | reply | reply _ WriteStream on: String new. reply nextPutAll: 'Number of notes: ', (notes size printString). notes size > 0 ifTrue: [reply nextPutAll: '. Last note: ',(notes last timestamp).]. ^reply contents! ! !Discussion methodsFor: 'access' stamp: 'mjg 11/17/97 14:20'! title ^title! ! !Discussion methodsFor: 'access' stamp: 'mjg 11/17/97 14:21'! title: aString title _ aString! ! Object subclass: #DiskProxy instanceVariableNames: 'globalObjectName constructorSelector constructorArgs ' classVariableNames: '' poolDictionaries: '' category: 'System-Object Storage'! !DiskProxy commentStamp: 'di 5/22/1998 16:33' prior: 0! DiskProxy comment: 'A DiskProxy is an externalized form of an object to write on a DataStream. It contains a "constructor" message to regenerate the 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 special externalization, a class method that will internalize the object by reconstructing it from its defining state. We call this a "constructor" method. Then externalize such an object as a frozen message that invokes this method--a DiskProxy. (Here is the old comment: Constructing a new object is good for any object that (1) can not be externalized simply by snapshotting and reloading its instance variables (like a CompiledMethod or a Picture), or (2) wants to be free to evolve its internal representation without making stored instances obsolete (and dangerous). Snapshotting and reloading an object"s instance variables is a dangerous breach of encapsulation. The internal structure of the class is then free to evolve. All externalized instances will be useful as long as the constructor methods are maintained with the same semantics. There may be several constructor methods for a particular class. This is useful for (1) instances with characteristically different defining state, and (2) newer, evolved forms of an object and its constructors, with the old constructor methods kept around so old data 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 in the above manner and then send it a sequence of messages. This may save creating a wide variety of constructor methods. It is also useful because the newly read-in DiskProxyQ can catch messages like #objectContainedIn: (via #doesNotUnderstand:) and add them to the queue of messages to send to the new object. * We may also want a subclass of DiskProxy that evaluates a string expression 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' stamp: 'tk 3/24/98 10:41'! comeFullyUpOnReload "Internalize myself into a fully alive object after raw loading from a DataStream. (See my class comment.) DataStream will substitute the object from this eval for the DiskProxy." | globalObj symbol reader | symbol _ globalObjectName. "See if class is mapped to another name" reader _ thisContext sender receiver. (reader respondsTo: #renamed) ifTrue: [ symbol _ reader renamed at: symbol ifAbsent: [symbol]]. globalObj _ Smalltalk at: symbol ifAbsent: [^ self halt: 'Global not found']. Symbol hasInterned: constructorSelector ifTrue: [:selector | ^ globalObj perform: selector withArguments: constructorArgs]. "(Renamed not checked by arg)" ^ 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.! ! !DiskProxy methodsFor: 'all' stamp: 'tk 3/26/98 11:17'! storeDataOn: aDataStream "Besides just storing, get me inserted into references, so structures will know about class DiskProxy." super storeDataOn: aDataStream. aDataStream references at: self put: #none. "just so instVarInfo: will find it and put it into structures"! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! DiskProxy class instanceVariableNames: ''! !DiskProxy class methodsFor: 'all'! global: globalNameSymbol selector: selectorSymbol args: argArray "Create a new DiskProxy constructor with the given globalNameSymbol, selectorSymbol, and argument Array. It will internalize itself by looking up the global object name in the SystemDictionary (Smalltalk) and sending it this message with these arguments." ^ self new global: globalNameSymbol selector: selectorSymbol args: argArray! ! DisplayObject subclass: #DisplayMedium instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Graphics-Display Objects'! !DisplayMedium commentStamp: 'di 5/22/1998 16:33' prior: 0! DisplayMedium comment: 'I am a display object which can both paint myself on a medium (displayOn: messages), and can act as a medium myself. My chief subclass is Form.'! !DisplayMedium methodsFor: 'coloring'! fill: aRectangle fillColor: aForm "Replace a rectangular area of the receiver with the pattern described by aForm according to the rule over." self fill: aRectangle rule: Form over fillColor: aForm! ! !DisplayMedium methodsFor: 'coloring'! fill: aRectangle rule: anInteger fillColor: aForm "Replace a rectangular area of the receiver with the pattern described by aForm according to the rule anInteger." self subclassResponsibility! ! !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'! fillColor: aColor "Set all pixels in the receiver to the color. Must be a correct color for this depth of medium. TK 1 Jun 96" self fill: self boundingBox fillColor: aColor! ! !DisplayMedium methodsFor: 'coloring'! fillGray "Set all bits in the receiver to gray." self fill: self boundingBox fillColor: Color gray! ! !DisplayMedium methodsFor: 'coloring'! fillGray: aRectangle "Set all bits in the receiver's area defined by aRectangle to the gray mask." self fill: aRectangle rule: Form over fillColor: Color gray! ! !DisplayMedium methodsFor: 'coloring'! fillShape: aShapeForm fillColor: aColor "Fill a region corresponding to 1 bits in aShapeForm with aColor" ^ self fillShape: aShapeForm fillColor: aColor at: 0@0! ! !DisplayMedium methodsFor: 'coloring'! fillShape: aShapeForm fillColor: aColor at: location "Fill a region corresponding to 1 bits in aShapeForm with aColor" ((BitBlt destForm: self sourceForm: aShapeForm fillColor: aColor combinationRule: Form paint destOrigin: location + aShapeForm offset sourceOrigin: 0@0 extent: self extent clipRect: self boundingBox) colorMap: (Bitmap with: 0 with: 16rFFFFFFFF)) copyBits! ! !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: 'coloring'! reverse "Change all the bits in the receiver that are white to black, and the ones that are black to white." self fill: self boundingBox rule: Form reverse fillColor: self highLight! ! !DisplayMedium methodsFor: 'coloring'! reverse: aRectangle "Change all the bits in the receiver's area that intersects with aRectangle that are white to black, and the ones that are black to white." self fill: aRectangle rule: Form reverse fillColor: self highLight! ! !DisplayMedium methodsFor: 'coloring'! reverse: aRectangle fillColor: aMask "Change all the bits in the receiver's area that intersects with aRectangle according to the mask. Black does not necessarily turn to white, rather it changes with respect to the rule and the bit in a corresponding mask location. Bound to give a surprise." self fill: aRectangle rule: Form reverse fillColor: aMask! ! !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. ! ! !DisplayMedium methodsFor: 'bordering'! border: aRectangle width: borderWidth fillColor: aHalfTone "Paint a border whose rectangular area is defined by aRectangle. The width of the border of each side is borderWidth. Uses aHalfTone for drawing the border." self border: aRectangle widthRectangle: (Rectangle left: borderWidth right: borderWidth top: borderWidth bottom: borderWidth) rule: Form over fillColor: aHalfTone! ! !DisplayMedium methodsFor: 'bordering'! border: aRectangle width: borderWidth rule: combinationRule fillColor: aHalfTone "Paint a border whose rectangular area is defined by aRectangle. The width of the border of each side is borderWidth. Uses aHalfTone for drawing the border." self border: aRectangle widthRectangle: (Rectangle left: borderWidth right: borderWidth top: borderWidth bottom: borderWidth) rule: combinationRule fillColor: aHalfTone! ! !DisplayMedium methodsFor: 'bordering'! border: aRectangle widthRectangle: insets rule: combinationRule fillColor: aHalfTone "Paint a border whose rectangular area is defined by aRectangle. The width of each edge of the border is determined by the four coordinates of insets. Uses aHalfTone and combinationRule for drawing the border." (aRectangle areasOutside: (aRectangle insetBy: insets)) do: [:edgeStrip | self fill: edgeStrip rule: combinationRule fillColor: aHalfTone]! ! !DisplayMedium methodsFor: 'displaying'! copyBits: sourceRect from: sourceForm at: destOrigin clippingBox: clipRect rule: rule fillColor: aForm "Make up a BitBlt table and copy the bits." self subclassResponsibility! ! !DisplayMedium methodsFor: 'displaying'! drawLine: sourceForm from: beginPoint to: endPoint clippingBox: clipRect rule: anInteger fillColor: aForm "Draw line by copying the argument, sourceForm, starting at location beginPoint and ending at endPoint, clipped by the rectangle, clipRect. The rule and mask for copying are the arguments anInteger and aForm." self subclassResponsibility! ! Object subclass: #DisplayObject instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Graphics-Display Objects'! !DisplayObject commentStamp: 'di 5/22/1998 16:33' prior: 0! DisplayObject comment: 'The abstract protocol for most display primitives that are used by Views for presenting information on the screen.'! !DisplayObject methodsFor: 'accessing'! extent "Answer the point that represents the width and height of the receiver's bounding box." ^self boundingBox extent! ! !DisplayObject methodsFor: 'accessing'! height "Answer the number that represents the height of the receiver's bounding box." ^self boundingBox height! ! !DisplayObject methodsFor: 'accessing'! offset "Answer the amount by which the receiver should be offset when it is displayed or its position is tested." self subclassResponsibility! ! !DisplayObject methodsFor: 'accessing'! offset: aPoint "Set the amount by which the receiver's position is offset." ^self! ! !DisplayObject methodsFor: 'accessing'! relativeRectangle "Answer a Rectangle whose top left corner is the receiver's offset position and whose width and height are the same as the receiver." ^Rectangle origin: self offset extent: self extent! ! !DisplayObject methodsFor: 'accessing'! width "Answer the number that represents the width of the receiver's bounding box." ^self boundingBox width! ! !DisplayObject methodsFor: 'truncation and round off'! rounded "Convert the offset of the receiver to integer coordinates." self offset: self offset rounded! ! !DisplayObject methodsFor: 'transforming'! align: alignmentPoint with: relativePoint "Translate the receiver's offset such that alignmentPoint aligns with relativePoint." self offset: (self offset translateBy: relativePoint - alignmentPoint)! ! !DisplayObject methodsFor: 'transforming'! scaleBy: aPoint "Scale the receiver's offset by aPoint." self offset: (self offset scaleBy: aPoint)! ! !DisplayObject methodsFor: 'transforming'! translateBy: aPoint "Translate the receiver's offset." self offset: (self offset translateBy: aPoint)! ! !DisplayObject methodsFor: 'display box access'! boundingBox "Answer the rectangular area that represents the boundaries of the receiver's space of information." ^self computeBoundingBox! ! !DisplayObject methodsFor: 'display box access'! center ^ self boundingBox center! ! !DisplayObject methodsFor: 'display box access'! computeBoundingBox "Answer the rectangular area that represents the boundaries of the receiver's area for displaying information. This is the primitive for computing the area if it is not already known." self subclassResponsibility! ! !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) ! ! !DisplayObject methodsFor: 'displaying-generic'! displayAt: aDisplayPoint "Display the receiver located at aDisplayPoint with default settings for the displayMedium, rule and halftone." self displayOn: Display at: aDisplayPoint clippingBox: Display boundingBox rule: Form over fillColor: nil! ! !DisplayObject methodsFor: 'displaying-generic'! displayOn: aDisplayMedium "Simple default display in order to see the receiver in the upper left corner of screen." self displayOn: aDisplayMedium at: 0 @ 0! ! !DisplayObject methodsFor: 'displaying-generic'! displayOn: aDisplayMedium at: aDisplayPoint "Display the receiver located at aDisplayPoint with default settings for rule and halftone." self displayOn: aDisplayMedium at: aDisplayPoint clippingBox: aDisplayMedium boundingBox rule: Form over fillColor: nil! ! !DisplayObject methodsFor: 'displaying-generic'! displayOn: aDisplayMedium at: aDisplayPoint clippingBox: clipRectangle "Display the receiver located at aDisplayPoint with default settings for rule and halftone. Information to be displayed must be confined to the area that intersects with clipRectangle." self displayOn: aDisplayMedium at: aDisplayPoint clippingBox: clipRectangle rule: Form over fillColor: nil! ! !DisplayObject methodsFor: 'displaying-generic'! displayOn: aDisplayMedium at: aDisplayPoint clippingBox: clipRectangle rule: ruleInteger fillColor: aForm "This is the basic display primitive for graphic display objects. Display the receiver located at aDisplayPoint with rule, ruleInteger, and mask, aForm. Information to be displayed must be confined to the area that intersects with clipRectangle." self subclassResponsibility! ! !DisplayObject methodsFor: 'displaying-generic'! displayOn: aDisplayMedium at: aDisplayPoint rule: ruleInteger "Display the receiver located at aPoint with default setting for the halftone and clippingBox." self displayOn: aDisplayMedium at: aDisplayPoint clippingBox: aDisplayMedium boundingBox rule: ruleInteger fillColor: nil! ! !DisplayObject methodsFor: 'displaying-generic'! displayOn: aDisplayMedium transformation: displayTransformation clippingBox: clipRectangle "Display primitive for the receiver where a DisplayTransformation is provided as an argument. Alignment is defaulted to the receiver's rectangle. Information to be displayed must be confined to the area that intersects with clipRectangle." self displayOn: aDisplayMedium transformation: displayTransformation clippingBox: clipRectangle align: self relativeRectangle center with: self relativeRectangle center rule: Form over fillColor: nil! ! !DisplayObject methodsFor: 'displaying-generic'! displayOn: aDisplayMedium transformation: displayTransformation clippingBox: clipRectangle align: alignmentPoint with: relativePoint "Display primitive where a DisplayTransformation is provided as an argument, rule is over and mask is Form black. Information to be displayed must be confined to the area that intersects with clipRectangle." self displayOn: aDisplayMedium transformation: displayTransformation clippingBox: clipRectangle align: alignmentPoint with: relativePoint rule: Form over fillColor: nil! ! !DisplayObject methodsFor: 'displaying-generic'! displayOn: aDisplayMedium transformation: displayTransformation clippingBox: clipRectangle align: alignmentPoint with: relativePoint rule: ruleInteger fillColor: aForm "Display the receiver where a DisplayTransformation is provided as an argument, rule is ruleInteger and mask is aForm. Translate by relativePoint-alignmentPoint. Information to be displayed must be confined to the area that intersects with clipRectangle." | absolutePoint | absolutePoint _ displayTransformation applyTo: relativePoint. self displayOn: aDisplayMedium at: (absolutePoint - alignmentPoint) clippingBox: clipRectangle rule: ruleInteger fillColor: aForm ! ! !DisplayObject methodsFor: 'displaying-generic'! displayOn: aDisplayMedium transformation: displayTransformation clippingBox: clipRectangle fixedPoint: aPoint "Display the receiver where a DisplayTransformation is provided as an argument, rule is over and mask is Form black. No translation. Information to be displayed must be confined to the area that intersects with clipRectangle." self displayOn: aDisplayMedium transformation: displayTransformation clippingBox: clipRectangle align: aPoint with: aPoint rule: Form over fillColor: nil! ! !DisplayObject methodsFor: 'displaying-generic'! displayOn: aDisplayMedium transformation: displayTransformation clippingBox: clipRectangle rule: ruleInteger fillColor: aForm "Display the receiver where a DisplayTransformation is provided as an argument, rule is ruleInteger and mask is aForm. No translation. Information to be displayed must be confined to the area that intersects with clipRectangle." self displayOn: aDisplayMedium transformation: displayTransformation clippingBox: clipRectangle align: self relativeRectangle origin with: self relativeRectangle origin rule: ruleInteger fillColor: aForm! ! !DisplayObject methodsFor: 'displaying-generic'! displayOnPort: aPort self displayOnPort: aPort at: 0@0! ! !DisplayObject methodsFor: 'displaying-generic' stamp: 'jm 10/21/97 16:56'! displayOnPort: port at: location rule: rule port copyForm: self to: location rule: rule. ! ! !DisplayObject methodsFor: 'displaying-generic'! followCursor "Just show the Form following the mouse. 6/21/96 tk" Cursor blank showWhile: [self follow: [Sensor cursorPoint] while: [Sensor noButtonPressed]] ! ! !DisplayObject methodsFor: 'displaying-Display'! display "Display the receiver on the Display at location 0,0." self displayOn: Display! ! !DisplayObject methodsFor: 'displaying-Display'! follow: locationBlock while: durationBlock "Move an image around on the Display. Restore the background continuously without causing flashing. The argument, locationBlock, supplies each new location, and the argument, durationBlock, supplies true to continue, and then false to stop. 8/20/96 sw: call follow:while:bitsBehind: to do the real work. Note that th method now returns the final bits behind as method value." | bitsBehind loc | bitsBehind _ Form fromDisplay: ((loc _ locationBlock value) extent: self extent). ^ self follow: locationBlock while: durationBlock bitsBehind: bitsBehind startingLoc: loc! ! !DisplayObject methodsFor: 'displaying-Display' stamp: 'jm 10/22/97 07:39'! follow: locationBlock while: durationBlock bitsBehind: initialBitsBehind startingLoc: loc "Move an image around on the Display. Restore the background continuously without causing flashing. The argument, locationBlock, supplies each new location, and the argument, durationBlock, supplies true to continue or false to stop. This variant takes the bitsBehind as an input argument, and returns the final saved saved bits as method value." | location rect1 save1 save1Blt buffer bufferBlt newLoc rect2 bothRects | location _ loc. rect1 _ location extent: self extent. save1 _ initialBitsBehind. save1Blt _ BitBlt toForm: save1. buffer _ Form extent: self extent*2 depth: Display depth. "Holds overlapping region" bufferBlt _ BitBlt toForm: buffer. self displayOn: Display at: location rule: Form paint. [durationBlock value] whileTrue: [ newLoc _ locationBlock value. newLoc ~= location ifTrue: [ rect2 _ newLoc extent: self extent. bothRects _ rect1 merge: rect2. (rect1 intersects: rect2) ifTrue: [ "when overlap, buffer background for both rectangles" bufferBlt copyFrom: bothRects in: Display to: 0@0. bufferBlt copyFrom: save1 boundingBox in: save1 to: rect1 origin - bothRects origin. "now buffer is clean background; get new bits for save1" save1Blt copy: (0@0 extent: self extent) from: rect2 origin - bothRects origin in: buffer. self displayOnPort: bufferBlt at: rect2 origin - bothRects origin rule: Form paint. Display copy: bothRects from: 0@0 in: buffer rule: Form over] ifFalse: [ "when no overlap, do the simple thing (both rects might be too big)" Display copy: (location extent: save1 extent) from: 0@0 in: save1 rule: Form over. save1Blt copyFrom: rect2 in: Display to: 0@0. self displayOn: Display at: newLoc rule: Form paint]. location _ newLoc. rect1 _ rect2]]. ^ save1 displayOn: Display at: location ! ! !DisplayObject methodsFor: 'displaying-Display' stamp: 'di 9/12/97 11:09'! isTransparent ^ false! ! !DisplayObject methodsFor: 'displaying-Display'! slideFrom: startPoint to: stopPoint nSteps: nSteps "does not display at the first point, but does at the last" | i p delta | i_0. p_ startPoint. delta _ (stopPoint-startPoint) // nSteps. ^ self follow: [p_ p+delta] while: [(i_i+1) < nSteps]! ! !DisplayObject methodsFor: 'displaying-Display' stamp: 'jm 10/22/97 07:43'! slideFrom: startPoint to: stopPoint nSteps: nSteps delay: milliSecs "Slide this object across the display over the given number of steps, pausing for the given number of milliseconds after each step." "Note: Does not display at the first point, but does at the last." | i p delta | i _ 0. p _ startPoint. delta _ (stopPoint - startPoint) / nSteps asFloat. ^ self follow: [(p _ p + delta) truncated] while: [ (Delay forMilliseconds: milliSecs) wait. (i _ i + 1) < nSteps] ! ! !DisplayObject methodsFor: 'displaying-Display' stamp: 'di 10/19/97 12:05'! slideFrom: startPoint to: stopPoint nSteps: nSteps delay: milliSecs andStay: stayAtEnd "Does not display at the first point, but does at the last. Moreover, if stayAtEnd is true, it leaves the dragged image at the stopPoint" | i done | i _ 0. ^ self follow: [startPoint + ((stopPoint-startPoint) * i // nSteps)] while: [milliSecs ifNotNil: [(Delay forMilliseconds: milliSecs) wait]. ((done _ (i _ i+1) > nSteps) and: [stayAtEnd]) ifTrue: [^ self "Return without clearing the image"]. done not]! ! !DisplayObject methodsFor: 'fileIn/Out'! writeOnFileNamed: fileName "Saves the receiver on the file fileName in the format: fileCode, depth, extent, offset, bits." | file | file _ FileStream newFileNamed: fileName. file binary. file nextPut: 2. "file code = 2" self writeOn: file. file close " | f | [(f _ Form fromUser) boundingBox area>25] whileTrue: [f writeOnFileNamed: 'test.form'. (Form newFromFileNamed: 'test.form') display]. "! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! DisplayObject class instanceVariableNames: ''! !DisplayObject class methodsFor: 'fileIn/Out' stamp: 'jm 3/27/98 14:19'! collectionFromFileNamed: fileName "Answer a collection of Forms read from the external file named fileName. The file format is: fileCode, {depth, extent, offset, bits}." | formList f fileCode | formList _ OrderedCollection new. f _ (FileStream oldFileNamed: fileName) readOnly; binary. fileCode _ f next. fileCode = 1 ifTrue: [ [f atEnd] whileFalse: [formList add: (self new readFromOldFormat: f)]] ifFalse: [ fileCode = 2 ifFalse: [self error: 'unknown Form file format'. ^ formList]. [f atEnd] whileFalse: [formList add: (self new readFrom: f)]]. f close. ^ formList ! ! !DisplayObject class methodsFor: 'fileIn/Out'! writeCollection: coll onFileNamed: fileName "Saves a collection of Forms on the file fileName in the format: fileCode, {depth, extent, offset, bits}." | file | file _ FileStream newFileNamed: fileName. file binary. file nextPut: 2. "file code = 2" coll do: [:f | f writeOn: file]. file close " | f c | c _ OrderedCollection new. [(f _ Form fromUser) boundingBox area>25] whileTrue: [c add: f]. Form writeCollection: c onFileNamed: 'test.forms'. c _ Form collectionFromFileNamed: 'test.forms'. 1 to: c size do: [:i | (c at: i) displayAt: 0@(i*100)]. "! ! CharacterScanner subclass: #DisplayScanner instanceVariableNames: 'lineY runX foregroundColor backgroundColor lastSourceDepth fillBlt lineHeight paragraph paragraphColor morphicOffset ' classVariableNames: '' poolDictionaries: 'TextConstants ' category: 'Graphics-Support'! !DisplayScanner commentStamp: 'di 5/22/1998 16:33' prior: 0! DisplayScanner comment: 'My instances are used to scan text and display it on the screen or in a hidden form.'! !DisplayScanner methodsFor: 'scanning' stamp: 'di 11/13/97 12:21'! displayLine: textLine offset: offset leftInRun: leftInRun "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). leftInRun is the # of characters left to scan in the current run; when 0, it is time to call setStopConditions." | done stopCondition nowLeftInRun | line _ textLine. morphicOffset _ offset. leftMargin _ (line leftMarginForAlignment: textStyle alignment) + offset x. runX _ destX _ leftMargin. rightMargin _ line rightMargin + offset x. lineY _ line top + offset y. lineHeight _ line lineHeight. fillBlt == nil ifFalse: ["Not right" fillBlt destX: line left destY: lineY width: leftMargin - line left height: lineHeight; copyBits]. lastIndex _ line first. leftInRun <= 0 ifTrue: [self setStopConditions. "also sets the font" nowLeftInRun _ text runLengthFor: lastIndex] ifFalse: [nowLeftInRun _ leftInRun]. destY _ lineY + line baseline - font ascent. runStopIndex _ lastIndex + (nowLeftInRun - 1) min: line last. spaceCount _ 0. done _ false. [done] whileFalse: [stopCondition _ self scanCharactersFrom: lastIndex to: runStopIndex in: text string rightX: rightMargin stopConditions: stopConditions kern: kern displaying: true. "see setStopConditions for stopping conditions for displaying." done _ self perform: stopCondition]. fillBlt == nil ifFalse: [fillBlt destX: destX destY: lineY width: line right-destX height: lineHeight; copyBits]. ^ runStopIndex - lastIndex "Number of characters remaining in the current run"! ! !DisplayScanner methodsFor: 'scanning' stamp: 'di 10/31/97 09:47'! 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. foregroundColor _ paragraphColor _ aParagraph foregroundColor. backgroundColor _ aParagraph backgroundColor. aParagraph backgroundColor isTransparent ifTrue: [fillBlt _ nil] ifFalse: [fillBlt _ self copy. "Blt to fill spaces, tabs, margins" fillBlt sourceForm: nil; sourceOrigin: 0@0. fillBlt 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 == nil ifFalse: [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) min: 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 kern: kern displaying: true. "see setStopConditions for stopping conditions for displaying." done _ self perform: stopCondition]. fillBlt == nil ifFalse: [fillBlt destX: destX destY: lineY width: visibleRectangle right-destX height: lineHeight; copyBits]. lineY _ lineY + lineHeight]! ! !DisplayScanner methodsFor: 'scanning' stamp: 'di 11/13/97 12:22'! placeEmbeddedObject: anchoredMorph (super placeEmbeddedObject: anchoredMorph) ifFalse: [^ false]. anchoredMorph isMorph ifTrue: [morphicOffset = (0@0) ifTrue: [anchoredMorph position: (destX - width)@lineY]] ifFalse: [destY _ lineY. height _ anchoredMorph height. runX _ destX. anchoredMorph displayOn: destForm at: destX - width@destY]. ^ true! ! !DisplayScanner methodsFor: 'stop conditions'! cr "When a carriage return is encountered, simply increment the pointer into the paragraph." lastIndex_ lastIndex + 1. ^false! ! !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' stamp: 'di 10/21/97 20:11'! 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) min: line last. self setStopConditions. ^ false! ! !DisplayScanner methodsFor: 'stop conditions' stamp: 'di 10/21/97 13:53'! 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 == nil ifFalse: [fillBlt destX: oldX destY: destY width: destX - oldX height: height; copyBits]. lastIndex _ lastIndex + 1. ^ false! ! !DisplayScanner methodsFor: 'stop conditions'! setStopConditions "Set the font and the stop conditions for the current run." self setFont. stopConditions at: Space asciiValue + 1 put: (textStyle alignment = Justified ifTrue: [#paddedSpace])! ! !DisplayScanner methodsFor: 'stop conditions' stamp: 'di 10/21/97 13:53'! 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 == nil ifFalse: [fillBlt destX: oldX destY: destY width: destX - oldX height: height; copyBits]. lastIndex _ lastIndex + 1. ^ false! ! !DisplayScanner methodsFor: 'private'! doesDisplaying ^true! ! !DisplayScanner methodsFor: 'private' stamp: 'di 10/31/97 12:49'! fillBlt ^ fillBlt! ! !DisplayScanner methodsFor: 'private' stamp: 'di 10/21/97 13:50'! 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" fillBlt == nil ifTrue: [^ self]. "No fill requested" "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' stamp: 'di 10/21/97 14:01'! setFont | map | foregroundColor _ paragraphColor. super setFont. "Sets font and emphasis bits, and maybe foregroundColor" 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: ((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' stamp: 'di 10/31/97 09:42'! text: t textStyle: ts foreground: foreColor background: backColor fillBlt: blt text _ t. textStyle _ ts. foregroundColor _ paragraphColor _ foreColor. (backgroundColor _ backColor) isTransparent ifFalse: [fillBlt _ blt. fillBlt fillColor: backgroundColor]. ! ! !DisplayScanner methodsFor: 'private'! textColor: textColor foregroundColor _ textColor! ! Form subclass: #DisplayScreen instanceVariableNames: 'clippingBox ' classVariableNames: 'ScreenSave ' poolDictionaries: '' category: 'Graphics-Display Objects'! !DisplayScreen commentStamp: 'di 5/22/1998 16:33' prior: 0! DisplayScreen comment: 'There is only one instance of me, Display. It is a global and is used to handle general user requests to deal with the whole display screen. Although I offer no protocol, my name provides a way to distinguish this special instance from all other Forms. This is useful, for example, in dealing with saving and restoring the system. To change the depth of your Display... Display newDepth: 16. Display newDepth: 8. Display newDepth: 1. Valid display depths are 1, 2, 4, 8, 16 and 32. It is suggested that you run with your monitors setting the same, for better speed and color fidelity. Note that this can add up to 4Mb for the Display form. Finally, note that newDepth: ends by executing a ''ControlManager restore'' which currently terminates the active process, so nothing that follows in the doit will get executed. Depths 1, 2, 4 and 8 bits go through a color map to put color on the screen, but 16 and 32-bit color use the pixel values directly for RGB color (5 and 8 bits per, respectivlely). The color choice an be observed by executing Color fromUser in whatever depth you are using. '! !DisplayScreen methodsFor: 'displaying'! copyBits: rect from: sf at: destOrigin clippingBox: clipRect rule: cr fillColor: hf (BitBlt destForm: self sourceForm: sf fillColor: hf combinationRule: cr destOrigin: destOrigin sourceOrigin: rect origin extent: rect extent clipRect: (clipRect intersect: clippingBox)) copyBits! ! !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' stamp: 'jm 5/22/1998 01:23'! flash: aRectangle "Flash the area of the screen defined by the given rectangle." self reverse: aRectangle. self forceDisplayUpdate. (Delay forMilliseconds: 100) wait. self reverse: aRectangle. self forceDisplayUpdate. ! ! !DisplayScreen methodsFor: 'other'! boundingBox clippingBox == nil ifTrue: [clippingBox _ super boundingBox]. ^ clippingBox! ! !DisplayScreen methodsFor: 'other'! clippingTo: aRect do: aBlock "Display clippingTo: Rectangle fromUser do: [ScheduledControllers restore: Display fullBoundingBox]" | saveClip | saveClip _ clippingBox. clippingBox _ aRect. aBlock value. clippingBox _ saveClip! ! !DisplayScreen methodsFor: 'other' stamp: 'jm 5/17/1998 08:29'! deferUpdates: aBoolean "Set the deferUpdates flag in the virtual machine. When this flag is true, BitBlt operations on the Display are not automatically propagated to the screen. If this underlying platform does not support deferred updates, this primitive will fail. Answer the receiver if the primitive succeeds, nil if it fails." ^ nil "answer nil if primitive fails" ! ! !DisplayScreen methodsFor: 'other' stamp: 'jm 5/21/1998 23:48'! forceDisplayUpdate "On platforms that buffer screen updates, force the screen to be updated immediately. On other platforms, or if the primitive is not implemented, do nothing." "do nothing if primitive fails"! ! !DisplayScreen methodsFor: 'other' stamp: 'jm 5/19/1998 17:50'! forceToScreen: aRectangle "Force the given rectangular section of the Display to be copied to the screen. The primitive call does nothing if the primitive is not implemented. Typically used when the deferUpdates flag in the virtual machine is on; see deferUpdates:." self primShowRectLeft: aRectangle left right: aRectangle right top: aRectangle top bottom: aRectangle bottom. ! ! !DisplayScreen methodsFor: 'other'! fullBoundingBox ^ super boundingBox! ! !DisplayScreen methodsFor: 'other'! fullScreen "Display fullScreen" ScreenSave notNil ifTrue: [Display _ ScreenSave]. clippingBox _ super boundingBox! ! !DisplayScreen methodsFor: 'other'! height ^ self boundingBox height! ! !DisplayScreen methodsFor: 'other' stamp: 'di 5/11/1998 15:30'! newDepth: pixelSize " Display newDepth: 8. Display newDepth: 1. " self newDepthNoRestore: pixelSize. Smalltalk isMorphic ifTrue: [World fullRepaintNeeded] ifFalse: [ScheduledControllers unCacheWindows; restore].! ! !DisplayScreen methodsFor: 'other'! replacedBy: aForm do: aBlock "Permits normal display to draw on aForm instead of the display." ScreenSave _ self. Display _ aForm. aBlock value. Display _ self. ScreenSave _ nil.! ! !DisplayScreen methodsFor: 'other' stamp: 'jm 5/6/1998 21:56'! restoreAfter: aBlock "Evaluate the block, wait for a mouse click, and then restore the screen." aBlock value. Sensor waitButton. World ifNotNil: [World fullRepaintNeeded. ^ self]. ScheduledControllers restore. ScheduledControllers activeController view emphasize. ! ! !DisplayScreen methodsFor: 'other'! usableArea "Answer the usable area of the receiver. 5/22/96 sw." ^ self boundingBox deepCopy! ! !DisplayScreen methodsFor: 'other'! width ^ self boundingBox width! ! !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: #()! ! !DisplayScreen methodsFor: 'private'! beDisplay "Primitive. Tell the interpreter to use the receiver as the current display image. Fail if the form is too wide to fit on the physical display. Essential. See Object documentation whatIsAPrimitive." self primitiveFailed! ! !DisplayScreen methodsFor: 'private' stamp: 'di 5/11/1998 15:28'! 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" Smalltalk isMorphic ifTrue: [area _ area + area "World canvas bitmap still separate"] ifFalse: [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: 'private' stamp: 'jm 5/19/1998 16:32'! primShowRectLeft: l right: r top: t bottom: b "Copy the given rectangular section of the Display to to the screen. This primitive is not implemented on all platforms. Do nothing if it fails. " "do nothing if primitive fails" ! ! !DisplayScreen methodsFor: 'private'! setExtent: aPoint "DisplayScreen startUp" width _ aPoint x. height _ aPoint y. clippingBox _ nil. self bitsSize. "Cause any errors before unrecoverable" bits _ nil. "Free up old bitmap in case space is low" bits _ Bitmap new: self bitsSize. self boundingBox! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! DisplayScreen class instanceVariableNames: ''! !DisplayScreen class methodsFor: 'display box access'! boundingBox "Answer the bounding box for the form representing the current display screen." ^Display boundingBox! ! !DisplayScreen class methodsFor: 'snapshots'! actualScreenSize ^ 640@480! ! !DisplayScreen class methodsFor: 'snapshots'! shutDown "Minimize Display memory saved in image" Display setExtent: 240@120! ! !DisplayScreen class methodsFor: 'snapshots'! startUp "DisplayScreen startUp" Display setExtent: self actualScreenSize. Display beDisplay! ! DisplayObject subclass: #DisplayText instanceVariableNames: 'text textStyle offset form foreColor backColor ' classVariableNames: '' poolDictionaries: 'TextConstants ' category: 'Graphics-Display Objects'! !DisplayText commentStamp: 'di 5/22/1998 16:33' prior: 0! DisplayText comment: 'I represent Text whose emphasis changes are mapped to a set of fonts. My instances have an offset used in determining screen placement for displaying. They get used two different ways in the system. In the user interface, they mainly hold onto some text which is viewed by some form of ParagraphEditor. However, as a DisplayObject, they may need to display efficiently, so my instances have a cache for the bits.'! !DisplayText methodsFor: 'accessing'! alignedTo: alignPointSelector "Return a copy with offset according to alignPointSelector which is one of... #(topLeft, topCenter, topRight, leftCenter, center, etc)" | boundingBox | boundingBox _ 0@0 corner: self form extent. ^ self shallowCopy offset: (0@0) - (boundingBox perform: alignPointSelector)! ! !DisplayText methodsFor: 'accessing'! fontsUsed "Return a list of all fonts used currently in this text. 8/19/96 tk" ^ text runs values asSet collect: [:each | textStyle fontAt: each]! ! !DisplayText methodsFor: 'accessing'! form "Answer the form into which the receiver's display bits are cached." form == nil ifTrue: [self composeForm]. ^form! ! !DisplayText methodsFor: 'accessing'! lineGrid "Answer the relative space between lines of the receiver's text." ^textStyle lineGrid! ! !DisplayText methodsFor: 'accessing'! numberOfLines "Answer the number of lines of text in the receiver." ^self height // text lineGrid! ! !DisplayText methodsFor: 'accessing'! offset "Refer to the comment in DisplayObject|offset." ^offset! ! !DisplayText methodsFor: 'accessing'! offset: aPoint "Refer to the comment in DisplayObject|offset:." offset _ aPoint! ! !DisplayText methodsFor: 'accessing'! string "Answer the string of the characters displayed by the receiver." ^text string! ! !DisplayText methodsFor: 'accessing'! text "Answer the text displayed by the receiver." ^text! ! !DisplayText methodsFor: 'accessing'! text: aText "Set the receiver to display the argument, aText." text _ aText. form _ nil. self changed. ! ! !DisplayText methodsFor: 'accessing'! textStyle "Answer the style by which the receiver displays its text." ^textStyle! ! !DisplayText methodsFor: 'accessing'! textStyle: aTextStyle "Set the style by which the receiver should display its text." textStyle _ aTextStyle. form _ nil. self changed. ! ! !DisplayText methodsFor: 'displaying'! displayOn: aDisplayMedium at: aDisplayPoint clippingBox: clipRectangle rule: ruleInteger fillColor: aForm "Refer to the comment in DisplayObject|displayOn:at:clippingBox:rule:mask:." self form displayOn: aDisplayMedium at: aDisplayPoint + offset clippingBox: clipRectangle rule: ruleInteger fillColor: aForm! ! !DisplayText methodsFor: 'displaying'! displayOn: aDisplayMedium transformation: displayTransformation clippingBox: clipRectangle align: alignmentPoint with: relativePoint rule: ruleInteger fillColor: aForm "Refer to the comment in DisplayObject|displayOn:transformation:clippingBox:align:with:rule:mask:." | absolutePoint | absolutePoint _ displayTransformation applyTo: relativePoint. absolutePoint _ absolutePoint x asInteger @ absolutePoint y asInteger. self displayOn: aDisplayMedium at: absolutePoint - alignmentPoint clippingBox: clipRectangle rule: ruleInteger fillColor: aForm! ! !DisplayText methodsFor: 'displaying'! displayOnPort: aPort at: location self form displayOnPort: aPort at: location + offset! ! !DisplayText methodsFor: 'display box access'! boundingBox "Refer to the comment in DisplayObject|boundingBox." ^self form boundingBox! ! !DisplayText methodsFor: 'display box access'! computeBoundingBox "Compute minimum enclosing rectangle around characters." | character font width carriageReturn lineWidth lineHeight | carriageReturn _ Character cr. width _ lineWidth _ 0. font _ textStyle defaultFont. lineHeight _ textStyle lineGrid. 1 to: text size do: [:i | character _ text at: i. character = carriageReturn ifTrue: [lineWidth _ lineWidth max: width. lineHeight _ lineHeight + textStyle lineGrid. width _ 0] ifFalse: [width _ width + (font widthOf: character)]]. lineWidth _ lineWidth max: width. ^offset extent: lineWidth @ lineHeight! ! !DisplayText methodsFor: 'converting' stamp: 'tk 10/21/97 12:28'! 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 isTransparent ifTrue: [para rule: Form paint]. ^ para! ! !DisplayText methodsFor: 'private'! composeForm form _ self asParagraph asForm! ! !DisplayText methodsFor: 'private'! setText: aText textStyle: aTextStyle offset: aPoint text _ aText. textStyle _ aTextStyle. offset _ aPoint. form _ nil! ! !DisplayText methodsFor: 'color'! backgroundColor backColor == nil ifTrue: [^ Color transparent]. ^ backColor! ! !DisplayText methodsFor: 'color'! foregroundColor foreColor == nil ifTrue: [^ Color black]. ^ foreColor! ! !DisplayText methodsFor: 'color'! foregroundColor: cf backgroundColor: cb foreColor _ cf. backColor _ cb! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! DisplayText class instanceVariableNames: ''! !DisplayText class methodsFor: 'instance creation'! text: aText "Answer an instance of me such that the text displayed is aText according to the system's default text style." ^self new setText: aText textStyle: DefaultTextStyle copy offset: 0 @ 0! ! !DisplayText class methodsFor: 'instance creation'! text: aText textStyle: aTextStyle "Answer an instance of me such that the text displayed is aText according to the style specified by aTextStyle." ^self new setText: aText textStyle: aTextStyle offset: 0 @ 0! ! !DisplayText class methodsFor: 'instance creation'! text: aText textStyle: aTextStyle offset: aPoint "Answer an instance of me such that the text displayed is aText according to the style specified by aTextStyle. The display of the information should be offset by the amount given as the argument, aPoint." ^self new setText: aText textStyle: aTextStyle offset: aPoint! ! !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 and this 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."! ! View subclass: #DisplayTextView instanceVariableNames: 'rule mask editParagraph centered ' classVariableNames: '' poolDictionaries: '' category: 'Graphics-Views'! !DisplayTextView commentStamp: 'di 5/22/1998 16:33' prior: 0! DisplayTextView comment: 'I represent a view of an instance of DisplayText.'! !DisplayTextView methodsFor: 'initialize-release'! initialize "Refer to the comment in View|initialize." super initialize. centered _ false! ! !DisplayTextView methodsFor: 'accessing'! centered centered _ true. self centerText! ! !DisplayTextView methodsFor: 'accessing'! fillColor "Answer an instance of class Form that is to be used as the mask when displaying the receiver's model (a DisplayText)." ^ mask! ! !DisplayTextView methodsFor: 'accessing'! fillColor: aForm "Set aForm to be the mask used when displaying the receiver's model." mask _ aForm! ! !DisplayTextView methodsFor: 'accessing'! isCentered ^centered! ! !DisplayTextView methodsFor: 'accessing'! mask "Answer an instance of class Form that is to be used as the mask when displaying the receiver's model (a DisplayText)." ^ mask! ! !DisplayTextView methodsFor: 'accessing'! rule "Answer a number from 0 to 15 that indicates which of the sixteen display rules is to be used when copying the receiver's model (a DisplayText) onto the display screen." rule == nil ifTrue: [^self defaultRule] ifFalse: [^rule]! ! !DisplayTextView methodsFor: 'accessing'! rule: anInteger "Set anInteger to be the rule used when displaying the receiver's model." rule _ anInteger! ! !DisplayTextView methodsFor: 'controller access'! defaultController "Refer to the comment in View|defaultController." ^self defaultControllerClass newParagraph: editParagraph! ! !DisplayTextView methodsFor: 'controller access'! defaultControllerClass "Refer to the comment in View|defaultControllerClass." ^ParagraphEditor! ! !DisplayTextView methodsFor: 'window access'! defaultWindow "Refer to the comment in View|defaultWindow." ^self inverseDisplayTransform: (editParagraph boundingBox expandBy: 6 @ 6)! ! !DisplayTextView methodsFor: 'window access'! window: aWindow "Refer to the comment in View|window:." super window: aWindow. self centerText! ! !DisplayTextView methodsFor: 'model access'! model: aDisplayText "Refer to the comment in View|model:." super model: aDisplayText. editParagraph _ model asParagraph. self centerText! ! !DisplayTextView methodsFor: 'displaying'! display "Refer to the comment in View|display." self isUnlocked ifTrue: [self positionText]. super display! ! !DisplayTextView methodsFor: 'displaying'! displayView "Refer to the comment in View|displayView." self clearInside. (self controller isKindOf: ParagraphEditor ) ifTrue: [controller changeParagraph: editParagraph]. editParagraph foregroundColor: self foregroundColor backgroundColor: self backgroundColor. self isCentered ifTrue: [editParagraph displayOn: Display transformation: self displayTransformation clippingBox: self insetDisplayBox fixedPoint: editParagraph boundingBox center] ifFalse: [editParagraph displayOn: Display]! ! !DisplayTextView methodsFor: 'displaying'! uncacheBits "Normally only sent to a StandardSystemView, but for casees where a DisplayTextView is used alone, without a superview, in which we make this a no-op, put in so that the Character Recognizer doesn't fail. 8/9/96 sw"! ! !DisplayTextView methodsFor: 'deEmphasizing'! deEmphasizeView "Refer to the comment in View|deEmphasizeView." (self controller isKindOf: ParagraphEditor) ifTrue: [controller deselect]! ! !DisplayTextView methodsFor: 'private'! centerText self isCentered ifTrue: [editParagraph align: editParagraph boundingBox center with: self getWindow center]! ! !DisplayTextView methodsFor: 'private'! defaultRule ^Form over! ! !DisplayTextView methodsFor: 'private'! positionText | box | box _ (self displayBox insetBy: 6@6) origin extent: editParagraph boundingBox extent. editParagraph wrappingBox: box clippingBox: box. self centerText! ! !DisplayTextView methodsFor: 'lock access'! lock "Refer to the comment in View|lock. Must do what would be done by displaying..." self isUnlocked ifTrue: [self positionText]. super lock! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! DisplayTextView class instanceVariableNames: ''! !DisplayTextView class methodsFor: 'examples'! example2 "Create a standarad system view with two parts, one editable, the other not." | topView aDisplayTextView | topView _ StandardSystemView new. topView label: 'Text Editor'. aDisplayTextView _ self new model: 'test string label' asDisplayText. aDisplayTextView controller: NoController new. aDisplayTextView window: (0 @ 0 extent: 100 @ 100). aDisplayTextView borderWidthLeft: 2 right: 0 top: 2 bottom: 2. topView addSubView: aDisplayTextView. aDisplayTextView _ self new model: 'test string' asDisplayText. aDisplayTextView window: (0 @ 0 extent: 100 @ 100). aDisplayTextView borderWidth: 2. topView addSubView: aDisplayTextView align: aDisplayTextView viewport topLeft with: topView lastSubView viewport topRight. topView controller open "DisplayTextView example2"! ! !DisplayTextView class methodsFor: 'examples'! example3 "Create a passive view of some text on the screen." | view | view_ self new model: 'this is a test of one line and the second line' asDisplayText. view translateBy: 100@100. view borderWidth: 2. view display. view release "DisplayTextView example3"! ! !DisplayTextView class methodsFor: 'examples'! example4 "Create four passive views of some text on the screen with fat borders." | view | view_ self new model: 'this is a test of one line and the second line' asDisplayText. view translateBy: 100@100. view borderWidth: 5. view display. 3 timesRepeat: [view translateBy: 100@100. view display]. view release "DisplayTextView example4"! ! FileDirectory subclass: #DosFileDirectory instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'System-Files'! !DosFileDirectory commentStamp: 'di 5/22/1998 16:33' prior: 0! I represent a DOS or Windows FileDirectory. ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! DosFileDirectory class instanceVariableNames: ''! !DosFileDirectory class methodsFor: 'platform specific' stamp: 'jm 5/8/1998 20:45'! maxFileNameLength ^ 255 ! ! !DosFileDirectory class methodsFor: 'platform specific' stamp: 'jm 12/4/97 22:57'! pathNameDelimiter ^ $\ ! ! EToyHolder subclass: #DriveACar instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Experimental-Miscellaneous'! !DriveACar methodsFor: 'all' stamp: 'sw 2/16/98 03:40'! chooseExternalNameFor: anObject "The intent here is for the e-toy, within limits, to allocate these names" | count names | names _ self playfield world allKnownNames. count _ self playfield submorphs size. (count == 1 and: [(names includes: 'car') not]) ifTrue: [^ 'car']. (count == 2 and: [(names includes: 'steering') not]) ifTrue: [^ 'steering']. ^ super chooseExternalNameFor: anObject ! ! !DriveACar methodsFor: 'all' stamp: 'sw 2/12/98 14:17'! favoredActorNames ^ #('car' 'steering'), super favoredActorNames! ! !DriveACar methodsFor: 'all' stamp: 'sw 9/20/97 23:16'! scaffoldingToyStrings ^ #('Welcome!! In this toy, you will build a car and drive it.' 'Whatever you (dear author) put here will go out on the saved etoy files.' 'Blah blah blah blah' 'Blah blah blah blah blah blah blah blah blah blah...')! ! Morph subclass: #DropShadowMorph instanceVariableNames: 'shadowOffset ' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Widgets'! !DropShadowMorph commentStamp: 'di 5/22/1998 16:33' prior: 0! DropShadowMorph comment: 'DropShadows display all their submorphs at a given offset and in given color.'! !DropShadowMorph methodsFor: 'initialization' stamp: 'di 11/3/97 12:26'! initialize super initialize. shadowOffset _ 3@3! ! !DropShadowMorph methodsFor: 'drawing' stamp: 'di 11/3/97 12:31'! drawOn: aCanvas "Draw my submorphs as a shadow, then fullDrawOn will droaw them normally." | shadowCanvas | submorphs isEmpty ifTrue: [^ super drawOn: aCanvas]. shadowCanvas _ aCanvas copyForShadowDrawingOffset: shadowOffset. shadowCanvas stipple: color. submorphs reverseDo: [:m | m fullDrawOn: shadowCanvas]. "draw back-to-front" ! ! !DropShadowMorph methodsFor: 'geometry' stamp: 'di 11/3/97 15:00'! invalidRect: damageRect owner ifNotNil: [owner invalidRect: (damageRect merge: (damageRect translateBy: shadowOffset))].! ! !DropShadowMorph methodsFor: 'geometry' stamp: 'di 11/3/97 13:04'! layoutChanged. self computeBounds. super layoutChanged. ! ! !DropShadowMorph methodsFor: 'menu' stamp: 'di 11/4/97 09:00'! addCustomMenuItems: aCustomMenu hand: aHandMorph super addCustomMenuItems: aCustomMenu hand: aHandMorph. aCustomMenu add: 'set offset' action: #setOffset:. aCustomMenu add: 'remove shadow' action: #removeDropShadow. ! ! !DropShadowMorph methodsFor: 'menu' stamp: 'di 2/20/98 15:32'! removeDropShadow | hadHalo first | (hadHalo _ self hasHalo) ifTrue: [self halo delete]. first _ self firstSubmorph. owner addAllMorphs: self submorphs. hadHalo ifTrue: [first addHalo]. self delete ! ! !DropShadowMorph methodsFor: 'menu' stamp: 'di 11/3/97 17:02'! setOffset: evt | handle | handle _ HandleMorph new forEachPointDo: [:newPoint | self shadowPoint: newPoint]. evt hand attachMorph: handle. handle startStepping. ! ! !DropShadowMorph methodsFor: 'private' stamp: 'di 11/4/97 05:26'! computeBounds submorphs isEmpty ifTrue: [self extent: 50@40. fullBounds _ nil. ^ self]. self changed. bounds _ (submorphs first bounds) copy. fullBounds _ nil. bounds _ self fullBounds translateBy: shadowOffset. self changed! ! !DropShadowMorph methodsFor: 'private' stamp: 'di 11/3/97 17:03'! shadowPoint: newPoint self changed. shadowOffset _ newPoint - self center // 5. self changed! ! Model subclass: #DualChangeSorter instanceVariableNames: 'leftCngSorter rightCngSorter ' classVariableNames: '' poolDictionaries: '' category: 'Interface-Changes'! !DualChangeSorter commentStamp: 'di 5/22/1998 16:33' prior: 0! This class presents a view of a two change sets at once, and supports copying changes between change sets. ! !DualChangeSorter methodsFor: 'all' stamp: 'sw 8/7/97 19:01'! defaultBackgroundColor ^ #lightBlue! ! !DualChangeSorter methodsFor: 'all'! isLeftSide: theOne "Which side am I?" ^ theOne == leftCngSorter! ! !DualChangeSorter methodsFor: 'all' stamp: 'tk 4/30/1998 13:44'! labelString "The window label" ^ leftCngSorter labelString! ! !DualChangeSorter methodsFor: 'all' stamp: 'tk 5/8/1998 16:30'! modelWakeUp "A window with me as model is being entered. Make sure I am up-to-date with the changeSets." "Dumb way" leftCngSorter canDiscardEdits ifTrue: [leftCngSorter update] "does both" ifFalse: [rightCngSorter update]. ! ! !DualChangeSorter methodsFor: 'all' stamp: 'di 5/20/1998 21:44'! okToChange ^ leftCngSorter okToChange & rightCngSorter okToChange! ! !DualChangeSorter methodsFor: 'all' stamp: 'tk 5/8/1998 23:35'! open | topView | World ifNotNil: [^ self openAsMorph]. Sensor leftShiftDown ifTrue: [^ self openAsMorph]. "testing" leftCngSorter _ ChangeSorter new myChangeSet: Smalltalk changes. leftCngSorter parent: self. rightCngSorter _ ChangeSorter new myChangeSet: ChangeSorter secondaryChangeSet. rightCngSorter parent: self. topView _ (StandardSystemView new) model: self; borderWidth: 1. topView label: leftCngSorter label. topView minimumSize: 300 @ 200. leftCngSorter openView: topView offsetBy: 0@0. rightCngSorter openView: topView offsetBy: 360@0. topView controller open. ! ! !DualChangeSorter methodsFor: 'all' stamp: 'tk 5/11/1998 10:07'! openAsMorph | window | leftCngSorter _ ChangeSorter new myChangeSet: Smalltalk changes. leftCngSorter parent: self. rightCngSorter _ ChangeSorter new myChangeSet: ChangeSorter secondaryChangeSet. rightCngSorter parent: self. window _ (SystemWindow labelled: leftCngSorter label) model: self. "topView minimumSize: 300 @ 200." leftCngSorter openAsMorphIn: window rect: (0@0 extent: 0.5@1). rightCngSorter openAsMorphIn: window rect: (0.5@0 extent: 0.5@1). World ifNil: [^ window openInMVC]. "test" window openInWorld! ! !DualChangeSorter methodsFor: 'all'! other: theOne "Return the other side's ChangeSorter" ^ theOne == leftCngSorter ifTrue: [rightCngSorter] ifFalse: [leftCngSorter]! ! !DualChangeSorter methodsFor: 'all'! release leftCngSorter release. rightCngSorter release.! ! Stream subclass: #DummyStream instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'System-Object Storage'! !DummyStream commentStamp: 'di 5/22/1998 16:33' prior: 0! 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'! binary "do nothing"! ! !DummyStream methodsFor: 'all' stamp: 'tk 10/31/97 11:43'! close "do nothing"! ! !DummyStream methodsFor: 'all'! nextInt32Put: arg "do nothing"! ! !DummyStream methodsFor: 'all'! nextNumber: cnt put: num "do nothing"! ! !DummyStream methodsFor: 'all'! nextStringPut: aString "do nothing"! ! !DummyStream methodsFor: 'all'! position "Return any random number. Here is where the real lying begins. We are a DummyStream afterall. 8/17/96 tk" ^ 47 ! ! !DummyStream methodsFor: 'all' stamp: '6/10/97 17:14 tk'! skip: aNumber "Do nothing."! ! !DummyStream methodsFor: 'all'! subclassResponsibility "Do nothing. Most messages to class Stream are defined as subclassResponsibility. Just accept them. 8/17/96 tk" "No error. Just go on."! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! DummyStream class instanceVariableNames: ''! !DummyStream class methodsFor: 'all' stamp: 'jm 12/3/97 20:25'! on: aFile "Return a new DummyStream instance, ignoring the argument." ^ self basicNew ! ! DynamicInterpreterState subclass: #DynamicContextCache instanceVariableNames: 'contextCache lastCachedContext contextCacheEntries stackCache stackCacheFence stackCacheEntries stackOverflow activeCachedContext lowestCachedContext ' classVariableNames: 'CacheBlockArgumentCountIndex CacheCallerIndex CacheEntrySize CacheFramePointerIndex CacheHomeIndex CacheInitialIPIndex CacheInstructionPointerIndex CacheMethodIndex CachePseudoContextIndex CacheReceiverIndex CacheSenderIndex CacheStackPointerIndex CacheTempPointerIndex CacheTranslatedMethodIndex CachedContextIndex CachedContextSize ContextCacheEntries StackCacheEntries StackCacheSize StackEntrySize ' poolDictionaries: '' category: 'Squeak-Jitter'! !DynamicContextCache commentStamp: 'di 5/22/1998 16:33' prior: 0! DynamicContextCache comment: 'I am part of the DynamicInterpreter, separate from that class for organisational purposes only.'! !DynamicContextCache methodsFor: 'initialization' stamp: 'ikp 12/11/97 16:52'! initializeCache: cacheAddress "Initialize cache-related Interpreter state before starting execution of a new image." "Note: The caches initially contain garbage, which is fine since the interpreter is expected to be *precise* in the initialisation and subsequent use of them (including marking and remapping during GC and become operations)." self inline: false. "Make sure we have at least two cached contexts to play with" (contextCacheEntries < 2) ifTrue: [self error: 'context cache too small (minimum 2 entries)']. contextCache _ cacheAddress. lastCachedContext _ contextCache + ((contextCacheEntries - 1) * CacheEntrySize). activeCachedContext _ 0. lowestCachedContext _ 0. "Make sure we have at least contextCacheEntries stack cache entries" (stackCacheEntries < contextCacheEntries) ifTrue: [self error: 'stack cache too small for context cache size']. stackCache _ self contextCacheLimit. stackCacheFence _ stackCache + ((stackCacheEntries - 1) * StackEntrySize). stackOverflow _ false.! ! !DynamicContextCache methodsFor: 'object memory support' stamp: 'ikp 12/11/97 17:00'! mapCachedContext: cp "Notes: the stack and instruction pointers are raw." | tmp start limit ip meth | self inline: true. self assertIsCachedContext: cp. "Map the context fields." (self basicIsCachedMethodContext: cp) ifFalse: [ tmp _ self basicCachedHomeAt: cp. self basicCachedHomeAt: cp put: (self remap: tmp). ]. tmp _ self basicCachedReceiverAt: cp. (self isIntegerObject: tmp) ifFalse: [self basicCachedReceiverAt: cp put: (self remap: tmp)]. tmp _ self basicCachedTranslatedMethodAt: cp. ip _ self basicCachedInstructionPointerAt: cp. ip _ ip - tmp. meth _ self remap: tmp. ip _ ip + meth. self basicCachedInstructionPointerAt: cp put: ip. self basicCachedTranslatedMethodAt: cp put: meth. tmp _ self basicCachedMethodAt: cp. self basicCachedMethodAt: cp put: (self remap: tmp). tmp _ self basicCachedPseudoContextAt: cp. (tmp = 0) ifFalse: [self basicCachedPseudoContextAt: cp put: (self remap: tmp)]. "Map the stack" start _ self cachedFramePointerAt: cp. limit _ self cachedStackPointerAt: cp. start to: limit by: 4 do: [ :ptr | tmp _ self longAt: ptr. (self isIntegerObject: tmp) ifFalse: [self longAt: ptr put: (self remap: tmp)]. ].! ! !DynamicContextCache methodsFor: 'object memory support' stamp: 'ikp 8/26/97 16:12'! mapContextCache "Assumes: SP and IP are external and valid for the activeCachedContext." | ctx tmp acc | self inline: true. acc _ activeCachedContext. acc = 0 ifFalse: [ ctx _ lowestCachedContext. tmp _ self basicCachedSenderAt: ctx. self basicCachedSenderAt: ctx put: (self remap: tmp). [ctx = 0] whileFalse: [ self mapCachedContext: ctx. ctx = acc ifTrue: [ctx _ 0] ifFalse: [ctx _ self cachedContextAfter: ctx]. ]. ].! ! !DynamicContextCache methodsFor: 'object memory support' stamp: 'ikp 11/30/97 18:43'! markAndTraceCachedContext: cp | tmp start limit | self inline: true. self assertIsCachedContext: cp. "Mark the context fields." (self isCachedBlockContext: cp) ifTrue: [ self markAndTrace: (self cachedHomeAt: cp). ]. tmp _ self cachedMethodAt: cp. self markAndTrace: tmp. tmp _ self cachedTranslatedMethodAt: cp. self markAndTrace: tmp. tmp _ self cachedReceiverAt: cp. (self isIntegerObject: tmp) ifFalse: [self markAndTrace: tmp]. tmp _ self cachedPseudoContextAt: cp. tmp = 0 ifFalse: [self markAndTrace: tmp]. "Mark the stack." start _ self cachedFramePointerAt: cp. limit _ self cachedStackPointerAt: cp. start to: limit by: 4 do: [ :ptr | tmp _ self longAt: ptr. (self isIntegerObject: tmp) ifFalse: [self markAndTrace: tmp]. ].! ! !DynamicContextCache methodsFor: 'object memory support' stamp: 'ikp 8/26/97 16:12'! markAndTraceContextCache "Assumes: SP and IP are external and valid for the activeCachedContext." | ctx tmp acc | self inline: true. acc _ activeCachedContext. acc = 0 ifFalse: [ self assertStackPointerIsExternal. self verifyStack. ctx _ lowestCachedContext. self assertIsCachedContext: ctx. tmp _ self cachedSenderAt: ctx. self assertIsStableContextOrNil: tmp. self markAndTrace: tmp. "Mark the stable section of the stack". [ctx = 0] whileFalse: [ self markAndTraceCachedContext: ctx. ctx = acc ifTrue: [ctx _ 0] ifFalse: [ctx _ self cachedContextAfter: ctx]. ]. ].! ! !DynamicContextCache methodsFor: 'accessing' stamp: 'ikp 8/26/97 01:36'! cachedContextAfter: contextPointer "Answer the address of the context cache frame after contextPointer. Wrap from the top context frame around to the bottom context frame." self inline: true. self assertIsCachedContext: contextPointer. lastCachedContext = contextPointer ifTrue: [^contextCache]. ^contextPointer + CacheEntrySize! ! !DynamicContextCache methodsFor: 'accessing' stamp: 'ikp 12/9/97 15:48'! cachedContextBefore: contextPointer "Answer the address of the context cache frame before contextPointer. Wrap from the bottom context frame around to the top context frame." self inline: true. self assertIsCachedContext: contextPointer. (contextCache = contextPointer) ifTrue: [^lastCachedContext]. ^contextPointer - CacheEntrySize! ! !DynamicContextCache methodsFor: 'accessing' stamp: 'ikp 8/17/97 09:07'! cacheSize "Answer the size (in bytes) of the all caches." self inline: true. ^self contextCacheSize + self stackCacheSize! ! !DynamicContextCache methodsFor: 'accessing' stamp: 'ikp 8/17/97 09:07'! contextCacheLimit "Answer the address of the first word after the last context cache frame." self inline: true. ^contextCache + self contextCacheSize! ! !DynamicContextCache methodsFor: 'accessing' stamp: 'ikp 8/17/97 09:07'! contextCacheSize "Answer the size (in bytes) of the context cache." self inline: true. ^contextCacheEntries * CacheEntrySize! ! !DynamicContextCache methodsFor: 'accessing' stamp: 'ikp 8/17/97 09:07'! stackCacheLimit "Answer the address of the first word after the last stack cache location." self inline: true. ^stackCache + self stackCacheSize! ! !DynamicContextCache methodsFor: 'accessing' stamp: 'ikp 8/17/97 09:08'! stackCacheSize "Answer the size (in bytes) of the stack cache." self inline: true. ^stackCacheEntries * StackEntrySize! ! !DynamicContextCache methodsFor: 'testing' stamp: 'ikp 8/18/97 01:35'! isBlockContext: ctx "Answer if the stable context ctx is a BlockContext" self inline: true. self assertIsStableContext: ctx. ^self isIntegerObject: (self fetchPointer: MethodIndex ofObject: ctx)! ! !DynamicContextCache methodsFor: 'testing' stamp: 'ikp 8/18/97 01:35'! isCachedBlockContext: cp "Answer if the cached context cp represents a BlockContext" self inline: true. self assertIsCachedContext: cp. ^(self cachedHomeAt: cp) ~= 0! ! !DynamicContextCache methodsFor: 'testing' stamp: 'ikp 8/18/97 01:35'! isCachedMethodContext: cp "Answer if the cached context cp represents a MethodContext" self inline: true. self assertIsCachedContext: cp. ^(self cachedHomeAt: cp) = 0! ! !DynamicContextCache methodsFor: 'testing' stamp: 'ikp 8/18/97 01:35'! isMethodContext: ctx "Answer if the stable context ctx is a MethodContext" self inline: true. self assertIsStableContext: ctx. ^(self isBlockContext: ctx) not! ! !DynamicContextCache methodsFor: 'testing' stamp: 'ikp 8/26/97 16:13'! isPseudoContext: aContext self inline: true. self assertIsContext: aContext. ^(self isIntegerObject: (self fetchPointer: SenderIndex ofObject: aContext))! ! !DynamicContextCache methodsFor: 'testing' stamp: 'ikp 8/26/97 16:13'! isStableContext: ctx "Answer if the object ctx is a BlockContext or MethodContext" self inline: true. ^(self isPseudoContext: ctx) not! ! !DynamicContextCache methodsFor: 'stack accessing' stamp: 'ikp 8/18/97 13:09'! cachedStackIndexAt: cp "Answer Smalltalk's index for the stack pointer in cp." self inline: true. self assertIsCachedContext: cp. ^self integerObjectOf: (self cachedStackPointerAt: cp) - (self cachedFramePointerAt: cp) // 4 + 1! ! !DynamicContextCache methodsFor: 'stack accessing' stamp: 'ikp 8/18/97 13:10'! cachedStackIndexAt: cp put: anInteger self inline: true. self assertIsIntegerObject: anInteger. self cachedStackPointerAt: cp put: (self cachedFramePointerAt: cp) + (((self integerValueOf: anInteger) - 1) * 4)! ! !DynamicContextCache methodsFor: 'stack accessing' stamp: 'ikp 8/26/97 17:14'! cachedTemporaryPointerAt: cp self inline: true. ^self longAt: cp + (CacheTempPointerIndex * 4)! ! !DynamicContextCache methodsFor: 'stack accessing' stamp: 'ikp 8/26/97 15:59'! cachedTemporaryPointerAt: cp put: tp self inline: true. self assertIsCachedContext: cp. ^self longAt: cp + (CacheTempPointerIndex * 4) put: tp! ! !DynamicContextCache methodsFor: 'context accessing' stamp: 'ikp 8/18/97 12:54'! cachedBlockArgumentCountAt: cp self inline: true. self assertIsCachedContext: cp. ^self longAt: cp + (CacheBlockArgumentCountIndex * 4)! ! !DynamicContextCache methodsFor: 'context accessing' stamp: 'ikp 8/18/97 12:54'! cachedBlockArgumentCountAt: cp put: anInteger self inline: true. self assertIsCachedContext: cp. self assertIsIntegerObject: anInteger. self longAt: cp + (CacheBlockArgumentCountIndex * 4) put: anInteger! ! !DynamicContextCache methodsFor: 'context accessing' stamp: 'ikp 8/18/97 12:54'! cachedCallerAt: cp put: aContext self inline: true. self assertIsCachedContext: cp. self assertIsStableContextOrNil: aContext. self longAt: cp + (CacheCallerIndex * 4) put: aContext! ! !DynamicContextCache methodsFor: 'context accessing' stamp: 'ikp 8/21/97 00:31'! cachedFramePointerAt: cp "Answer the frame pointer for the given context" self inline: true. self assertIsCachedContext: cp. ^self longAt: cp + (CacheFramePointerIndex * 4)! ! !DynamicContextCache methodsFor: 'context accessing' stamp: 'ikp 8/21/97 00:31'! cachedFramePointerAt: cp put: fp "Answer the frame pointer for the given context" self inline: true. self assertIsCachedContext: cp. ^self longAt: cp + (CacheFramePointerIndex * 4) put: fp! ! !DynamicContextCache methodsFor: 'context accessing' stamp: 'ikp 8/18/97 13:12'! cachedHomeAt: cp self inline: true. self assertIsCachedContext: cp. self assertIsContextOrNull: (self longAt: cp + (CacheHomeIndex * 4)). ^self longAt: cp + (CacheHomeIndex * 4)! ! !DynamicContextCache methodsFor: 'context accessing' stamp: 'ikp 8/18/97 12:54'! cachedHomeAt: cp put: aContext self inline: true. self assertIsCachedContext: cp. self assertIsContextOrNull: aContext. self longAt: cp + (CacheHomeIndex * 4) put: aContext. " self cachedTemporaryPointerAt: cp put: (self temporaryPointerForCachedContext: aContext). "! ! !DynamicContextCache methodsFor: 'context accessing' stamp: 'ikp 8/18/97 13:12'! cachedInitialIPAt: cp self inline: true. self assertIsCachedContext: cp. self assertIsIntegerObject: (self longAt: cp + (CacheInitialIPIndex * 4)). ^self longAt: cp + (CacheInitialIPIndex * 4)! ! !DynamicContextCache methodsFor: 'context accessing' stamp: 'ikp 8/18/97 12:54'! cachedInitialIPAt: cp put: anInteger self inline: true. self assertIsCachedContext: cp. self assertIsIntegerObject: anInteger. self longAt: cp + (CacheInitialIPIndex * 4) put: anInteger! ! !DynamicContextCache methodsFor: 'context accessing' stamp: 'ikp 8/18/97 13:16'! cachedMethodAt: cp self inline: true. self assertIsCachedContext: cp. self assertIsCompiledMethod: (self longAt: cp + (CacheMethodIndex * 4)). ^self longAt: cp + (CacheMethodIndex * 4)! ! !DynamicContextCache methodsFor: 'context accessing' stamp: 'ikp 8/18/97 12:55'! cachedMethodAt: cp put: aCompiledMethod self inline: true. self assertIsCachedContext: cp. self assertIsCompiledMethod: aCompiledMethod. self longAt: cp + (CacheMethodIndex * 4) put: aCompiledMethod! ! !DynamicContextCache methodsFor: 'context accessing' stamp: 'ikp 1/5/98 16:32'! cachedPseudoContextAt: cp self inline: true. self assertIsCachedContext: cp. self assertIsPseudoContextOrNull: (self longAt: cp + (CachePseudoContextIndex * 4)). self assertIsValidPseudoContextAt: cp. ^self longAt: cp + (CachePseudoContextIndex * 4)! ! !DynamicContextCache methodsFor: 'context accessing' stamp: 'ikp 1/5/98 16:40'! cachedPseudoContextAt: cp put: aPseudoContext self inline: true. self assertIsCachedContext: cp. self assertIsPseudoContextOrNull: aPseudoContext. self longAt: cp + (CachePseudoContextIndex * 4) put: aPseudoContext.! ! !DynamicContextCache methodsFor: 'context accessing' stamp: 'ikp 8/18/97 13:17'! cachedReceiverAt: cp self inline: true. self assertIsCachedContext: cp. self assertIsOop: (self longAt: cp + (CacheReceiverIndex * 4)). ^self longAt: cp + (CacheReceiverIndex * 4)! ! !DynamicContextCache methodsFor: 'context accessing' stamp: 'ikp 8/18/97 12:55'! cachedReceiverAt: cp put: anObject self inline: true. self assertIsCachedContext: cp. self assertIsOop: anObject. self longAt: cp + (CacheReceiverIndex * 4) put: anObject! ! !DynamicContextCache methodsFor: 'context accessing' stamp: 'ikp 8/18/97 13:17'! cachedSenderAt: cp self inline: true. self assertIsCachedContext: cp. self assertIsStableContextOrNilOrNull: (self longAt: cp + (CacheSenderIndex * 4)). ^self longAt: cp + (CacheSenderIndex * 4)! ! !DynamicContextCache methodsFor: 'context accessing' stamp: 'ikp 12/17/97 13:51'! cachedSenderAt: cp put: aContext self inline: true. self assertIsCachedContext: cp. self assertIsStableContextOrNilOrNull: aContext. "nil if base context" self longAt: cp + (CacheSenderIndex * 4) put: aContext! ! !DynamicContextCache methodsFor: 'context accessing' stamp: 'ikp 8/21/97 00:31'! cachedStackPointerAt: cp "Answer the raw stack pointer for the given context" self inline: true. self assertIsCachedContext: cp. ^self longAt: cp + (CacheStackPointerIndex * 4)! ! !DynamicContextCache methodsFor: 'context accessing' stamp: 'ikp 8/21/97 00:32'! cachedStackPointerAt: cp put: rawPointer "Store the stack pointer in the given context" self inline: true. self assertIsCachedContext: cp. self longAt: cp + (CacheStackPointerIndex * 4) put: rawPointer! ! !DynamicContextCache methodsFor: 'cache management' stamp: 'ikp 8/26/97 15:27'! allocateCachedContextAfter: activeContext frame: fp "Answer a new cached context, initialised with the given frame pointer, and set activeCachedContext to point to it. If the context cache overflows then eject the lowest cached context to make space available. If the stack cache overflows, wrap it implicitly by setting the framePointer in the new context to a usable stack location, and set stackOverflow to true to alert the caller. The caller is *obliged* to check this flag: if it is true then the caller must fetch the frame pointer that was actually allocated out of the new context, and use it instead of the the frame pointer originally requested. The caller is also responsible for copying any arguments or other values from the top of the stack cache to the new frame's location during stack overflow, and for resetting the stackOverflow flag to false once this is done. The new cached context has the pseudoContext and sender fields set to 0, the framePointer field set to the actual location of the stack frame, the home field set to the supplied home pointer (which will be 0 for methods), and the temporaryPointer field set to the base of the temporary frame (this is either the same as the framePointer [methods], the frame pointer of the [cached] home context, or the address of the first indexable field in the [stable] home context). Note: This method can cause a GC!! This in turn obliges the caller to truncate the active context's stack AFTER calling this method." | newCachedContext | self inline: true. newCachedContext _ self cachedContextAfter: activeContext. newCachedContext = lowestCachedContext ifTrue: [ self ejectFromCache: newCachedContext. lowestCachedContext _ self cachedContextAfter: newCachedContext. ]. self initializeCachedContext: newCachedContext. activeCachedContext _ newCachedContext. fp >= stackCacheFence ifTrue: [ self cachedFramePointerAt: newCachedContext put: stackCache. "wrap the stack" stackOverflow _ true. ^newCachedContext. ]. self cachedFramePointerAt: newCachedContext put: fp. ^newCachedContext! ! !DynamicContextCache methodsFor: 'cache management' stamp: 'ikp 11/30/97 19:12'! copyCache: cp toPseudoContext: ctx setSender: senderFlag "Copy the cached context cp into the pseudo context ctx. Mutate ctx into the appropriate stable context in the process. Leave the sender field according to senderFlag, where 'true' means use the cached sender (e.g. when ejecting because of overflow), 'false' means nil (e.g. when stabilising during return)." | sp sz stackSize | self inline: false. self assertIsCachedContext: cp. self assertIsPseudoContext: ctx. (self isCachedMethodContext: cp) ifTrue: [ self mutateToMethodContext: ctx. self storePointerUnchecked: InstructionPointerIndex ofObject: ctx withValue: (self cachedInstructionIndexAt: cp). self storePointerUnchecked: StackPointerIndex ofObject: ctx withValue: (sp _ self cachedStackIndexAt: cp). self storePointerUnchecked: MethodIndex ofObject: ctx withValue: (self cachedMethodAt: cp). self storePointerUnchecked: TranslatedMethodIndex ofObject: ctx withValue: (self cachedTranslatedMethodAt: cp). self storePointerUnchecked: ReceiverIndex ofObject: ctx withValue: (self cachedReceiverAt: cp). "The cached context might have been the home context for a cached block activation -- fix the situation" " self redirectTemporaryPointersFrom: (self cachedFramePointerAt: cp) to: (ctx + BaseHeaderSize + (TempFrameStart * 4))." ] ifFalse: [ self mutateToBlockContext: ctx. self storePointerUnchecked: InstructionPointerIndex ofObject: ctx withValue: (self cachedInstructionIndexAt: cp). self storePointerUnchecked: StackPointerIndex ofObject: ctx withValue: (sp _ self cachedStackIndexAt: cp). self storePointerUnchecked: BlockArgumentCountIndex ofObject: ctx withValue: (self cachedBlockArgumentCountAt: cp). self storePointerUnchecked: InitialIPIndex ofObject: ctx withValue: (self cachedInitialIPAt: cp). self storePointerUnchecked: HomeIndex ofObject: ctx withValue: (self cachedHomeAt: cp). ]. senderFlag ifTrue: [ self storePointerUnchecked: SenderIndex ofObject: ctx withValue: (self cachedSenderAt: cp). ] ifFalse: [ self storePointerUnchecked: SenderIndex ofObject: ctx withValue: nilObj. ]. "Copy the stack." sz _ ((self sizeBitsOf: ctx) - BaseHeaderSize) // 4 - TempFrameStart. "12 or 32" stackSize _ self integerValueOf: sp. stackSize > sz ifTrue: [self error: 'stack overflow while stabilising context']. self inlineTransfer: stackSize wordsFrom: (self cachedFramePointerAt: cp) to: ctx + BaseHeaderSize + (TempFrameStart * 4). "Pseudo-contexts are born full of nil -- no need to fill the rest." ctx < youngStart ifTrue: [self beRootIfOld: ctx]. self assertIsStableContext: ctx. self assertIsLegalStackOffsetInContext: ctx. ^ctx! ! !DynamicContextCache methodsFor: 'cache management' stamp: 'ikp 1/5/98 16:39'! copyContextToCache: ctx "Copy ctx into the first context cache location, resetting activeCachedContext in the process. Mutate the source context into a PseudoContext in the process. Assumes: ctx is the topmost context in the stable stack. The context cache is initially empty. Notes: If ctx is a BlockContext, the home context is guaranteed to be stable." | cp sp home | self inline: false. self assertIsStableContext: ctx. "Reset the context cache to initial conditions." cp _ lowestCachedContext _ activeCachedContext _ contextCache. self initializeCachedContext: cp. self cachedFramePointerAt: cp put: stackCache. (self isMethodContext: ctx) ifTrue: [ self cachedMethodAt: cp put: (self fetchPointer: MethodIndex ofObject: ctx). self cachedTranslatedMethodAt: cp put: (self fetchPointer: TranslatedMethodIndex ofObject: ctx). self cachedReceiverAt: cp put: (self fetchPointer: ReceiverIndex ofObject: ctx). self cachedHomeAt: cp put: 0. self cachedSenderAt: cp put: (self fetchPointer: SenderIndex ofObject: ctx). self cachedInstructionIndexAt: cp put: (self fetchPointer: InstructionPointerIndex ofObject: ctx). self cachedStackIndexAt: cp put: (self fetchPointer: StackPointerIndex ofObject: ctx). " self cachedTemporaryPointerAt: cp put: stackCache." ] ifFalse: [ home _ self fetchPointer: HomeIndex ofObject: ctx. self cachedHomeAt: cp put: (home). self cachedMethodAt: cp put: (self methodOfBlockContext: ctx). self cachedTranslatedMethodAt: cp put: (self translatedMethodOfBlockContext: ctx). self cachedReceiverAt: cp put: (self receiverOfBlockContext: ctx). self cachedCallerAt: cp put: (self fetchPointer: CallerIndex ofObject: ctx). self cachedInstructionIndexAt: cp put: (self fetchPointer: InstructionPointerIndex ofObject: ctx). self cachedStackIndexAt: cp put: (self fetchPointer: StackPointerIndex ofObject: ctx). self cachedBlockArgumentCountAt: cp put: (self fetchPointer: BlockArgumentCountIndex ofObject: ctx). self cachedInitialIPAt: cp put: (self fetchPointer: InitialIPIndex ofObject: ctx). self assertIsStableMethodContext: home. " self cachedTemporaryPointerAt: cp put: (home + BaseHeaderSize + (TempFrameStart * 4))." " home < youngStart ifTrue: [self beRootIfOld: home]." ]. "Copy the stack" sp _ self quickFetchInteger: StackPointerIndex ofObject: ctx. self inlineTransfer: sp wordsFrom: ctx + BaseHeaderSize + (TempFrameStart * 4) to: (self cachedFramePointerAt: cp). "Unused stack locations are ignored by GC -- no need to fill with nil" self mutateToPseudoContext: ctx. "fills with nil in the process" self cachedPseudoContextAt: cp put: ctx. self pseudoCachedContextAt: ctx put: cp. self assertIsValidPseudoContextAt: cp. ctx < youngStart ifTrue: [self beRootIfOld: ctx] "*** I DON'T THINK THIS IS NEEDED (there are no real pointers in it!!) ***" ! ! !DynamicContextCache methodsFor: 'cache management' stamp: 'ikp 1/5/98 16:45'! deallocateAllCachedContexts "Deallocate the all cached contexts, resetting activeCachedContext to indicate the absence of any active context. If any cached context has a pseudo context, copy its state into the pseudo context, but leave the sender field nil. Answer the topmost stable context. Notes: It is the caller's responsibility to reinitialise the cache for subsequent execution." | cp pc stableContext | self inline: false. cp _ activeCachedContext. [cp = 0] whileFalse: [ stableContext _ self cachedSenderAt: cp. pc _ self cachedPseudoContextAt: cp. pc = 0 ifFalse: [ self assertIsValidPseudoContextAt: cp. self copyCache: cp toPseudoContext: pc setSender: false. self cachedPseudoContextAt: cp put: 0. "sane value for future allocations" ]. cp = lowestCachedContext ifTrue: [cp _ 0] ifFalse: [cp _ self cachedContextBefore: cp]. ]. activeCachedContext _ 0. ^stableContext! ! !DynamicContextCache methodsFor: 'cache management' stamp: 'ikp 1/5/98 16:46'! deallocateCachedContext "Deallocate the top cached context, setting activeCachedContext to the appropriate new value. If the old activeCachedContext has a pseudo context, copy its state into the pseudo context, but leave the sender field nil. If the context cache underflows, copy the topmost stable context into the cache and reset activeCachedContext and lowestCachedContext appropriately. If the new activeCachedContext is a block context with a stable home, make the home a root if it is in old space." | cp pc | self inline: true. cp _ activeCachedContext. pc _ self cachedPseudoContextAt: cp. pc = 0 ifFalse: [ self assertIsValidPseudoContextAt: cp. self copyCache: cp toPseudoContext: pc setSender: false. self cachedPseudoContextAt: cp put: 0. "sane value for future allocations" ]. cp = lowestCachedContext ifTrue: [ self copyContextToCache: (self cachedSenderAt: cp). ] ifFalse: [ cp _ self cachedContextBefore: cp. activeCachedContext _ cp. ].! ! !DynamicContextCache methodsFor: 'cache management' stamp: 'ikp 8/17/97 13:55'! ejectFromCache: cp "We're ejecting cp, the lowest cached context, to make room for a new active cached context. Fetch the PseudoContext for the ejected context, turn it into a real context, and fill it in from the cache. Fix the sender field in the following cached context to point to the newly stabilised context. Answer the new stable context. Assumes: The cached sender of cp is a stable context. Notes: This method can provoke a GC." | ctx | self inline: false. self assertIsCachedContext: cp. ctx _ self pseudoContextFor: cp. self assertIsPseudoContext: ctx. self copyCache: cp toPseudoContext: ctx setSender: true. self assertIsStableContext: ctx. self cachedSenderAt: (self cachedContextAfter: cp) put: ctx. ^ctx! ! !DynamicContextCache methodsFor: 'cache management' stamp: 'ikp 12/9/97 15:48'! flushCacheFrom: cp "Flush the cache starting at the cached context cp. Answer the new top context in the stable section of the stack. Notes: We flush the cache from the lowestCachedContext to cp inclusive, using ejectFromCache: which already implements exactly the required behaviour. This method can provoke a GC." | ctx done | self inline: false. self assertIsCachedContext: cp. done _ false. [done] whileFalse: [ ctx _ self ejectFromCache: lowestCachedContext. done _ lowestCachedContext = cp. lowestCachedContext _ self cachedContextAfter: lowestCachedContext. ]. self assertIsStableContext: ctx. cp = activeCachedContext ifTrue: [activeCachedContext _ lowestCachedContext _ 0]. ^ctx! ! !DynamicContextCache methodsFor: 'cache management' stamp: 'ikp 12/27/97 14:44'! initializeCachedContext: cp "Init the private fields of cp." "cp to: cp + CacheEntrySize - 4 by: 4 do: [:ptr | self longAt: ptr put: nilObj]." self inline: true. self cachedSenderAt: cp put: 0. self cachedPseudoContextAt: cp put: 0. "self cachedContextReceiverFlagAt: cp put: 0." "no longer needed"! ! !DynamicContextCache methodsFor: 'pseudo contexts' stamp: 'ikp 1/5/98 16:45'! allocatePseudoContextFor: cp "Answer the PseudoContext for cp. Create one if necessary. Notes: This method can provoke a GC." | pc methodHeader smallContext meth | self inline: false. self assertIsCachedContext: cp. meth _ self cachedMethodAt: cp. methodHeader _ self headerOf: meth. smallContext _ ((methodHeader >> 18) bitAnd: 1) = 0. smallContext ifTrue: [ pc _ self instantiateSmallClass: (self splObj: ClassPseudoContext) sizeInBytes: SmallContextSize fill: nilObj. ] ifFalse: [ pc _ self instantiateSmallClass: (self splObj: ClassPseudoContext) sizeInBytes: LargeContextSize fill: nilObj. ]. "The cached context and associated pseudo context contain back pointers to each other." self pseudoCachedContextAt: pc put: cp. self cachedPseudoContextAt: cp put: pc. self assertIsValidPseudoContextAt: cp. ^pc! ! !DynamicContextCache methodsFor: 'pseudo contexts' stamp: 'ikp 10/20/97 12:34'! mutateToBlockContext: aContext "Change the class of aContext to BlockContext" self inline: true. self assertIsPseudoContext: aContext. self changeClassOf: aContext to: (self splObj: ClassBlockContext)! ! !DynamicContextCache methodsFor: 'pseudo contexts' stamp: 'ikp 10/20/97 12:34'! mutateToMethodContext: aContext "Change the class of aContext to MethodContext" self inline: true. self assertIsPseudoContext: aContext. self changeClassOf: aContext to: (self splObj: ClassMethodContext)! ! !DynamicContextCache methodsFor: 'pseudo contexts' stamp: 'ikp 10/20/97 12:34'! mutateToPseudoContext: aContext "Change the class of aContext to PseudoContext and set the entire contents to nil." | nilOop | self inline: true. self assertIsStableContext: aContext. self changeClassOf: aContext to: (self splObj: ClassPseudoContext). "IS THIS NECESSARY?" nilOop _ nilObj. self fill: ((self sizeBitsOf: aContext) - BaseHeaderSize) // 4 - 1 wordsFrom: aContext + BaseHeaderSize with: nilOop. ! ! !DynamicContextCache methodsFor: 'pseudo contexts' stamp: 'ikp 8/17/97 09:34'! pseudoCachedContextAt: pc "Answer the cached context pointer for the PseudoContext pc. Notes: The cached context pointer is encoded as an integer in the sender field of the PseudoContext. Subtract 1 to get the real pointer." self inline: true. self assertIsPseudoContext: pc. self assertIsCachedContext: ((self fetchPointer: CachedContextIndex ofObject: pc) - 1). ^(self fetchPointer: CachedContextIndex ofObject: pc) - 1! ! !DynamicContextCache methodsFor: 'pseudo contexts' stamp: 'ikp 1/5/98 16:43'! pseudoCachedContextAt: pc put: cachePointer "Store the cached context pointer for the PseudoContext pc. Notes: The cached context pointer is encoded as an integer in the sender field of the PseudoContext. Add 1 to get the encoded integer." self inline: true. self assertIsPseudoContext: pc. self assertIsCachedContext: cachePointer. self storeWord: CachedContextIndex ofObject: pc withValue: cachePointer + 1! ! !DynamicContextCache methodsFor: 'pseudo contexts' stamp: 'ikp 12/9/97 15:48'! pseudoContextFor: cp "Answer the PseudoContext for cp. Create one if necessary. Notes: This method can provoke a GC." | pc | self inline: true. self assertIsCachedContext: cp. pc _ self cachedPseudoContextAt: cp. pc = 0 ifTrue: [pc _ self allocatePseudoContextFor: cp]. self assertIsPseudoContext: pc. ^pc! ! !DynamicContextCache methodsFor: 'pseudo contexts' stamp: 'ikp 8/18/97 12:56'! stableClassOf: pc "Answer the class needed to represent a stable version of the PseudoContext pc." | cp | self inline: true. self assertIsPseudoContext: pc. cp _ self pseudoCachedContextAt: pc. (self isCachedBlockContext: cp) ifTrue: [^self splObj: ClassBlockContext] ifFalse: [^self splObj: ClassMethodContext]! ! !DynamicContextCache methodsFor: 'pseudo contexts' stamp: 'ikp 8/18/97 12:57'! wordLengthOfContext: cp "Anwer the size in words of the stable context needed to represent the cached context cp." | pc meth methodHeader | self inline: true. self assertIsCachedContext: cp. pc _ self cachedPseudoContextAt: cp. pc = 0 ifTrue: [ meth _ self cachedMethodAt: cp. methodHeader _ self headerOf: meth. ((methodHeader >> 18) bitAnd: 1) = 0 ifTrue: [ ^SmallContextSize - BaseHeaderSize // 4. ] ifFalse: [ ^LargeContextSize - BaseHeaderSize // 4. ]. ] ifFalse: [ ^self fetchWordLengthOf: pc. ].! ! !DynamicContextCache methodsFor: 'utilities' stamp: 'ikp 8/26/97 17:37'! addRootsForCachedContext: ctx | home | home _ self cachedHomeAt: ctx. home = 0 ifFalse: [ (self isStableContext: home) ifTrue: [ home < youngStart ifTrue: [self beRootIfOld: home]. ]. ].! ! !DynamicContextCache methodsFor: 'utilities' stamp: 'ikp 8/25/97 17:11'! baseHeader: oop put: newHeader "Note: This method should be in ObjectMemory" ^ self longAt: oop put: newHeader! ! !DynamicContextCache methodsFor: 'utilities' stamp: 'ikp 10/20/97 12:33'! changeClassOf: anObject to: aClass "Used to mutate a PseudoContext to/from a stable Method/BlockContext. Notes: Tacitly assumes that the type bits are the SAME for the source and destination!! This method should be in ObjectMemory." | ccClass hdrObject ccObject | self inline: false. hdrObject _ self baseHeader: anObject. ccObject _ hdrObject bitAnd: 16r1F000. ccObject = 0 ifTrue: [ "object has uncompact class" self classHeader: anObject put: aClass. ] ifFalse: [ "object has compact class" ccClass _ (self formatOfClass: aClass) bitAnd: 16rF000. ccClass ~= 0 ifTrue: [ "object has compact class; class is compact" hdrObject _ (hdrObject bitXor: ccObject) bitOr: ccClass. self baseHeader: anObject put: hdrObject. ] ifFalse: [ "object has compact class; class is uncompact" self error: 'cannot mutate header from compact to uncompact'. ] ]! ! !DynamicContextCache methodsFor: 'utilities' stamp: 'ikp 8/25/97 17:01'! classHeader: oop put: newClass "Note: This method should be in ObjectMemory" ^ self longAt: oop - 4 put: newClass! ! !DynamicContextCache methodsFor: 'utilities' stamp: 'ikp 8/18/97 12:57'! fill: num wordsFrom: dst with: val "Note: this could be rewritten to use memset() in the C translation." | out ctr | self inline: true. out _ dst - 4. "pre-increment is our friend on many architectures." ctr _ num. [(ctr _ ctr - 1) >= 0] whileTrue: [ self longAt: (out _ out + 4) put: val. ].! ! !DynamicContextCache methodsFor: 'utilities' stamp: 'ikp 8/27/97 09:46'! inlineTransfer: num wordsFrom: src to: dst | in out ctr | self inline: true. in _ src - 4. "pre-increment is our friend on many architectures." out _ dst - 4. ctr _ num. [(ctr _ ctr - 1) >= 0] whileTrue: [ self longAt: (out _ out + 4) put: (self longAt: (in _ in + 4)). ].! ! !DynamicContextCache methodsFor: 'utilities' stamp: 'ikp 8/27/97 12:12'! temporaryPointerForCachedContext: cp | home | self inline: true. self assertIsCachedContext: cp. home _ self cachedHomeAt: cp. home = 0 ifTrue: [ ^self cachedFramePointerAt: cp. ] ifFalse: [ (self isPseudoContext: home) ifTrue: [ ^self cachedFramePointerAt: (self pseudoCachedContextAt: home). ] ifFalse: [ ^home + BaseHeaderSize + (TempFrameStart * 4). ]. ].! ! !DynamicContextCache methodsFor: 'utilities' stamp: 'ikp 8/27/97 09:46'! transfer: num wordsFrom: src to: dst | in out ctr | self inline: false. in _ src - 4. "pre-increment is our friend on many architectures." out _ dst - 4. ctr _ num. [(ctr _ ctr - 1) >= 0] whileTrue: [ self longAt: (out _ out + 4) put: (self longAt: (in _ in + 4)). ].! ! !DynamicContextCache methodsFor: 'private' stamp: 'ikp 8/18/97 12:57'! basicCachedHomeAt: cp "For use during GC remapping" self inline: true. self assertIsCachedContext: cp. ^self longAt: cp + (CacheHomeIndex * 4)! ! !DynamicContextCache methodsFor: 'private' stamp: 'ikp 8/18/97 12:57'! basicCachedHomeAt: cp put: aContext "For use during GC remapping" self inline: true. self assertIsCachedContext: cp. self longAt: cp + (CacheHomeIndex * 4) put: aContext! ! !DynamicContextCache methodsFor: 'private' stamp: 'ikp 8/18/97 12:57'! basicCachedInstructionPointerAt: cp "For use during GC remapping" self inline: true. self assertIsCachedContext: cp. ^self longAt: cp + (CacheInstructionPointerIndex * 4)! ! !DynamicContextCache methodsFor: 'private' stamp: 'ikp 8/18/97 12:57'! basicCachedInstructionPointerAt: cp put: ip "For use during GC remapping" self inline: true. self assertIsCachedContext: cp. ^self longAt: cp + (CacheInstructionPointerIndex * 4) put: ip.! ! !DynamicContextCache methodsFor: 'private' stamp: 'ikp 8/18/97 12:57'! basicCachedMethodAt: cp "For use during GC remapping" self inline: true. self assertIsCachedContext: cp. ^self longAt: cp + (CacheMethodIndex * 4)! ! !DynamicContextCache methodsFor: 'private' stamp: 'ikp 8/18/97 12:57'! basicCachedMethodAt: cp put: aCompiledMethod "For use during GC remapping" self inline: true. self assertIsCachedContext: cp. self longAt: cp + (CacheMethodIndex * 4) put: aCompiledMethod! ! !DynamicContextCache methodsFor: 'private' stamp: 'ikp 8/18/97 12:57'! basicCachedPseudoContextAt: cp self inline: true. self assertIsCachedContext: cp. ^self longAt: cp + (CachePseudoContextIndex * 4)! ! !DynamicContextCache methodsFor: 'private' stamp: 'ikp 8/18/97 12:57'! basicCachedPseudoContextAt: cp put: aPseudoContext "For use during GC remapping" self inline: true. self assertIsCachedContext: cp. ^self longAt: cp + (CachePseudoContextIndex * 4) put: aPseudoContext! ! !DynamicContextCache methodsFor: 'private' stamp: 'ikp 8/18/97 12:57'! basicCachedReceiverAt: cp "For use during GC remapping" self inline: true. self assertIsCachedContext: cp. ^self longAt: cp + (CacheReceiverIndex * 4)! ! !DynamicContextCache methodsFor: 'private' stamp: 'ikp 8/18/97 12:57'! basicCachedReceiverAt: cp put: anObject "For use during GC remapping" self inline: true. self assertIsCachedContext: cp. self longAt: cp + (CacheReceiverIndex * 4) put: anObject! ! !DynamicContextCache methodsFor: 'private' stamp: 'ikp 8/18/97 12:57'! basicCachedSenderAt: cp "For use during GC remapping" self inline: true. self assertIsCachedContext: cp. ^self longAt: cp + (CacheSenderIndex * 4)! ! !DynamicContextCache methodsFor: 'private' stamp: 'ikp 8/18/97 12:57'! basicCachedSenderAt: cp put: aContext "For use during GC remapping" self inline: true. self assertIsCachedContext: cp. self longAt: cp + (CacheSenderIndex * 4) put: aContext! ! !DynamicContextCache methodsFor: 'private' stamp: 'ikp 8/18/97 12:57'! basicIsCachedMethodContext: cp "For use during GC remapping" self inline: true. self assertIsCachedContext: cp. ^(self basicCachedHomeAt: cp) = 0! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! DynamicContextCache class instanceVariableNames: ''! !DynamicContextCache class methodsFor: 'class initialization' stamp: 'ikp 12/1/97 14:20'! initialize "DynamicContextCache initialize" super initialize. self initializeCacheIndices. self initializePseudoContextIndices. ContextCacheEntries _ 16. CacheEntrySize _ CachedContextSize * 4. StackCacheEntries _ 16. StackEntrySize _ 32 * 4 ! ! !DynamicContextCache class methodsFor: 'class initialization' stamp: 'ikp 12/27/97 14:44'! initializeCacheIndices "ContextCache initialize" "Method contexts" CacheSenderIndex _ 0. "caller of this method context" CacheInstructionPointerIndex _ 1. "raw instruction pointer (points into method body)" CacheStackPointerIndex _ 2. "raw stack pointer (points into stack cache)" CacheMethodIndex _ 3. "method (home method for blocks)" CacheReceiverIndex _ 4. "receiver (home receiver for blocks)" "Block contexts" CacheCallerIndex _ CacheSenderIndex. "caller of this block context" CacheBlockArgumentCountIndex _ 5. "number of arguments (used only in stabilisation)" CacheInitialIPIndex _ 6. "initial IP (used only in stabilisation)" CacheHomeIndex _ 7. "home context (stable or pseudo) (0 for methods)" "All contexts" CachePseudoContextIndex _ 8. "allocated PseudoContext (0 if unallocated)" CacheFramePointerIndex _ 9. "address of stack frame (first temp) in cache" CacheTempPointerIndex _ 10. "address of first temporary in cache or heap context" CacheTranslatedMethodIndex _ 11. "translated method corresponding to method" "CacheContextReceiverFlagIndex _ 12." "non-nil if receiver is a context" CachedContextSize _ 12.! ! !DynamicContextCache class methodsFor: 'class initialization' stamp: 'ikp 8/16/97 19:51'! initializePseudoContextIndices "Assumes: InterpreterCore has already been initialised." "Notes: this permits a quick test for a pseudo context (the sender field contains an integer object)." CachedContextIndex _ SenderIndex.! ! !DynamicContextCache class methodsFor: 'translation' stamp: 'ikp 10/28/97 01:56'! declareCVarsIn: aCCodeGenerator "Nothing to declare..."! ! DynamicTranslator subclass: #DynamicInterpreter instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Squeak-Jitter'! !DynamicInterpreter commentStamp: 'di 5/22/1998 16:33' prior: 0! DynamicInterpreter 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.'! !DynamicInterpreter methodsFor: 'initialization' stamp: 'jm 5/18/1998 13:25'! initializeInterpreter: bytesToShift "Initialize Interpreter state before starting execution of a new image." self inline: false. self initializeObjectMemory: bytesToShift. self initBBOpTable. messageSelector _ nilObj. newReceiver _ nilObj. newMethod _ nilObj. newTranslatedMethod _ nilObj. pseudoReceiver _ 0. self initializeTranslator. self initMethodCache. self loadInitialContext. interruptCheckCounter _ 0. nextPollTick _ 0. nextWakeupTick _ 0. lastTick _ 0. interruptKeycode _ 2094. "cmd-." interruptPending _ false. semaphoresToSignalCount _ 0. deferDisplayUpdates _ false. ! ! !DynamicInterpreter methodsFor: 'initialization' stamp: 'ikp 12/11/97 16:51'! loadInitialContext | sched proc | self inline: false. self preTranslateContextMethods. sched _ self fetchPointer: ValueIndex ofObject: (self splObj: SchedulerAssociation). proc _ self fetchPointer: ActiveProcessIndex ofObject: sched. self copyContextToCache: (self fetchPointer: SuspendedContextIndex ofObject: proc). self fetchContextRegisters: activeCachedContext. self assertStackPointerIsExternal.! ! !DynamicInterpreter methodsFor: 'initialization' stamp: 'ikp 1/5/98 17:52'! preTranslateContextMethods "Scan the object memory for MethodContexts, translating their methods and installing the results in their translatedMethod slot. Note that there is one problematical MethodContext: that which was active for #snapshot:andQuit: when the image was saved. This context has its root bit set, and so will not be placed in the root table when the translated method is stored into it. We therefore remove any root bits that we find set in the method contexts for which new translated methods are generated." | oop header | self inline: false. oop _ self firstAccessibleObject. [oop = nil] whileFalse: [ (self fetchClassOf: oop) = (self splObj: ClassMethodContext) ifTrue: [ header _ self longAt: oop. (header bitAnd: RootBit) = 0 ifFalse: [self longAt: oop put: (header bitAnd: AllButRootBit)]. newMethod _ self fetchPointer: MethodIndex ofObject: oop. (self fetchClassOf: newMethod) = (self splObj: ClassCompiledMethod) ifTrue: [ self translateNewMethod. self assertIsTranslatedMethod: newTranslatedMethod. self storePointer: TranslatedMethodIndex ofObject: oop withValue: newTranslatedMethod. ]. ]. oop _ self accessibleObjectAfter: oop. ].! ! !DynamicInterpreter methodsFor: 'utilities'! areIntegers: oop1 and: oop2 ^ ((oop1 bitAnd: oop2) bitAnd: 1) ~= 0! ! !DynamicInterpreter methodsFor: 'utilities' stamp: 'jm 2/15/98 17:10'! 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. ! ! !DynamicInterpreter methodsFor: 'utilities'! booleanValueOf: obj obj = trueObj ifTrue: [ ^ true ]. obj = falseObj ifTrue: [ ^ false ]. successFlag _ false. ^ nil! ! !DynamicInterpreter methodsFor: 'utilities'! checkedIntegerValueOf: intOop "Note: May be called by translated primitive code." (self isIntegerObject: intOop) ifTrue: [ ^ self integerValueOf: intOop ] ifFalse: [ self primitiveFail. ^ 0 ]! ! !DynamicInterpreter methodsFor: 'utilities' stamp: 'ikp 8/25/97 23:37'! externalizeIPandSP "Copy the local instruction and stack pointer to global variables for use in primitives and other functions outside the interpret loop." self internalSetInstructionPointer: (self cCoerce: localIP to: 'int'). self internalSetStackPointer: (self cCoerce: localSP to: 'int'). ! ! !DynamicInterpreter methodsFor: 'utilities' stamp: 'jm 2/15/98 17:10'! 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 ! ! !DynamicInterpreter 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! ! !DynamicInterpreter 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 ]! ! !DynamicInterpreter methodsFor: 'utilities' stamp: 'ikp 8/18/97 12:26'! 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 successIfClassOf: 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]. ! ! !DynamicInterpreter methodsFor: 'utilities' stamp: 'ikp 8/18/97 11:11'! 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 successIfClassOf: oop is: (self splObj: ClassFloat). successFlag ifTrue: [self fetchFloatAt: oop + BaseHeaderSize into: result] ifFalse: [result _ 0.0]. ^ result! ! !DynamicInterpreter methodsFor: 'utilities' stamp: 'ikp 8/27/97 18:12'! internalizeIPandSP "Copy the local instruction and stack pointer to local variables for rapid access within the interpret loop." self assertStackPointerIsExternal. localCP _ "self cCoerce:" activeCachedContext "to: 'char *'". localIP _ self cCoerce: self internalInstructionPointer to: 'char *'. localSP _ self cCoerce: self internalStackPointer to: 'char *'. self assertStackPointerIsInternal. " localTP _ self cCoerce: self internalTemporaryPointer to: 'char *'." " localTP _ self cCoerce: theTemporaryPointer to: 'char *'."! ! !DynamicInterpreter 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! ! !DynamicInterpreter 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).! ! !DynamicInterpreter 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 ].! ! !DynamicInterpreter methodsFor: 'utilities' stamp: 'jm 2/16/98 11:13'! sizeOfSTArrayFromCPrimitive: cPtr "Return the number of indexable fields of the given object. This method is to be called from an automatically generated C primitive. The argument is assumed to be a pointer to the first indexable field of a words or bytes object; the object header start 4 bytes before that." "Note: Only called by translated primitive code." | oop | self var: #cPtr declareC: 'void *cPtr'. oop _ self cCode: '((int) cPtr) - 4'. (self isWordsOrBytes: oop) ifFalse: [ self primitiveFail. ^ 0]. ^ self lengthOf: oop ! ! !DynamicInterpreter 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 ].! ! !DynamicInterpreter methodsFor: 'utilities' stamp: 'ikp 8/18/97 11:10'! successIfClassOf: 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. ! ! !DynamicInterpreter methodsFor: 'utilities' stamp: 'ikp 8/18/97 11:12'! successIfFloat: 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 successIfClassOf: oop1 is: floatClass. self successIfClassOf: oop2 is: floatClass. ].! ! !DynamicInterpreter methodsFor: 'utilities' stamp: 'ikp 12/27/97 14:50'! translatedInstructionIndex: ip toPointerIn: tMeth self inline: true. ^(((self integerValueOf: ip) - (self translatedMethodBias: tMeth)) * 8) + (4 * MethodOpcodeStart) + tMeth! ! !DynamicInterpreter methodsFor: 'utilities' stamp: 'ikp 12/27/97 14:50'! translatedInstructionPointer: ip toIndexIn: tMeth self inline: true. ^self integerObjectOf: (((ip - tMeth - (MethodOpcodeStart * 4)) // 8) + (self translatedMethodBias: tMeth))! ! !DynamicInterpreter methodsFor: 'object memory support' stamp: 'ikp 1/6/98 14:58'! 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. messageSelector _ self remap: messageSelector. bytePointer _ bytePointer - newMethod. "*** rel to newMethod" opPointer _ opPointer - newTranslatedMethod. "*** rel to newTranslatedMethod" newMethod _ self remap: newMethod. newTranslatedMethod _ self remap: newTranslatedMethod. bytePointer _ bytePointer + newMethod. opPointer _ opPointer + newTranslatedMethod. (newReceiver = 0 or: [self isIntegerObject: newReceiver]) ifFalse: [newReceiver _ self remap: newReceiver]. (pseudoReceiver = 0) ifFalse: [pseudoReceiver _ self remap: pseudoReceiver]. self mapContextCache. 1 to: remapBufferCount do: [ :i | oop _ remapBuffer at: i. (self isIntegerObject: oop) ifFalse: [ remapBuffer at: i put: (self remap: oop). ]. ]. UseMethodCacheHashBits "If the method cache uses proper hashes, then remap its contents" ifTrue: [self remapMethodCache]. ! ! !DynamicInterpreter methodsFor: 'object memory support' stamp: 'ikp 1/6/98 14:59'! markAndTraceInterpreterOops "Mark and trace all oops in the interpreter's state." "Assume: All traced variables contain valid oops." | oop | "self verifyImage." self markAndTrace: specialObjectsOop. "also covers nilObj, trueObj, falseObj, and compact classes" "Tolerate SmallIntegers as selectors" (self isIntegerObject: messageSelector) ifFalse: [self markAndTrace: messageSelector]. self markAndTrace: newMethod. self markAndTrace: newTranslatedMethod. (newReceiver = 0 or: [self isIntegerObject: newReceiver]) ifFalse: [self markAndTrace: newReceiver]. (pseudoReceiver = 0) ifFalse: [self markAndTrace: pseudoReceiver]. self markAndTraceContextCache. 1 to: remapBufferCount do: [ :i | oop _ remapBuffer at: i. (self isIntegerObject: oop) ifFalse: [ self markAndTrace: oop. ]. ]. UseMethodCacheHashBits ifTrue: [self markAndTraceMethodCache] "If the method cache uses oops as hashes, need to toss the whole thing." ifFalse: [self flushMethodCache].! ! !DynamicInterpreter methodsFor: 'object memory support' stamp: 'ikp 1/5/98 17:51'! postGCAction | acc | " self mapCachedTemporaryPointers." acc _ activeCachedContext. acc = 0 ifFalse: [ self addRootsForCachedContext: acc. self setTemporaryPointer: (self temporaryPointerForCachedContext: acc). checkAssertions ifTrue: [self verifyStack. self verifyMethodCache]. ].! ! !DynamicInterpreter methodsFor: 'compiled methods'! argumentCountOf: methodPointer ^ ((self headerOf: methodPointer) >> 25) bitAnd: 16r1F! ! !DynamicInterpreter methodsFor: 'compiled methods'! headerOf: methodPointer ^self fetchPointer: HeaderIndex ofObject: methodPointer! ! !DynamicInterpreter methodsFor: 'compiled methods' stamp: 'ikp 8/26/97 00:48'! literal: offset "Assumes: always inlined into the interpreter loop" ^self literal: offset ofMethod: self internalMethod! ! !DynamicInterpreter methodsFor: 'compiled methods'! literal: offset ofMethod: methodPointer ^ self fetchPointer: offset + LiteralStart ofObject: methodPointer ! ! !DynamicInterpreter methodsFor: 'compiled methods'! literalCountOf: methodPointer ^self literalCountOfHeader: (self headerOf: methodPointer)! ! !DynamicInterpreter methodsFor: 'compiled methods'! literalCountOfHeader: headerPointer ^ (headerPointer >> 10) bitAnd: 16rFF! ! !DynamicInterpreter methodsFor: 'compiled methods'! methodClassOf: methodPointer ^ self fetchPointer: ValueIndex ofObject: (self literal: (self literalCountOf: methodPointer) - 1 ofMethod: methodPointer)! ! !DynamicInterpreter methodsFor: 'compiled methods' stamp: 'ikp 9/29/97 20:58'! 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]! ! !DynamicInterpreter methodsFor: 'compiled methods' stamp: 'ikp 8/25/97 14:15'! primitiveNewMethod | header bytecodeCount class size theNewMethod 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. theNewMethod _ self instantiateClass: class indexableSize: size. self storePointer: HeaderIndex ofObject: theNewMethod withValue: header. literalCount _ self literalCountOfHeader: header. 1 to: literalCount do: [:i | self storePointer: i ofObject: theNewMethod withValue: nilObj]. self push: theNewMethod! ! !DynamicInterpreter methodsFor: 'registers' stamp: 'ikp 8/25/97 22:43'! instructionPointer ^self cachedInstructionPointerAt: activeCachedContext! ! !DynamicInterpreter methodsFor: 'registers' stamp: 'ikp 8/25/97 23:38'! internalInstructionPointer ^self cachedInstructionPointerAt: localCP! ! !DynamicInterpreter methodsFor: 'registers' stamp: 'ikp 8/26/97 00:48'! internalMethod ^self cachedMethodAt: localCP! ! !DynamicInterpreter methodsFor: 'registers' stamp: 'ikp 8/25/97 23:48'! internalReceiver ^self cachedReceiverAt: localCP! ! !DynamicInterpreter methodsFor: 'registers' stamp: 'ikp 8/27/97 23:48'! internalSetInstructionPointer: ip self cachedInstructionPointerAt: localCP put: ip! ! !DynamicInterpreter methodsFor: 'registers' stamp: 'ikp 8/27/97 23:49'! internalSetStackPointer: sp self cachedStackPointerAt: localCP put: sp! ! !DynamicInterpreter methodsFor: 'registers' stamp: 'ikp 8/25/97 23:39'! internalStackPointer ^self cachedStackPointerAt: localCP! ! !DynamicInterpreter methodsFor: 'registers' stamp: 'ikp 12/1/97 22:32'! internalTranslatedMethod ^self cachedTranslatedMethodAt: localCP! ! !DynamicInterpreter methodsFor: 'registers' stamp: 'ikp 8/26/97 00:55'! setStackPointer: sp self cachedStackPointerAt: activeCachedContext put: sp! ! !DynamicInterpreter methodsFor: 'registers' stamp: 'ikp 8/27/97 10:50'! setTemporaryPointer: tp theTemporaryPointer _ tp! ! !DynamicInterpreter methodsFor: 'registers' stamp: 'ikp 8/25/97 23:18'! stackPointer ^self cachedStackPointerAt: activeCachedContext! ! !DynamicInterpreter methodsFor: 'registers' stamp: 'ikp 8/27/97 10:50'! temporaryPointer "^self cachedTemporaryPointerAt: activeCachedContext" ^theTemporaryPointer! ! !DynamicInterpreter methodsFor: 'registers' stamp: 'ikp 12/1/97 22:32'! translatedMethod ^self cachedTranslatedMethodAt: activeCachedContext! ! !DynamicInterpreter methodsFor: 'context cache' stamp: 'ikp 12/11/97 17:01'! cachedInstructionIndexAt: cp " | result | self inline: true. self assertIsCachedContext: cp. result _ self longAt: cp + (CacheInstructionPointerIndex * 4). self assertIsIntegerObject: result. ^result " | meth index ip | self inline: true. ip _ self cachedInstructionPointerAt: cp. meth _ self cachedTranslatedMethodAt: cp. index _ self translatedInstructionPointer: ip toIndexIn: meth. self assertIsLegalTranslatedInstructionIndex: index in: meth. ^index ! ! !DynamicInterpreter methodsFor: 'context cache' stamp: 'ikp 12/11/97 17:01'! cachedInstructionIndexAt: cp put: anInteger "Only for use in situations where the transformation of representation is required." self inline: true. self assertIsIntegerObject: anInteger. self cachedInstructionPointerAt: cp put: (self translatedInstructionIndex: anInteger toPointerIn: (self cachedTranslatedMethodAt: cp)).! ! !DynamicInterpreter methodsFor: 'context cache' stamp: 'ikp 12/11/97 17:02'! cachedInstructionPointerAt: cp " | meth index ip | self inline: true. self assertIsCachedContext: cp. meth _ self cachedMethodAt: cp. index _ self longAt: cp + (CacheInstructionPointerIndex * 4). self assertIsIntegerObject: index. index _ self integerValueOf: index. ip _ meth + BaseHeaderSize + index - 2. self assertIsLegalInstructionPointer: ip in: meth. ^ip " self inline: true. self assertIsCachedContext: cp. self assertIsLegalTranslatedInstructionPointer: (self longAt: cp + (CacheInstructionPointerIndex * 4)) in: (self cachedTranslatedMethodAt: cp). ^self longAt: cp + (CacheInstructionPointerIndex * 4)! ! !DynamicInterpreter methodsFor: 'context cache' stamp: 'ikp 12/11/97 17:02'! cachedInstructionPointerAt: cp put: rawPointer " | meth index | self inline: true. self assertIsCachedContext: cp. meth _ self cachedMethodAt: cp. index _ self integerObjectOf: (rawPointer - meth - BaseHeaderSize + 2). self assertIsLegalInstructionIndex: index in: meth. self longAt: cp + (CacheInstructionPointerIndex * 4) put: index " self inline: true. self assertIsLegalTranslatedInstructionPointer: rawPointer in: (self cachedTranslatedMethodAt: cp). self longAt: cp + (CacheInstructionPointerIndex * 4) put: rawPointer! ! !DynamicInterpreter methodsFor: 'context cache' stamp: 'ikp 1/1/98 23:51'! cachedTranslatedMethodAt: cp self inline: true. self assertIsCachedContext: cp. self assertIsTranslatedMethod: (self longAt: cp + (CacheTranslatedMethodIndex * 4)). ^self longAt: cp + (CacheTranslatedMethodIndex * 4)! ! !DynamicInterpreter methodsFor: 'context cache' stamp: 'ikp 1/1/98 23:52'! cachedTranslatedMethodAt: cp put: anArray self inline: true. self assertIsCachedContext: cp. self assertIsTranslatedMethod: anArray. self longAt: cp + (CacheTranslatedMethodIndex * 4) put: anArray! ! !DynamicInterpreter methodsFor: 'context cache-private' stamp: 'ikp 12/1/97 14:56'! basicCachedTranslatedMethodAt: cp "For use during GC remapping" self inline: true. self assertIsCachedContext: cp. ^self longAt: cp + (CacheTranslatedMethodIndex * 4)! ! !DynamicInterpreter methodsFor: 'context cache-private' stamp: 'ikp 12/1/97 14:56'! basicCachedTranslatedMethodAt: cp put: anArray "For use during GC remapping" self inline: true. self assertIsCachedContext: cp. self longAt: cp + (CacheTranslatedMethodIndex * 4) put: anArray! ! !DynamicInterpreter methodsFor: 'context cache-private' stamp: 'ikp 1/1/98 23:52'! translatedMethodOfBlockContext: blockContext | home cp tMeth | self assertIsStableBlockContext: blockContext. home _ self fetchPointer: HomeIndex ofObject: blockContext. (self isPseudoContext: home) ifTrue: [ cp _ self pseudoCachedContextAt: home. tMeth _ self cachedTranslatedMethodAt: cp. ] ifFalse: [ tMeth _ self fetchPointer: TranslatedMethodIndex ofObject: home. ]. self assertIsTranslatedMethod: tMeth. ^tMeth! ! !DynamicInterpreter methodsFor: 'contexts' stamp: 'ikp 8/28/97 00:58'! argumentCountOfBlock: blockPointer | argCount | argCount _ self fetchPointer: BlockArgumentCountIndex ofObject: blockPointer. (self isIntegerObject: argCount) ifTrue: [ ^ self integerValueOf: argCount ] ifFalse: [ self primitiveFail. ^0 ].! ! !DynamicInterpreter methodsFor: 'contexts' stamp: 'ikp 8/27/97 10:49'! fetchContextRegisters: ctx "No-op. (The cache interpreter runs directly out of the cached context when IP/SP are external. :)" self addRootsForCachedContext: ctx. self setTemporaryPointer: (self temporaryPointerForCachedContext: ctx)! ! !DynamicInterpreter methodsFor: 'contexts' stamp: 'ikp 8/27/97 10:55'! internalFetchContextRegisters "Need only to fetch the local registers from the cached context." self inline: true. self setTemporaryPointer: (self temporaryPointerForCachedContext: activeCachedContext). self internalizeIPandSP. self addRootsForCachedContext: localCP.! ! !DynamicInterpreter methodsFor: 'contexts' stamp: 'ikp 8/14/97 16:42'! internalPop: nItems localSP _ localSP - (nItems * 4).! ! !DynamicInterpreter methodsFor: 'contexts' stamp: 'ikp 8/22/97 22:09'! internalPop: nItems thenPush: oop self longAt: (localSP _ localSP - ((nItems - 1) * 4)) put: oop. ! ! !DynamicInterpreter methodsFor: 'contexts' stamp: 'ikp 8/22/97 22:09'! internalPush: object self longAt: (localSP _ localSP + 4) put: object.! ! !DynamicInterpreter methodsFor: 'contexts' stamp: 'ikp 8/22/97 22:09'! internalStackTop ^ self longAt: localSP! ! !DynamicInterpreter methodsFor: 'contexts' stamp: 'ikp 8/14/97 16:44'! internalStackValue: offset ^ self longAt: localSP - (offset * 4)! ! !DynamicInterpreter methodsFor: 'contexts' stamp: 'ikp 8/16/97 23:59'! methodOfBlockContext: blockContext | home cp | self assertIsStableBlockContext: blockContext. home _ self fetchPointer: HomeIndex ofObject: blockContext. (self isPseudoContext: home) ifTrue: [ cp _ self pseudoCachedContextAt: home. ^self cachedMethodAt: cp. ] ifFalse: [ ^self fetchPointer: MethodIndex ofObject: home. ]. ! ! !DynamicInterpreter methodsFor: 'contexts' stamp: 'ikp 8/25/97 14:32'! pop: nItems "Note: May be called by translated primitive code." self setStackPointer: (self stackPointer - (nItems*4)).! ! !DynamicInterpreter methodsFor: 'contexts' stamp: 'ikp 8/25/97 14:32'! pop: nItems thenPush: oop | sp | self longAt: (sp _ self stackPointer - ((nItems - 1) * 4)) put: oop. self setStackPointer: sp. ! ! !DynamicInterpreter 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"]! ! !DynamicInterpreter methodsFor: 'contexts'! popPos32BitInteger "May set successFlag, and return false if not valid" | top | top _ self popStack. ^ self positive32BitValueOf: top! ! !DynamicInterpreter methodsFor: 'contexts' stamp: 'ikp 8/25/97 14:32'! popStack | top | top _ self longAt: self stackPointer. self setStackPointer: (self stackPointer - 4). ^ top! ! !DynamicInterpreter methodsFor: 'contexts' stamp: 'ikp 8/25/97 14:32'! push: object | sp | self longAt: (sp _ self stackPointer + 4) put: object. self setStackPointer: sp.! ! !DynamicInterpreter methodsFor: 'contexts'! pushBool: trueOrFalse trueOrFalse ifTrue: [ self push: trueObj ] ifFalse: [ self push: falseObj ].! ! !DynamicInterpreter methodsFor: 'contexts'! pushInteger: integerValue self push: (self integerObjectOf: integerValue).! ! !DynamicInterpreter methodsFor: 'contexts' stamp: 'ikp 8/17/97 00:45'! receiverOfBlockContext: blockContext | home cp | self assertIsStableBlockContext: blockContext. home _ self fetchPointer: HomeIndex ofObject: blockContext. (self isPseudoContext: home) ifTrue: [ cp _ self pseudoCachedContextAt: home. ^self cachedReceiverAt: cp. ] ifFalse: [ ^self fetchPointer: ReceiverIndex ofObject: home. ]. ! ! !DynamicInterpreter methodsFor: 'contexts' stamp: 'ikp 8/25/97 11:32'! stackIntegerValue: offset | integerPointer | integerPointer _ self longAt: self stackPointer - (offset*4). (self isIntegerObject: integerPointer) ifTrue: [ ^self integerValueOf: integerPointer ] ifFalse: [ self primitiveFail. ^0 ]! ! !DynamicInterpreter methodsFor: 'contexts' stamp: 'ikp 8/25/97 11:32'! stackTop ^self longAt: self stackPointer! ! !DynamicInterpreter methodsFor: 'contexts' stamp: 'ikp 8/25/97 11:32'! stackValue: offset ^ self longAt: self stackPointer - (offset*4)! ! !DynamicInterpreter methodsFor: 'contexts' stamp: 'ikp 8/27/97 18:12'! temporary: offset self assertIsLegalTempOffset: offset. ^ self longAt: self temporaryPointer"localTP" + (offset * 4)! ! !DynamicInterpreter methodsFor: 'contexts' stamp: 'ikp 8/27/97 18:12'! temporary: offset put: aValue self assertIsLegalTempOffset: offset. ^ self longAt: self temporaryPointer"localTP" + (offset * 4) put: aValue! ! !DynamicInterpreter methodsFor: 'contexts' stamp: 'ikp 8/25/97 14:32'! unPop: nItems self setStackPointer: self stackPointer + (nItems*4)! ! !DynamicInterpreter 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 ! ! !DynamicInterpreter 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! ! !DynamicInterpreter methodsFor: 'message sending' stamp: 'ikp 12/28/97 22:30'! activateNewMethod "Activate the method in newMethod. Receiver and arguments are on the stack. Assumes: ArgumentCount is set appropriately. The topmost cached context is still active. IP and SP are external. newTranslatedMethod contains a translation of newMethod" | newContext methodHeader tempCount cp newFrame oldSP newSP oldContext argCount nilOop | self inline: false. self assertStackPointerIsExternal. argCount _ argumentCount. oldContext _ activeCachedContext. oldSP _ self cachedStackPointerAt: oldContext. newFrame _ oldSP - (argCount * 4) + 4. "first argument" newSP _ newFrame - 8. "pop arguments and receiver" newContext _ self allocateCachedContextAfter: oldContext frame: newFrame. "can cause GC!!" self cachedStackPointerAt: oldContext put: newSP. "updated AFTER possible GC" stackOverflow ifTrue: [ newFrame _ self cachedFramePointerAt: newContext. self transfer: argCount wordsFrom: newSP + 8 to: newFrame. stackOverflow _ false. ]. methodHeader _ self headerOf: newMethod. tempCount _ (methodHeader >> 19) bitAnd: 16r3F. tempCount > argCount ifTrue: [ nilOop _ nilObj. self fill: tempCount - argCount wordsFrom: newFrame + (argCount * 4) with: nilOop. ]. self cachedMethodAt: newContext put: (newMethod). self cachedTranslatedMethodAt: newContext put: (newTranslatedMethod). self cachedReceiverAt: newContext put: (self longAt: (newSP + 4)). self cachedHomeAt: newContext put: 0. self cachedInstructionPointerAt: newContext put: (newTranslatedMethod + BaseHeaderSize + ((MethodOpcodeStart - "pre-incr" 1) * 4)). self cachedStackPointerAt: newContext put: (newFrame + (tempCount * 4) - 4). " self cachedTemporaryPointerAt: newContext put: newFrame." self setTemporaryPointer: newFrame. pseudoReceiver = 0 ifFalse: [ self assertIsPseudoContext: pseudoReceiver. cp _ self pseudoCachedContextAt: pseudoReceiver. self flushCacheFrom: cp. pseudoReceiver _ 0. "self cachedContextReceiverFlagAt: cp put: 1." "non-zero" "deprecated" ]. ! ! !DynamicInterpreter methodsFor: 'message sending'! argCount ^ argumentCount! ! !DynamicInterpreter methodsFor: 'message sending' stamp: 'ikp 8/25/97 11:32'! createActualMessage | argumentArray message | self inline: false. 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 pop: argumentCount. self transfer: argumentCount wordsFrom: self stackPointer + 4 "first argument" to: argumentArray + BaseHeaderSize. "first indexed field" self push: message. argumentCount _ 1.! ! !DynamicInterpreter methodsFor: 'message sending' stamp: 'ikp 1/5/98 16:20'! executeForCachedReceiver "Execute newMethod for a cached receiver, which might or might not be the activeCachedContext" | cp | self inline: false. self assert: pseudoReceiver = newReceiver. cp _ self pseudoCachedContextAt: pseudoReceiver. self assert: (self cachedPseudoContextAt: cp) = pseudoReceiver. cp = activeCachedContext ifTrue: [ (primitiveIndex = 0 or: [self primitiveResponseForCachedReceiver not]) ifTrue: [ "Bail out and perform a full activation. This case is extremely rare, and will get even rarer once the #release anachronisms in Process>>terminate (left over from the days of reference counting) are removed from the image." self activateNewMethod. "...which cleans up the receiver situation for us" self quickCheckForInterrupts. ]. pseudoReceiver _ 0. ] ifFalse: [ self flushCacheFrom: cp. self assertIsStableContext: newReceiver. pseudoReceiver _ 0. (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. ]. ].! ! !DynamicInterpreter methodsFor: 'message sending' stamp: 'ikp 8/17/97 13:28'! executeForNormalReceiver self inline: true. (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. ]. ! ! !DynamicInterpreter methodsFor: 'message sending' stamp: 'ikp 1/5/98 17:51'! executeNewMethod "The common case (not a pseudo receiver) is inlined; the other is not." self inline: true. pseudoReceiver = 0 ifTrue: [ self executeForNormalReceiver. ] ifFalse: [ self assert: pseudoReceiver = newReceiver. "One special case: #blockCopy for the activeCachedContext is inlined." "This is utterly redundant now that we have MacroPushBlock" (primitiveIndex = 80 and: [(self pseudoCachedContextAt: pseudoReceiver) = activeCachedContext]) ifTrue: [ self primitiveBlockCopy. pseudoReceiver _ 0. ] ifFalse: [ self executeForCachedReceiver. ] ]! ! !DynamicInterpreter methodsFor: 'message sending' stamp: 'ikp 1/13/98 00:44'! 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 cls sel | self inline: true. sel _ messageSelector. ok _ self lookupInMethodCacheSel: sel class: class. ok ifFalse: [ statMethodCacheMisses _ statMethodCacheMisses + 1. "entry was not found in the cache; look it up the hard way" self pushRemappableOop: class. self lookupMethodInClass: class. "Can provoke GC if createActualMessage is called" cls _ self popRemappableOop. primitiveIndex _ self primitiveIndexOf: newMethod. "Avoid creating cache entries for PseudoContexts" pseudoReceiver = 0 ifTrue: [ self assert: cls ~= (self splObj: ClassPseudoContext). self addToMethodCacheSel: messageSelector class: cls method: newMethod primIndex: primitiveIndex translatedMethod: newTranslatedMethod. ]. ]. ! ! !DynamicInterpreter methodsFor: 'message sending' stamp: 'ikp 12/9/97 15:49'! lookupMethodInClass: class "Assumes: newReceiver contains the receiver with the given class" | currentClass dictionary found stableClass cls | currentClass _ class. [currentClass ~= nilObj] whileTrue: [ dictionary _ self fetchPointer: MessageDictionaryIndex ofObject: currentClass. found _ self lookupMethodInDictionary: dictionary. found ifTrue: [^currentClass]. currentClass _ self superclassOf: currentClass. ]. class = (self splObj: ClassPseudoContext) ifTrue: [ self assertIsPseudoContext: newReceiver. pseudoReceiver _ newReceiver. "changes behaviour of {activate,execute}NewMethod" stableClass _ self stableClassOf: newReceiver. self assertIsStableContextClass: stableClass. self lookupMethodInClass: stableClass. ^nilObj. "stableClass might be hit by a GC in the recursive call" ]. messageSelector = (self splObj: SelectorDoesNotUnderstand) ifTrue: [ self error: 'Recursive not understood error encountered' ]. self pushRemappableOop: class. self createActualMessage. cls _ self popRemappableOop. messageSelector _ self splObj: SelectorDoesNotUnderstand. ^self lookupMethodInClass: cls! ! !DynamicInterpreter methodsFor: 'message sending' stamp: 'ikp 11/30/97 16:11'! 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. "*** found newMethod: now create newTranslatedMethod ***" self translateNewMethod. ^true]. index _ index + 1. index = length ifTrue: [wrapAround ifTrue: [^false]. wrapAround _ true. index _ SelectorStart]]! ! !DynamicInterpreter methodsFor: 'message sending' stamp: 'ikp 12/20/97 02:55'! sendSelectorToClass: classPointer "Note: Requires that instructionPointer and stackPointer be externalized." self inline: true. self findNewMethodInClass: classPointer. self executeNewMethod. ! ! !DynamicInterpreter methodsFor: 'message sending'! specialSelector: index ^ self fetchPointer: (index * 2) ofObject: (self splObj: SpecialSelectors)! ! !DynamicInterpreter methodsFor: 'message sending'! superclassOf: classPointer ^ self fetchPointer: SuperclassIndex ofObject: classPointer! ! !DynamicInterpreter methodsFor: 'method lookup cache' stamp: 'ikp 1/14/98 01:46'! addToMethodCacheSel: selector class: class method: meth primIndex: primIndex translatedMethod: tMeth "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" UseMethodCacheHashBits ifTrue: [probe _ (((self hashForCacheWithSelector: selector class: class) >> mcProbe) bitAnd: MethodCacheMask) + 1] ifFalse: [probe _ (((selector bitXor: class) >> (mcProbe + 2)) bitAnd: MethodCacheMask) + 1]. "...and replace the entry at that probe addresses" self assertIsCompiledMethod: meth. self assertIsTranslatedMethod: tMeth. (methodCache at: probe + MethodCacheSelectorCol) = 0 ifFalse: [self ejectMethodCacheLine: probe]. methodCache at: probe + MethodCacheSelectorCol put: selector. methodCache at: probe + MethodCacheClassCol put: class. methodCache at: probe + MethodCacheMethodCol put: meth. methodCache at: probe + MethodCachePrimIndexCol put: primIndex. methodCache at: probe + MethodCacheTMethodCol put: tMeth. UseInlineCacheDelay ifTrue: [methodCache at: probe + MethodCacheDelayCol put: inlineCacheDelay. newInlineCacheDelay _ inlineCacheDelay].! ! !DynamicInterpreter methodsFor: 'method lookup cache' stamp: 'ikp 12/18/97 03:00'! hashForCacheWithSelector: selector class: class | selHash | self inline: true. (self isIntegerObject: selector) ifTrue: ["We tolerate integers as selectors for now. This allows an image to have selectors scrunched out to save space." selHash _ self integerValueOf: selector] ifFalse: [selHash _ self hashBitsOf: messageSelector]. ^ selHash bitXor: (self hashBitsOf: class)! ! !DynamicInterpreter methodsFor: 'method lookup cache' stamp: 'ikp 1/14/98 01:45'! 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: The method cache must either be compeltely flushed, or all pointers must be remapped following a compaction (ie, incremental or full GC)." | hash probe oldDelay | self inline: true. UseMethodCacheHashBits ifTrue: [hash _ self hashForCacheWithSelector: selector class: class] ifFalse: [hash _ (selector bitXor: class) >> 2]. "drop two low-order zeros from addresses" probe _ (hash bitAnd: MethodCacheMask) + 1. "initial probe" 1 to: CacheProbeMax do: [ :p | (((methodCache at: probe + MethodCacheSelectorCol) = selector) and: [(methodCache at: probe + MethodCacheClassCol) = class]) ifTrue: [newMethod _ methodCache at: probe + MethodCacheMethodCol. primitiveIndex _ methodCache at: probe + MethodCachePrimIndexCol. newTranslatedMethod _ methodCache at: probe + MethodCacheTMethodCol. statMethodCacheHits _ statMethodCacheHits + 1. UseInlineCacheDelay ifTrue: [ oldDelay _ methodCache at: probe + MethodCacheDelayCol. oldDelay > 0 ifTrue: [methodCache at: probe + MethodCacheDelayCol put: oldDelay - 1]. newInlineCacheDelay _ oldDelay. ]. ^ true "found entry in cache; done" ]. probe _ ((hash >> p) bitAnd: MethodCacheMask) + 1 ]. ^ false ! ! !DynamicInterpreter methodsFor: 'method lookup cache' stamp: 'ikp 12/27/97 15:31'! markAndTraceMethodCache "Mark from the translated methods in the method cache. This is necessary since the method cache might be the only place that still has a reference to a given translated method. It is also necessary to support selective flush because a class definition change may #become: the class in the hierarchy, leaving an obsolete class referenced only from the cache." self inline: false. 1 to: MethodCacheEntries do: [:i | self markAndTraceMethodCacheLine: i]. " 1 to: MethodCacheEntries do: [:i | (methodCache at: i) = 0 ifFalse: [self markAndTrace: (methodCache at: i + (MethodCacheEntries * 4))]]. "! ! !DynamicInterpreter methodsFor: 'method lookup cache' stamp: 'ikp 1/14/98 01:01'! markAndTraceMethodCacheLine: lineIndex | oldOop | self inline: true. oldOop _ methodCache at: lineIndex + MethodCacheSelectorCol. oldOop ~= 0 ifTrue: [self markAndTrace: oldOop. oldOop _ methodCache at: lineIndex + MethodCacheClassCol. self markAndTrace: oldOop. oldOop _ methodCache at: lineIndex + MethodCacheMethodCol. self markAndTrace: oldOop. oldOop _ methodCache at: lineIndex + MethodCacheTMethodCol. self markAndTrace: oldOop]. ! ! !DynamicInterpreter methodsFor: 'method lookup cache' stamp: 'ikp 12/18/97 03:00'! remapMethodCache "Remap all pointers in the method cache. The method cache must be remapped following a compaction (inc or full gc)." self inline: false. 1 to: MethodCacheEntries do: [:i | self remapMethodCacheLine: i].! ! !DynamicInterpreter methodsFor: 'method lookup cache' stamp: 'ikp 1/14/98 01:05'! remapMethodCacheLine: lineIndex | oldOop | self inline: true. oldOop _ methodCache at: lineIndex + MethodCacheSelectorCol. oldOop ~= 0 ifTrue: [methodCache at: lineIndex + MethodCacheSelectorCol put: (self remap: oldOop). oldOop _ methodCache at: lineIndex + MethodCacheClassCol. methodCache at: lineIndex + MethodCacheClassCol put: (self remap: oldOop). oldOop _ methodCache at: lineIndex + MethodCacheMethodCol. methodCache at: lineIndex + MethodCacheMethodCol put: (self remap: oldOop). oldOop _ methodCache at: lineIndex + MethodCacheTMethodCol. methodCache at: lineIndex + MethodCacheTMethodCol put: (self remap: oldOop)]. ! ! !DynamicInterpreter methodsFor: 'interpreter shell' stamp: 'ikp 12/12/97 18:00'! interpret "If newTranslatedMethod = nilObj then the interpreter is initialising: dispatch on opcodeIndex to store the address of the opcode in opcodeAddress, then return. If newTranslatedMethod ~= nilObj then the interpreter is starting execution: dispatch to the first instruction to begin execution." "Note: the current instruction is called currentBytecode for historical reasons (and is hard to change without breaking compatibility with the original Interpreter in the CCodeGenerator)." "Note: in the simulator this code is only executed for initialisation, never for execution." self inline: false. self interpreterInitializing ifFalse: [ checkAssertions ifTrue: [self print: 'Warning: assertions are enabled'; cr]. self internalizeIPandSP. self nextOp. "dispatches to first instruction" ]. currentBytecode _ opcodeIndex. opcodeAddress _ 0. "the following loop is executed exactly once, but is needed to defeat dead code elimination in some C compilers" [opcodeAddress = 0] whileTrue: [self dispatchOn: currentBytecode in: OpcodeTable]. ^opcodeAddress! ! !DynamicInterpreter methodsFor: 'interpreter shell' stamp: 'ikp 12/28/97 22:30'! interpreterInitializing ^newTranslatedMethod = nilObj! ! !DynamicInterpreter methodsFor: 'primitive support'! failed ^successFlag not! ! !DynamicInterpreter 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! ! !DynamicInterpreter methodsFor: 'primitive support' stamp: 'ikp 8/18/97 11:11'! 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 successIfClassOf: 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) ].! ! !DynamicInterpreter methodsFor: 'primitive support'! primIndex ^ primitiveIndex! ! !DynamicInterpreter methodsFor: 'primitive support' stamp: 'ikp 8/27/97 23:44'! primitiveFail successFlag _ false.! ! !DynamicInterpreter methodsFor: 'primitive support' stamp: 'di 2/4/98 23:54'! primitiveResponse self inline: false. 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 bitAnd: 16r1FFFFFFF) >= nextWakeupTick]]) ifTrue: [ interruptCheckCounter _ 1000. self checkForInterrupts]. ^ successFlag! ! !DynamicInterpreter methodsFor: 'primitive support' stamp: 'ikp 1/10/98 02:59'! primitiveResponseForCachedReceiver | thisReceiver ctx result cp | self inline: true. successFlag _ true. primitiveIndex >= 256 ifTrue: [thisReceiver _ self popStack. primitiveIndex < 264 ifTrue: ["Quick return of self or a constant" primitiveIndex = 256 ifTrue: [self push: thisReceiver. ^true]. primitiveIndex = 257 ifTrue: [self push: trueObj. ^true]. primitiveIndex = 258 ifTrue: [self push: falseObj. ^true]. primitiveIndex = 259 ifTrue: [self push: nilObj. ^true]. primitiveIndex = 260 ifTrue: [self push: ConstMinusOne. ^true]. primitiveIndex = 261 ifTrue: [self push: ConstZero. ^true]. primitiveIndex = 262 ifTrue: [self push: ConstOne. ^true]. primitiveIndex = 263 ifTrue: [self push: ConstTwo. ^true]. ^ true] ifFalse: ["Quick return of an instance field" self assertIsPseudoContext: thisReceiver. self assertIsPseudoActiveContext: thisReceiver. cp _ self pseudoCachedContextAt: thisReceiver. ctx _ self flushCacheFrom: cp. result _ (self fetchPointer: primitiveIndex-264 ofObject: ctx). self copyContextToCache: ctx. self fetchContextRegisters: activeCachedContext. self push: result. ^ true]] ifFalse: [^ false]! ! !DynamicInterpreter methodsFor: 'primitive support'! success: successValue successFlag _ successValue & successFlag.! ! !DynamicInterpreter methodsFor: 'arithmetic primitives' stamp: 'ikp 12/6/97 00:54'! checkBooleanResult: result self inline: true. successFlag ifTrue: [self pushBool: result] ifFalse: [self unPop: 2]! ! !DynamicInterpreter methodsFor: 'arithmetic primitives' stamp: 'ikp 12/6/97 00:55'! checkIntegerResult: integerResult self inline: true. (successFlag and: [self isIntegerValue: integerResult]) ifTrue: [self pushInteger: integerResult] ifFalse: [self unPop: 2. self primitiveFail]! ! !DynamicInterpreter 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)! ! !DynamicInterpreter methodsFor: 'arithmetic primitives' stamp: 'ikp 12/6/97 00:58'! 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! ! !DynamicInterpreter methodsFor: 'arithmetic primitives' stamp: 'ikp 12/8/97 14:25'! 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"]! ! !DynamicInterpreter methodsFor: 'arithmetic primitives' stamp: 'ikp 12/6/97 00:14'! 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"]! ! !DynamicInterpreter methodsFor: 'arithmetic primitives' stamp: 'ikp 12/23/97 12:02'! 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) bitAnd: 16rFFFFFFFF. 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"]! ! !DynamicInterpreter 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]! ! !DynamicInterpreter methodsFor: 'arithmetic primitives' stamp: 'ikp 12/6/97 00:59'! 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] ifFalse: [self unPop: 2]! ! !DynamicInterpreter methodsFor: 'arithmetic primitives' stamp: 'ikp 12/6/97 00:59'! 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! ! !DynamicInterpreter methodsFor: 'arithmetic primitives' stamp: 'ikp 12/6/97 00:55'! primitiveEqual | integerReceiver integerArgument result | successFlag _ true. integerArgument _ self popStack. integerReceiver _ self popStack. result _ self compare31or32Bits: integerReceiver equal: integerArgument. self checkBooleanResult: result! ! !DynamicInterpreter methodsFor: 'arithmetic primitives' stamp: 'ikp 12/6/97 00:55'! primitiveGreaterOrEqual | integerReceiver integerArgument | successFlag _ true. integerArgument _ self popInteger. integerReceiver _ self popInteger. self checkBooleanResult: integerReceiver >= integerArgument! ! !DynamicInterpreter methodsFor: 'arithmetic primitives' stamp: 'ikp 12/6/97 00:55'! primitiveGreaterThan | integerReceiver integerArgument | successFlag _ true. integerArgument _ self popInteger. integerReceiver _ self popInteger. self checkBooleanResult: integerReceiver > integerArgument! ! !DynamicInterpreter methodsFor: 'arithmetic primitives' stamp: 'ikp 12/6/97 00:55'! primitiveLessOrEqual | integerReceiver integerArgument | successFlag _ true. integerArgument _ self popInteger. integerReceiver _ self popInteger. self checkBooleanResult: integerReceiver <= integerArgument! ! !DynamicInterpreter methodsFor: 'arithmetic primitives' stamp: 'ikp 12/6/97 00:56'! primitiveLessThan | integerReceiver integerArgument | successFlag _ true. integerArgument _ self popInteger. integerReceiver _ self popInteger. self checkBooleanResult: integerReceiver < integerArgument! ! !DynamicInterpreter methodsFor: 'arithmetic primitives' stamp: 'ikp 12/6/97 00:59'! primitiveMakePoint | integerReceiver integerArgument | successFlag _ true. integerArgument _ self popInteger. integerReceiver _ self popInteger. successFlag ifTrue: [self push: (self makePointwithxValue: integerReceiver yValue: integerArgument)] ifFalse: [self unPop: 2]! ! !DynamicInterpreter methodsFor: 'arithmetic primitives' stamp: 'jm 2/1/98 21:43'! 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. "ensure that the result has the same sign as the argument" integerArgument < 0 ifTrue: [ integerResult > 0 ifTrue: [integerResult _ integerResult + integerArgument]. ] ifFalse: [ integerResult < 0 ifTrue: [integerResult _ integerResult + integerArgument]. ]. self checkIntegerResult: integerResult. ! ! !DynamicInterpreter methodsFor: 'arithmetic primitives' stamp: 'ikp 12/6/97 01:00'! 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! ! !DynamicInterpreter methodsFor: 'arithmetic primitives' stamp: 'ikp 12/6/97 00:56'! primitiveNotEqual | integerReceiver integerArgument result | successFlag _ true. integerArgument _ self popStack. integerReceiver _ self popStack. result _ (self compare31or32Bits: integerReceiver equal: integerArgument) not. self checkBooleanResult: result! ! !DynamicInterpreter 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]! ! !DynamicInterpreter methodsFor: 'arithmetic primitives' stamp: 'ikp 12/6/97 01:00'! primitiveSubtract | integerReceiver integerArgument | successFlag _ true. integerArgument _ self popInteger. integerReceiver _ self popInteger. self checkIntegerResult: integerReceiver - integerArgument! ! !DynamicInterpreter methodsFor: 'float primitives' stamp: 'ikp 8/18/97 11:11'! popFloat "Note: May be called by translated primitive code." | top result | self returnTypeC: 'double'. self var: #result declareC: 'double result'. top _ self popStack. self successIfClassOf: top is: (self splObj: ClassFloat). successFlag ifTrue: [self fetchFloatAt: top + BaseHeaderSize into: result]. ^ result! ! !DynamicInterpreter 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]! ! !DynamicInterpreter methodsFor: 'float primitives'! primitiveAsFloat | arg | arg _ self popInteger. successFlag ifTrue: [ self pushFloat: (self cCode: '((double) arg)') ] ifFalse: [ self unPop: 1 ].! ! !DynamicInterpreter 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]! ! !DynamicInterpreter methodsFor: 'float primitives' stamp: 'jm 2/1/98 18:55'! 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)" self pushInteger: pwr - 1] ifFalse: [self unPop: 1]. ! ! !DynamicInterpreter methodsFor: 'float primitives' stamp: 'ikp 8/18/97 11:13'! 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 successIfFloat: 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].! ! !DynamicInterpreter methodsFor: 'float primitives' stamp: 'ikp 8/18/97 11:13'! 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 successIfFloat: 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]].! ! !DynamicInterpreter methodsFor: 'float primitives' stamp: 'ikp 8/18/97 11:13'! 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 successIfFloat: rcvrOop and: argOop. successFlag ifTrue: [ self fetchFloatAt: rcvrOop + BaseHeaderSize into: rcvr. self fetchFloatAt: argOop + BaseHeaderSize into: arg. self pop: 2. self pushBool: rcvr = arg]. ! ! !DynamicInterpreter methodsFor: 'float primitives' stamp: 'ikp 8/18/97 11:13'! 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 successIfFloat: rcvrOop and: argOop. successFlag ifTrue: [ self fetchFloatAt: rcvrOop + BaseHeaderSize into: rcvr. self fetchFloatAt: argOop + BaseHeaderSize into: arg. self pop: 2. self pushBool: rcvr >= arg]. ! ! !DynamicInterpreter methodsFor: 'float primitives' stamp: 'ikp 8/18/97 11:13'! 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 successIfFloat: rcvrOop and: argOop. successFlag ifTrue: [ self fetchFloatAt: rcvrOop + BaseHeaderSize into: rcvr. self fetchFloatAt: argOop + BaseHeaderSize into: arg. self pop: 2. self pushBool: rcvr > arg]. ! ! !DynamicInterpreter methodsFor: 'float primitives' stamp: 'ikp 8/18/97 11:13'! 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 successIfFloat: rcvrOop and: argOop. successFlag ifTrue: [ self fetchFloatAt: rcvrOop + BaseHeaderSize into: rcvr. self fetchFloatAt: argOop + BaseHeaderSize into: arg. self pop: 2. self pushBool: rcvr <= arg]. ! ! !DynamicInterpreter methodsFor: 'float primitives' stamp: 'ikp 8/18/97 11:13'! 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 successIfFloat: rcvrOop and: argOop. successFlag ifTrue: [ self fetchFloatAt: rcvrOop + BaseHeaderSize into: rcvr. self fetchFloatAt: argOop + BaseHeaderSize into: arg. self pop: 2. self pushBool: rcvr < arg]. ! ! !DynamicInterpreter methodsFor: 'float primitives' stamp: 'ikp 8/18/97 11:13'! 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 successIfFloat: 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].! ! !DynamicInterpreter methodsFor: 'float primitives' stamp: 'ikp 8/18/97 11:13'! 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 successIfFloat: rcvrOop and: argOop. successFlag ifTrue: [ self fetchFloatAt: rcvrOop + BaseHeaderSize into: rcvr. self fetchFloatAt: argOop + BaseHeaderSize into: arg. self pop: 2. self pushBool: rcvr ~= arg]. ! ! !DynamicInterpreter methodsFor: 'float primitives' stamp: 'ikp 8/18/97 11:13'! 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 successIfFloat: 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].! ! !DynamicInterpreter 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]! ! !DynamicInterpreter 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]! ! !DynamicInterpreter 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]! ! !DynamicInterpreter 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]! ! !DynamicInterpreter 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 ].! ! !DynamicInterpreter methodsFor: 'float primitives' stamp: 'di 6/7/97 09:59'! 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]! ! !DynamicInterpreter 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.! ! !DynamicInterpreter methodsFor: 'array and stream primitives' stamp: 'ikp 8/18/97 11:11'! asciiOfCharacter: characterObj "Returns an integer object" self inline: false. self successIfClassOf: characterObj is: (self splObj: ClassCharacter). successFlag ifTrue: [^ self fetchPointer: CharacterValueIndex ofObject: characterObj] ifFalse: [^ ConstZero] "in case some code needs an int"! ! !DynamicInterpreter 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"! ! !DynamicInterpreter methodsFor: 'array and stream primitives'! characterForAscii: integerObj "Arg must lie in range 0-255!!" ^ self fetchPointer: (self integerValueOf: integerObj) ofObject: (self splObj: CharacterTable)! ! !DynamicInterpreter methodsFor: 'array and stream primitives' stamp: 'ikp 12/6/97 00:22'! 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]. ]. "! ! !DynamicInterpreter methodsFor: 'array and stream primitives' stamp: 'ikp 12/6/97 00:24'! 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]. ]. "! ! !DynamicInterpreter 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"! ! !DynamicInterpreter 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"! ! !DynamicInterpreter methodsFor: 'array and stream primitives'! okArrayClass: cl ^(cl = (self splObj: ClassArray) or: [cl = (self splObj: ClassBitmap) or: [cl = (self splObj: ClassByteArray)]])! ! !DynamicInterpreter 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)]]])! ! !DynamicInterpreter methodsFor: 'array and stream primitives'! primitiveAt self commonAt: false.! ! !DynamicInterpreter 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].! ! !DynamicInterpreter methodsFor: 'array and stream primitives'! primitiveAtPut self commonAtPut: false.! ! !DynamicInterpreter methodsFor: 'array and stream primitives' stamp: 'ikp 8/12/97 23:31'! 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]. ! ! !DynamicInterpreter methodsFor: 'array and stream primitives' stamp: 'ikp 8/12/97 23:32'! 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]! ! !DynamicInterpreter methodsFor: 'array and stream primitives' stamp: 'ikp 12/6/97 00:31'! primitiveSize | rcvr sz | rcvr _ self stackTop. (self isIntegerObject: rcvr) ifTrue: [sz _ 0] "integers have no indexable fields" ifFalse: [sz _ self stSizeOf: rcvr]. " ikp: this is redundant!! successFlag ifTrue: [ " self pop: 1. self pushInteger: sz " ] ifFalse: [self failSpecialPrim: 62]."! ! !DynamicInterpreter methodsFor: 'array and stream primitives'! primitiveStringAt self commonAt: true.! ! !DynamicInterpreter methodsFor: 'array and stream primitives'! primitiveStringAtPut self commonAtPut: true.! ! !DynamicInterpreter methodsFor: 'array and stream primitives'! primitiveStringReplace " primReplaceFrom: start to: stop with: replacement startingAt: repStart " | 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"! ! !DynamicInterpreter methodsFor: 'array and stream primitives'! stObject: array at: index "Return what ST would return for 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 ].! ! !DynamicInterpreter methodsFor: 'array and stream primitives'! stObject: array at: index put: value "Do what ST would return for 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]. ! ! !DynamicInterpreter methodsFor: 'array and stream primitives'! stSizeOf: oop "Return the number of indexable fields in the given object. (i.e., what Smalltalk would return for 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! ! !DynamicInterpreter 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) ].! ! !DynamicInterpreter 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]. ]. ].! ! !DynamicInterpreter methodsFor: 'object access primitives' stamp: 'ikp 1/11/98 19:18'! primitiveArrayBecome "We must flush the method cache here, to eliminate stale references to mutated classes and/or selectors." | arg rcvr | arg _ self popStack. rcvr _ self stackTop. self flushMethodCache. self flushInlineCache. self success: (self become: rcvr with: arg). successFlag ifFalse: [ self unPop: 1 ].! ! !DynamicInterpreter 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]! ! !DynamicInterpreter methodsFor: 'object access primitives' stamp: 'ikp 8/18/97 01:40'! primitiveClass | instance class cp | instance _ self popStack. class _ self fetchClassOf: instance. class = (self splObj: ClassPseudoContext) ifTrue: [ cp _ self pseudoCachedContextAt: instance. (self isCachedMethodContext: cp) ifTrue: [class _ self splObj: ClassMethodContext] ifFalse: [class _ self splObj: ClassBlockContext]]. self push: class! ! !DynamicInterpreter methodsFor: 'object access primitives' stamp: 'ikp 1/5/98 17:50'! primitiveClone "Return a shallow copy of the receiver." | newCopy | newCopy _ self clone: (self stackTop). self pop: 1 thenPush: newCopy.! ! !DynamicInterpreter methodsFor: 'object access primitives'! primitiveEquivalent | thisObject otherObject | otherObject _ self popStack. thisObject _ self popStack. self pushBool: thisObject = otherObject! ! !DynamicInterpreter 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]! ! !DynamicInterpreter 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]! ! !DynamicInterpreter methodsFor: 'object access primitives' stamp: 'ikp 8/12/97 23:30'! 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 ].! ! !DynamicInterpreter methodsFor: 'object access primitives' stamp: 'ikp 8/12/97 23:31'! 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 ].! ! !DynamicInterpreter 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]! ! !DynamicInterpreter 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 ].! ! !DynamicInterpreter 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]! ! !DynamicInterpreter 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]! ! !DynamicInterpreter 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.! ! !DynamicInterpreter methodsFor: 'object access primitives' stamp: 'ikp 12/6/97 00:47'! primitivePointX | rcvr | successFlag _ true. rcvr _ self popStack. self successIfClassOf: rcvr is: (self splObj: ClassPoint). successFlag ifTrue: [self push: (self fetchPointer: XIndex ofObject: rcvr)] ifFalse: [self unPop: 1. "self failSpecialPrim: 0" "will fail"]! ! !DynamicInterpreter methodsFor: 'object access primitives' stamp: 'ikp 12/6/97 00:48'! primitivePointY | rcvr | successFlag _ true. rcvr _ self popStack. self successIfClassOf: rcvr is: (self splObj: ClassPoint). successFlag ifTrue: [self push: (self fetchPointer: YIndex ofObject: rcvr)] ifFalse: [self unPop: 1. "self failSpecialPrim: 0" "will fail"]! ! !DynamicInterpreter methodsFor: 'object access primitives' stamp: 'di 1/14/98 09:24'! primitiveSomeInstance | class instance | class _ self popStack. instance _ self initialInstanceOf: class. instance = nilObj ifTrue: [self unPop: 1. self primitiveFail] ifFalse: [self push: instance]! ! !DynamicInterpreter methodsFor: 'object access primitives'! primitiveSomeObject "Return the first object in the heap." self pop: 1. self push: self firstAccessibleObject.! ! !DynamicInterpreter 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! ! !DynamicInterpreter methodsFor: 'control primitives' stamp: 'ikp 12/1/97 22:39'! initializeCachedBlockContext: context fromClosure: closure "Called by primitiveValue and primitiveValueWithArgs" | home initialIP hp method tMethod | self inline: true. self assertIsStableBlockContext: closure. home _ self fetchPointer: HomeIndex ofObject: closure. self cachedHomeAt: context put: home. (self isPseudoContext: home) ifTrue: [ hp _ self pseudoCachedContextAt: home. method _ (self cachedMethodAt: hp). tMethod _ (self cachedTranslatedMethodAt: hp). self cachedReceiverAt: context put: (self cachedReceiverAt: hp). self cachedMethodAt: context put: (method). self cachedTranslatedMethodAt: context put: (tMethod). " self cachedTemporaryPointerAt: context put: (self cachedFramePointerAt: hp)." self setTemporaryPointer: (self cachedFramePointerAt: hp). ] ifFalse: [ method _ (self fetchPointer: MethodIndex ofObject: home). tMethod _ (self fetchPointer: TranslatedMethodIndex ofObject: home). self cachedReceiverAt: context put: (self fetchPointer: ReceiverIndex ofObject: home). self cachedMethodAt: context put: (method). self cachedTranslatedMethodAt: context put: (tMethod). " self cachedTemporaryPointerAt: context put: (home + BaseHeaderSize + (TempFrameStart * 4))." self setTemporaryPointer: (home + BaseHeaderSize + (TempFrameStart * 4)). home < youngStart ifTrue: [self beRootIfOld: home]. ]. initialIP _ (self fetchPointer: InitialIPIndex ofObject: closure). self cachedInitialIPAt: context put: initialIP. self cachedInstructionIndexAt: context put: initialIP. ! ! !DynamicInterpreter methodsFor: 'control primitives' stamp: 'ikp 12/11/97 17:00'! primitiveBlockCopy | context methodContext contextSize newContext initialIP cp | context _ self stackValue: 1. self assertIsContext: context. (self isPseudoContext: context) ifTrue: [ cp _ self pseudoCachedContextAt: context. (self isCachedBlockContext: cp) ifTrue: [ methodContext _ self cachedHomeAt: cp. ] ifFalse: [ methodContext _ context. ]. ] ifFalse: [ (self isBlockContext: context) ifTrue: [ methodContext _ self fetchPointer: HomeIndex ofObject: context. ] ifFalse: [ methodContext _ context. ]. ]. self assertIsContext: methodContext. 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 translatedInstructionPointer: self instructionPointer toIndexIn: self translatedMethod) + (2 * "integer object weighting" 2). "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 unchecked stores." self storePointerUnchecked: CallerIndex ofObject: newContext withValue: nilObj. self storeWord: InstructionPointerIndex ofObject: newContext withValue: initialIP. self storeWord: StackPointerIndex ofObject: newContext withValue: ConstZero. self storeWord: BlockArgumentCountIndex ofObject: newContext withValue: (self stackValue: 0). self storeWord: InitialIPIndex ofObject: newContext withValue: initialIP. self storePointerUnchecked: HomeIndex ofObject: newContext withValue: methodContext. self pop: 2. "block argument count, rcvr" self push: newContext.! ! !DynamicInterpreter methodsFor: 'control primitives' stamp: 'ikp 1/14/98 20:39'! primitiveDoPrimitiveWithArgs | argumentArray primIdx arraySize index cntxSize stackSize | "Stack: ... receiver primitiveIndex argumentArray" self assertStackPointerIsExternal. argumentArray _ self stackTop. arraySize _ self fetchWordLengthOf: argumentArray. cntxSize _ (self wordLengthOfContext: activeCachedContext) - TempFrameStart. "max stack depth" stackSize _ (self stackPointer - (self cachedFramePointerAt: activeCachedContext)) // 4. "current stack depth" self success: (cntxSize - stackSize) > arraySize. self successIfClassOf: argumentArray is: (self splObj: ClassArray). primIdx _ self stackIntegerValue: 1. successFlag ifFalse: [^ self primitiveFail]. "invalid args" "Pop primIndex and argArray, then push args in place..." self pop: 2. newReceiver _ self stackTop. "is this actually necessary??" primitiveIndex _ primIdx. argumentCount _ arraySize. index _ 0. [index < arraySize] whileTrue: [self push: (self fetchPointer: index ofObject: argumentArray). index _ index + 1]. "Run the primitive (sets successFlag)" self pushRemappableOop: argumentArray. "prim might alloc" self primitiveResponse. "pseudo receivers will already be flushed by the calling primResponse" argumentArray _ self popRemappableOop. successFlag ifFalse: [ self pop: arraySize. "prim might clobber argumentCount" self pushInteger: primIdx. "prim might clobber primitiveIndex" self push: argumentArray. argumentCount _ 2. "... caller (execNewMeth) will run failure code"]! ! !DynamicInterpreter methodsFor: 'control primitives' stamp: 'ikp 11/30/97 16:06'! primitivePerform | performSelector | self assertStackPointerIsExternal. 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 pushRemappableOop: performSelector. "** self lookupMethodInClass: (self fetchClassOf: newReceiver). **" "provokes GC!!" self findNewMethodInClass: (self fetchClassOf: newReceiver). "provokes GC!!" performSelector _ self popRemappableOop. self success: (self argumentCountOf: newMethod) = argumentCount. successFlag ifTrue: [ "Remove the #perform: from the stack" self inlineTransfer: argumentCount "N" wordsFrom: self stackPointer - (argumentCount * 4) + 4 "[arg1 arg2 ... argN]" to: self stackPointer - (argumentCount * 4). "[selector arg1 arg2 ... argN]" self pop: 1. self executeNewMethod. "Recursive xeq affects successFlag" successFlag _ true. ] ifFalse: [ argumentCount _ argumentCount + 1. messageSelector _ performSelector. ]! ! !DynamicInterpreter methodsFor: 'control primitives' stamp: 'ikp 11/30/97 16:07'! primitivePerformWithArgs | performSelector argumentArray arraySize index cntxSize stackSize numArgs | self assertStackPointerIsExternal. argumentArray _ self popStack. arraySize _ self fetchWordLengthOf: argumentArray. cntxSize _ (self wordLengthOfContext: activeCachedContext) - TempFrameStart. "max stack depth" stackSize _ (self stackPointer - (self cachedFramePointerAt: activeCachedContext)) // 4. "current stack depth" self success: (cntxSize - stackSize) > arraySize. self successIfClassOf: argumentArray is: (self splObj: ClassArray). successFlag ifTrue: [ performSelector _ messageSelector. messageSelector _ self popStack. newReceiver _ self stackTop. numArgs _ argumentCount _ arraySize. index _ 0. [index < numArgs] whileTrue: [ self push: (self fetchPointer: index ofObject: argumentArray). index _ index + 1]. self pushRemappableOop: performSelector. self pushRemappableOop: argumentArray. "*** self lookupMethodInClass: (self fetchClassOf: newReceiver)." "provokes GC!!" self findNewMethodInClass: (self fetchClassOf: newReceiver). "provokes GC!!" argumentArray _ self popRemappableOop. performSelector _ self popRemappableOop. 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. ]! ! !DynamicInterpreter methodsFor: 'control primitives' stamp: 'ikp 8/27/97 10:44'! primitiveValue | blockContext blockArgumentCount newContext newFrame oldSP oldContext numArgs | self assertStackPointerIsExternal. numArgs _ argumentCount. blockContext _ self stackValue: numArgs. self assertIsStableBlockContext: blockContext. blockArgumentCount _ self argumentCountOfBlock: blockContext. self success: (numArgs = blockArgumentCount and: [(self fetchPointer: CallerIndex ofObject: blockContext) = nilObj]). successFlag ifTrue: [ oldContext _ activeCachedContext. oldSP _ self cachedStackPointerAt: oldContext. newFrame _ oldSP - (numArgs * 4) + 4. "first argument" self pushRemappableOop: blockContext. newContext _ self allocateCachedContextAfter: oldContext frame: newFrame. "GC!!" blockContext _ self popRemappableOop. self cachedStackPointerAt: oldContext put: (newFrame - 8). "updated AFTER possible GC" stackOverflow ifTrue: [ newFrame _ self cachedFramePointerAt: newContext. self transfer: numArgs wordsFrom: oldSP - (numArgs * 4) + 4 "first argument" to: newFrame. stackOverflow _ false. ]. self initializeCachedBlockContext: newContext fromClosure: blockContext. self cachedStackPointerAt: newContext put: (newFrame + (numArgs * 4) - 4). self cachedBlockArgumentCountAt: newContext put: (self integerObjectOf: blockArgumentCount). " self fetchContextRegisters: newContext." ]! ! !DynamicInterpreter methodsFor: 'control primitives' stamp: 'ikp 8/27/97 10:44'! primitiveValueWithArgs | argumentArray blockContext blockArgumentCount arrayArgumentCount newContext newFrame oldSP | self assertStackPointerIsExternal. argumentArray _ self popStack. blockContext _ self popStack. self assertIsStableBlockContext: blockContext. blockArgumentCount _ self argumentCountOfBlock: blockContext. self successIfClassOf: argumentArray is: (self splObj: ClassArray). successFlag ifTrue: [ arrayArgumentCount _ self fetchWordLengthOf: argumentArray. "Note: refusing to activate a block context that is already activated used to be necessary when block contexts were reused during their activations. This restriction could easily be relaxed now that they are copied for evaluation." self success: (arrayArgumentCount = blockArgumentCount and: [(self fetchPointer: CallerIndex ofObject: blockContext) = nilObj])]. successFlag ifTrue: [ oldSP _ self stackPointer. newFrame _ oldSP + 4. "first free location" self pushRemappableOop: argumentArray. self pushRemappableOop: blockContext. newContext _ self allocateCachedContextAfter: activeCachedContext frame: newFrame. blockContext _ self popRemappableOop. argumentArray _ self popRemappableOop. stackOverflow ifTrue: [ newFrame _ self cachedFramePointerAt: newContext. stackOverflow _ false. ]. self inlineTransfer: arrayArgumentCount wordsFrom: argumentArray + BaseHeaderSize to: newFrame. self initializeCachedBlockContext: newContext fromClosure: blockContext. self cachedStackPointerAt: newContext put: (newFrame + (blockArgumentCount * 4) - 4). self cachedBlockArgumentCountAt: newContext put: (self integerObjectOf: blockArgumentCount). " self fetchContextRegisters: newContext." ] ifFalse: [ self push: blockContext. self push: argumentArray. ].! ! !DynamicInterpreter 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.! ! !DynamicInterpreter methodsFor: 'processes' stamp: 'di 2/4/98 23:55'! checkForInterrupts "Check for possible interrupts and handle one if necessary." | sema now index externalObjects semaClass | self inline: false. "Mask so same wrap as primitiveMillisecondClock" now _ self ioMSecs bitAnd: 16r1FFFFFFF. 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]. ! ! !DynamicInterpreter methodsFor: 'processes'! internalQuickCheckForInterrupts "Internal version of quickCheckForInterrupts for use within jumps." ((interruptCheckCounter _ interruptCheckCounter - 1) <= 0) ifTrue: [ interruptCheckCounter _ 1000. self externalizeIPandSP. self checkForInterrupts. self internalizeIPandSP. ]. ! ! !DynamicInterpreter methodsFor: 'processes'! isEmptyList: aLinkedList ^ (self fetchPointer: FirstLinkIndex ofObject: aLinkedList) = nilObj! ! !DynamicInterpreter methodsFor: 'processes'! primitiveResume | proc | proc _ self stackTop. "rcvr" "self success: ((self fetchClassOf: proc) = (self splObj: ClassProcess))." successFlag ifTrue: [ self resume: proc ].! ! !DynamicInterpreter methodsFor: 'processes' stamp: 'ikp 8/18/97 11:11'! primitiveSignal | sema | sema _ self stackTop. "rcvr" self successIfClassOf: sema is: (self splObj: ClassSemaphore). successFlag ifTrue: [ self synchronousSignal: sema ].! ! !DynamicInterpreter 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. ].! ! !DynamicInterpreter methodsFor: 'processes' stamp: 'ikp 8/18/97 11:11'! primitiveWait | sema excessSignals activeProc | sema _ self stackTop. "rcvr" self successIfClassOf: 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. ]. ].! ! !DynamicInterpreter 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.! ! !DynamicInterpreter 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. ]. ! ! !DynamicInterpreter 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! ! !DynamicInterpreter 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. ].! ! !DynamicInterpreter methodsFor: 'processes'! schedulerPointer ^ self fetchPointer: ValueIndex ofObject: (self splObj: SchedulerAssociation)! ! !DynamicInterpreter methodsFor: 'processes' stamp: 'ikp 9/29/97 21:14'! 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]. ! ! !DynamicInterpreter 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). ].! ! !DynamicInterpreter methodsFor: 'processes' stamp: 'ikp 8/26/97 01:02'! transferTo: newProcArg "Record a process to be awoken on the next interpreter cycle. Assumes: IP and SP are external." | sched oldProc suspendedContext newProc | self pushRemappableOop: newProcArg. suspendedContext _ self flushCacheFrom: activeCachedContext. "GC!!" newProc _ self popRemappableOop. self assertIsStableContext: suspendedContext. self assertIsProcess: newProc. sched _ self schedulerPointer. oldProc _ self fetchPointer: ActiveProcessIndex ofObject: sched. self storePointer: SuspendedContextIndex ofObject: oldProc withValue: suspendedContext. self storePointer: ActiveProcessIndex ofObject: sched withValue: newProc. suspendedContext _ self fetchPointer: SuspendedContextIndex ofObject: newProc. self assertIsStableContext: suspendedContext. self copyContextToCache: suspendedContext. self fetchContextRegisters: activeCachedContext.! ! !DynamicInterpreter 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! ! !DynamicInterpreter 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)'. ].! ! !DynamicInterpreter 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)'. ].! ! !DynamicInterpreter 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. ].! ! !DynamicInterpreter methodsFor: 'I/O primitives'! primitiveBeep self ioBeep.! ! !DynamicInterpreter 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. ].! ! !DynamicInterpreter methodsFor: 'I/O primitives' stamp: 'jm 5/18/1998 13:34'! primitiveDeferDisplayUpdates "Set or clear the flag that controls whether modifications of the Display object are propagated to the underlying platform's screen." | flag | flag _ self stackTop. flag = trueObj ifTrue: [deferDisplayUpdates _ true] ifFalse: [ flag = falseObj ifTrue: [deferDisplayUpdates _ false] ifFalse: [self primitiveFail]]. successFlag ifTrue: [self pop: 1]. "pop flag; leave rcvr on stack" ! ! !DynamicInterpreter 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].! ! !DynamicInterpreter methodsFor: 'I/O primitives' stamp: 'jm 5/18/1998 13:35'! primitiveForceDisplayUpdate "On some platforms, this primitive forces enqueued display updates to be processed immediately. On others, it does nothing." self ioForceDisplayUpdate. ! ! !DynamicInterpreter 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. ].! ! !DynamicInterpreter 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"! ! !DynamicInterpreter 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. ].! ! !DynamicInterpreter 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

'; cr. ^ stream contents! ! !HTMLformatter class methodsFor: 'pages and forms' stamp: 'mjg 10/31/97 15:57'! startPage: title | stream | stream _ WriteStream on: ''. stream nextPutAll: ''; cr; nextPutAll: '';cr; nextPutAll: '';cr; nextPutAll: ''; nextPutAll: title; nextPutAll: '';cr; nextPutAll: ''; cr. ^ stream contents! ! !HTMLformatter class methodsFor: 'translating' stamp: 'ls 4/18/98 16:23'! evalEmbedded: stringOrStream with: request | formatter | formatter _ self forEvaluatingEmbedded: stringOrStream. ^formatter format: request! ! !HTMLformatter class methodsFor: 'translating' stamp: 'mjg 1/29/98 21:40'! evalEmbedded: string with: request unlessContains: dangerSet dangerSet do: [:each | (string includesSubstring: each caseSensitive: false) ifTrue: [^'Unsafe code!!']]. ^self evalEmbedded: string with: request ! ! !HTMLformatter class methodsFor: 'translating' stamp: 'mjg 11/25/97 11:50'! fixEndings: aStringOrStream | sourceStream targetStream aLine | (aStringOrStream isKindOf: Stream) ifTrue: [sourceStream := aStringOrStream] ifFalse: [sourceStream := ReadStream on: aStringOrStream]. targetStream := ReadWriteStream on: String new. [sourceStream atEnd] whileFalse: [aLine := sourceStream upTo: (Character linefeed). targetStream nextPutAll: aLine. targetStream nextPut: Character cr.]. ^targetStream ! ! !HTMLformatter class methodsFor: 'translating' stamp: 'ls 5/1/98 09:28'! forEvaluatingEmbedded: stringOrStream "stringOrStream is text with expressions intermingled. This creates a HTLMLformatter instance which will substitute the expressions with the value of the argument (named request), and which leaves all other text in stringOrStream alone" | blockStream sourceStream doingEval ch | blockStream _ WriteStream on: String new. blockStream nextPutAll: '[ :request :output | output nextPutAll: '''. (stringOrStream isKindOf: Stream) ifTrue: [sourceStream := stringOrStream] ifFalse: [sourceStream := ReadStream on: stringOrStream]. doingEval _ false. [sourceStream atEnd] whileFalse: [ ch := sourceStream next. (doingEval not and: [ ch = $< and: [ sourceStream peek = $? ]]) ifTrue: [ "beginning of an expression" blockStream nextPutAll: '''. output nextPutAll: ['. sourceStream next. "Skip the ?" doingEval _ true] ifFalse: [ (doingEval and: [ ch = $? and: [ sourceStream peek = $> ]]) ifTrue: [ "end of a expression" blockStream nextPutAll: '] value asString. output nextPutAll: '''. sourceStream next. "Skip the >" doingEval _ false.] ifFalse: [ "normal char" blockStream nextPut: ch. (doingEval not and: [ ch = $' ]) ifTrue: [ "double $' marks" blockStream nextPut: $' ] ] ] ]. "end the block" doingEval ifTrue: [ blockStream nextPutAll: '] value asString' ] ifFalse: [ blockStream nextPutAll: '''' ]. blockStream nextPutAll: ']'. ^HTMLformatter new formattingBlock: (Compiler evaluate: blockStream contents)! ! !HTMLformatter class methodsFor: 'translating' stamp: 'ls 4/18/98 16:38'! oldEvalEmbedded: stringOrStream with: request | sourceStream targetStream evalStream currentStream evalValue peekValue ch | (stringOrStream isKindOf: Stream) ifTrue: [sourceStream := stringOrStream] ifFalse: [sourceStream := ReadStream on: stringOrStream]. targetStream := WriteStream on: String new. currentStream := targetStream. [sourceStream atEnd] whileFalse: [ch := sourceStream next. ch = $< ifTrue: [ peekValue := sourceStream peek. (peekValue = $?) ifTrue: [evalStream := WriteStream on: String new. currentStream := evalStream. sourceStream next. "Eat the ?" ch := sourceStream next.]]. ((currentStream = evalStream) and: [ch = $?]) ifTrue: [ peekValue := sourceStream peek. (peekValue = $>) ifTrue: [sourceStream next. "Eat the >" currentStream := targetStream. evalValue := (Compiler new evaluate: (evalStream contents) in: thisContext to: self notifying: nil ifFail: [^nil]). (evalValue isKindOf: String) ifFalse: [evalValue := evalValue printString]. currentStream nextPutAll: evalValue.]] ifFalse: [currentStream nextPut: ch].]. ^targetStream contents ! ! !HTMLformatter class methodsFor: 'translating' stamp: 'tk 1/14/98 10:30'! rangesOfAngleBrackets: sourceStrm "Return an OrderedCollection of intervals of position within angle brackets < and >. Caller wants to avoid putting
in there." | list char intervals start | list _ OrderedCollection new: 10. [sourceStrm atEnd] whileFalse: [ (char _ sourceStrm next) == $< ifTrue: [list add: sourceStrm position]. "a start" char == $> ifTrue: [list add: sourceStrm position negated]]. "an end" sourceStrm reset. intervals _ OrderedCollection new: 10. start _ nil. list do: [:each | (each > 0) & (start == nil) ifTrue: [start _ each]. (each < 0) & (start ~~ nil) ifTrue: [ intervals add: (start to: each negated). start _ nil]]. ^ intervals " HTMLformatter rangesOfAngleBrackets: (ReadStream on: '1234 <456 567> ') "! ! !HTMLformatter class methodsFor: 'translating' stamp: 'mjg 11/10/97 12:38'! simpleProcess: aStringOrStream | sourceStream targetStream ch | (aStringOrStream isKindOf: Stream) ifTrue: [sourceStream := aStringOrStream] ifFalse: [sourceStream := ReadStream on: aStringOrStream]. targetStream := WriteStream on: String new. [sourceStream atEnd] whileFalse: [ch := sourceStream next. (ch = Character linefeed) ifTrue: [(sourceStream peek) = (Character linefeed) ifTrue: [sourceStream next. targetStream nextPutAll: '

'] ifFalse: [targetStream nextPutAll: '
']]. targetStream nextPut: ch]. ^targetStream contents. ! ! !HTMLformatter class methodsFor: 'translating' stamp: 'mjg 5/1/98 13:12'! swikify: aStringOrStream linkhandler: aBlock | sourceStream aLine targetStream start end forbidden ignore | (aStringOrStream isKindOf: Stream) ifTrue: [sourceStream := aStringOrStream] ifFalse: [sourceStream := ReadStream on: aStringOrStream]. forbidden _ self rangesOfAngleBrackets: sourceStream. targetStream := WriteStream on: String new. [sourceStream atEnd] whileFalse: [aLine := sourceStream upTo: (Character linefeed). " Now, look for links " start _ 1. [(start _ aLine indexOfSubCollection: '*' startingAt: start ifAbsent: [0]) ~= 0 and: [start < aLine size]] whileTrue: [(aLine at: start+1) = $* ifTrue: [aLine _ aLine copyReplaceFrom: start to: start+1 with: '*'. start_start + 1.] ifFalse: [ (end _ aLine indexOfSubCollection: '*' startingAt: (start+1) ifAbsent: [0]) ~= 0 ifTrue: [aLine _ aLine copyReplaceFrom: start to: end with: (aBlock value: (aLine copyFrom: start+1 to: end-1))] ifFalse: [start _ start + 1]]]. "If it's at least 4 dashes, make it a horizontal rule" (aLine indexOfSubCollection: '----' startingAt: 1) = 1 ifTrue: [targetStream nextPutAll: '


'] ifFalse: [targetStream nextPutAll: aLine]. "Should there be a
after this line?" (ignore _ sourceStream peek = $<) ifTrue: [ "If just before a tag, ignore the newline" targetStream nextPut: $ ]. "but do put in a separator" forbidden do: [:interval | (interval includes: sourceStream position) ifTrue: [ignore _ true]]. ignore ifFalse: [ (sourceStream peek) = (Character linefeed) ifTrue: [sourceStream next. targetStream nextPutAll: '

'] ifFalse: [targetStream nextPutAll: '
']]]. ^targetStream contents. ! ! !HTMLformatter class methodsFor: 'translating' stamp: 'mjg 12/8/97 11:37'! textToGIF: oneLineString | form filename | form _ (Form extent: 400@20 depth: Display depth) fillWhite. oneLineString displayOn: form at: 2@0. "form display." filename _ 'f',(SmallInteger maxVal atRandom) printString,'.gif'. GIFReadWriter putForm: form onFileNamed: filename. ^(FileStream fileNamed: filename) contentsOfEntireFile ! ! !HTMLformatter class methodsFor: 'formatting' stamp: 'mjg 10/31/97 15:48'! checkbox: buttonname value: b ^ ''! ! !HTMLformatter class methodsFor: 'formatting' stamp: 'mjg 10/24/97 16:56'! formFooter "Write the standard footer for a form." self reply: '


' ! ! !HTMLformatter class methodsFor: 'formatting' stamp: 'mjg 10/24/97 16:58'! formHeader: title For: aReference "Write the standard header for a page and form for editing anObject." self title: title; reply: '
' ! ! !HTMLformatter class methodsFor: 'formatting' stamp: 'mjg 10/31/97 15:54'! graphic: f ^self graphic: f standIn: 'Picture' alignment: 'right'! ! !HTMLformatter class methodsFor: 'formatting' stamp: 'mjg 10/31/97 15:53'! graphic: f standIn: s alignment: a ^ '' , s , ''! ! !HTMLformatter class methodsFor: 'formatting' stamp: 'mjg 10/31/97 15:55'! hiddenName: n value: v ^ ''! ! !HTMLformatter class methodsFor: 'formatting' stamp: 'mjg 10/31/97 16:02'! linkTo: url label: label ^'',label,''.! ! !HTMLformatter class methodsFor: 'formatting' stamp: 'mjg 10/31/97 15:50'! select: n values: values selection: selection size: size ^ self select: n values: values selections: (Array with: selection) size: size multiple: false! ! !HTMLformatter class methodsFor: 'formatting' stamp: 'mjg 10/31/97 15:49'! select: buttonname values: values selections: selections size: size multiple: multiple | stream | stream _ WriteStream on: ''. stream nextPutAll: ''. ^ stream contents! ! !HTMLformatter class methodsFor: 'formatting' stamp: 'mjg 10/31/97 15:53'! submit: label ^ self submit: 'submit' label: label! ! !HTMLformatter class methodsFor: 'formatting' stamp: 'mjg 10/31/97 15:52'! submit: buttonName label: v ^ ''! ! !HTMLformatter class methodsFor: 'formatting' stamp: 'mjg 10/31/97 15:51'! text: fieldName ^ self text: fieldName value: '' length: 80. ! ! !HTMLformatter class methodsFor: 'formatting' stamp: 'mjg 10/31/97 15:51'! text: fieldName value: v length: l ^ ''! ! !HTMLformatter class methodsFor: 'formatting' stamp: 'mjg 11/4/97 14:30'! textArea: fieldName ^ (self textAreaStart: fieldName rows: 15 cols: 70), self textAreaEnd! ! !HTMLformatter class methodsFor: 'formatting' stamp: 'mjg 11/4/97 14:30'! textArea: fieldName value: value ^ (self textAreaStart: fieldName rows: 15 cols: 70), value, self textAreaEnd! ! !HTMLformatter class methodsFor: 'formatting' stamp: 'mjg 11/4/97 14:28'! textAreaEnd ^ '' ! ! !HTMLformatter class methodsFor: 'formatting' stamp: 'mjg 11/4/97 14:28'! textAreaStart: fieldName rows: rows cols: cols ^ '